{-# LANGUAGE LambdaCase #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Template Haskell function for getting the git revision from the local
-- repo. This is a separate module due to the GHC stage restriction.

module Cardano.Wallet.Version.TH
    ( gitRevFromGit
    ) where

import Prelude

import Fmt
    ( fmt, (+|), (+||), (|+), (||+) )
import Language.Haskell.TH
    ( Exp (..), Lit (..), Q, runIO )
import System.Exit
    ( ExitCode (..) )
import System.IO
    ( hPutStrLn, stderr )
import System.IO.Error
    ( isDoesNotExistError )
import UnliftIO.Exception
    ( handle )
import UnliftIO.Process
    ( readProcessWithExitCode )

-- | Git revision found by running @git rev-parse@. If @git@ could not be
-- executed, then this will be an empty string.
gitRevFromGit :: Q Exp
gitRevFromGit :: Q Exp
gitRevFromGit = Lit -> Exp
LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL (String -> Exp) -> Q String -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> Q String
forall a. IO a -> Q a
runIO IO String
runGitRevParse
  where
    runGitRevParse :: IO String
    runGitRevParse :: IO String
runGitRevParse = String -> [String] -> IO (Either String String)
run String
"git" [String
"rev-parse", String
"--verify", String
"HEAD"] IO (Either String String)
-> (Either String String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right String
output -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
output
        Left String
errorMessage -> do
            -- This message will appear in the build logs
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"WARNING (gitRevFromGit): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorMessage
            String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""

    run :: FilePath -> [String] -> IO (Either String String)
    run :: String -> [String] -> IO (Either String String)
run String
cmd [String]
args = IO (ExitCode, String, String) -> IO (Either String String)
forall b. IO (ExitCode, b, String) -> IO (Either String b)
handleProcess (IO (ExitCode, String, String) -> IO (Either String String))
-> IO (ExitCode, String, String) -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
forall (m :: * -> *).
MonadIO m =>
String -> [String] -> String -> m (ExitCode, String, String)
readProcessWithExitCode String
cmd [String]
args String
""
      where
        handleProcess :: IO (ExitCode, b, String) -> IO (Either String b)
handleProcess = (IOError -> IO (Either String b))
-> IO (Either String b) -> IO (Either String b)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle (Either String b -> IO (Either String b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String b -> IO (Either String b))
-> (IOError -> Either String b) -> IOError -> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b)
-> (IOError -> String) -> IOError -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> String
errMsg) (IO (Either String b) -> IO (Either String b))
-> (IO (ExitCode, b, String) -> IO (Either String b))
-> IO (ExitCode, b, String)
-> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ExitCode, b, String) -> Either String b)
-> IO (ExitCode, b, String) -> IO (Either String b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ExitCode, b, String) -> Either String b
forall b. (ExitCode, b, String) -> Either String b
handleExitCode

        handleExitCode :: (ExitCode, b, String) -> Either String b
handleExitCode = \case
            (ExitCode
ExitSuccess, b
output, String
_) -> b -> Either String b
forall a b. b -> Either a b
Right b
output
            (ExitFailure Int
code, b
_, String
err) -> String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ Builder -> String
forall b. FromBuilder b => Builder -> b
fmt (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$
                String
cmd'String -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
" exited with status "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|Int
codeInt -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
": "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|String
errString -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
""

        cmd' :: String
cmd' = [String] -> String
unwords (String
cmdString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args)

        errMsg :: IOError -> String
errMsg IOError
e = if IOError -> Bool
isDoesNotExistError IOError
e
            then Builder -> String
forall b. FromBuilder b => Builder -> b
fmt (Builder
"Could not find "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|String
cmdString -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+Builder
": "Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+||IOError
eIOError -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+Builder
"")
            else IOError -> String
forall a. Show a => a -> String
show IOError
e