Implement type command to get gpg path

teggotic · teggotic · commit 9165e6f2657d · 2023-03-12T20:07:45.000+02:00
`type` command is only available as the shell command which means that we can't use `proc`. This means we should use `shell` instead. However, using `shell` is not safe, and escaping is needed to make sure args are mungled. This is the reason why I use `shell` only for `type` command and `proc` for everything else. #297
diff --git a/.github/workflows/haskell-quality-pipeline.yml b/.github/workflows/haskell-quality-pipeline.yml
@@ -26,15 +26,6 @@ jobs:
 
     steps:
     - uses: actions/checkout@v3
-    - uses: actions/cache@v3
-      name: Cache .ghcup
-      id: haskell-env-cache
-      with:
-        path: ~/.ghcup
-        key: ${{ runner.os }}-ghcup-global-${{ env.GHCUP_VERSION }}-${{ env.STACK_VERSION }}
-        restore-keys: |
-          ${{ runner.os }}-ghcup-global-${{ env.GHCUP_VERSION }}-
-          ${{ runner.os }}-ghcup-global-
     - uses: actions/cache@v3
       name: Cache .stack
       id: haskell-deps-cache
diff --git a/src/Elegit/Cli/Action/AcquireRepository.hs b/src/Elegit/Cli/Action/AcquireRepository.hs
@@ -83,8 +83,8 @@ configDefault cKey = case cKey of
 configureBasics :: (MonadFree GA.GitF m) => GA.ConfigScope -> m ()
 configureBasics cScope = do
     for_ basicConfigs $ \cKey -> do
-        keyDefault <- configDefault cKey
-        newValue <- GA.promptDefault (configPrompt cKey) keyDefault
+        mKeyDefault <- configDefault cKey
+        newValue <- GA.promptDefault (configPrompt cKey) mKeyDefault
         GA.setConfigVerbose cScope (configName cKey) newValue
 
     where
@@ -150,36 +150,38 @@ configureAliases cScope = do
             ]
 
 
+-- TODO: This could be improved syntastically if we use `mdo` instead of plain `do`
 setupGPGSignature :: (MonadFree GA.GitF m) => m ()
 setupGPGSignature = do
     whenJustM (GA.readConfig GA.LocalConfig (configName UserEmailKey)) $ \userEmail -> do
-        GA.gpgListKeysVerbose userEmail >>= \case
-            Nothing -> do
-                GA.print =<< GA.formatInfo "There is no gpg key for the given email."
-                GA.print =<< GA.formatInfo "A signature is not configured."
-            Just gpgKeysOutput -> do
-                mapM_ GA.print gpgKeysOutput
-                GA.print ""
-                GA.print =<< GA.formatInfo "From the list of GPG keys above, copy the GPG key ID you'd like to use."
-                GA.print =<< GA.formatInfo "It will be"
-                GA.print =<< GA.formatInfo "    3AA5C34371567BD2"
-                GA.print =<< GA.formatInfo "for the output like this"
-                GA.print =<< GA.formatInfo "    sec   4096R/3AA5C34371567BD2 2016-03-10 [expires: 2017-03-10]"
-                GA.print =<< GA.formatInfo "    A330C91F8EC4BC7AECFA63E03AA5C34371567BD2"
-                GA.print =<< GA.formatInfo "    uid                          Hubot"
-                GA.print =<< GA.formatInfo ""
-                GA.print =<< GA.formatInfo "If you don't want to configure signature, just hit Enter button."
-                -- TODO: We could parse IDs out of the gpg output.
-                -- Then could ask for the index into list of keys instead?
-                key <- GA.promptDefault "Please pass a key that has to sign objects of the current repository: " (Just "")
-                if null key
-                   then GA.print =<< GA.formatInfo "The signature is not configured as the empty key is provided."
-                   else do
-                       GA.setConfigVerbose GA.LocalConfig "user.signingkey" key
-                       GA.setConfigVerbose GA.LocalConfig "gpg.program" "$(type -p gpg)"
-                       GA.setConfigVerbose GA.LocalConfig "commit.gpgsign" "true"
-                       GA.setConfigVerbose GA.LocalConfig "tag.forceSignAnnotated" "true"
-                       GA.setConfigVerbose GA.LocalConfig "tag.gpgSign" "true"
+        whenJustM (GA.pathToTool "gpg") $ \pathToGPG -> do
+            GA.gpgListKeysVerbose userEmail >>= \case
+                Nothing -> do
+                    GA.print =<< GA.formatInfo "There is no gpg key for the given email."
+                    GA.print =<< GA.formatInfo "A signature is not configured."
+                Just gpgKeysOutput -> do
+                    mapM_ GA.print gpgKeysOutput
+                    GA.print ""
+                    GA.print =<< GA.formatInfo "From the list of GPG keys above, copy the GPG key ID you'd like to use."
+                    GA.print =<< GA.formatInfo "It will be"
+                    GA.print =<< GA.formatInfo "    3AA5C34371567BD2"
+                    GA.print =<< GA.formatInfo "for the output like this"
+                    GA.print =<< GA.formatInfo "    sec   4096R/3AA5C34371567BD2 2016-03-10 [expires: 2017-03-10]"
+                    GA.print =<< GA.formatInfo "    A330C91F8EC4BC7AECFA63E03AA5C34371567BD2"
+                    GA.print =<< GA.formatInfo "    uid                          Hubot"
+                    GA.print =<< GA.formatInfo ""
+                    GA.print =<< GA.formatInfo "If you don't want to configure signature, just hit Enter button."
+                    -- TODO: We could parse IDs out of the gpg output.
+                    -- Then could ask for the index into list of keys instead?
+                    key <- GA.promptOneTime "Please pass a key that has to sign objects of the current repository"
+                    if null key
+                       then GA.print =<< GA.formatInfo "The signature is not configured as the empty key is provided."
+                       else do
+                           GA.setConfigVerbose GA.LocalConfig "user.signingkey" key
+                           GA.setConfigVerbose GA.LocalConfig "gpg.program" pathToGPG
+                           GA.setConfigVerbose GA.LocalConfig "commit.gpgsign" "true"
+                           GA.setConfigVerbose GA.LocalConfig "tag.forceSignAnnotated" "true"
+                           GA.setConfigVerbose GA.LocalConfig "tag.gpgSign" "true"
 
 
 -- | Execution description of the AcquireRepository action
diff --git a/src/Elegit/Git/Action.hs b/src/Elegit/Git/Action.hs
@@ -96,7 +96,9 @@ data GReadConfigData
       }
 
 instance RenderGitCommand GReadConfigData where
-  commandArgs (GReadConfigData cScope cName) = ["config", scopeText, "--get", cName]
+  commandArgs (GReadConfigData cScope cName) =
+    filter (not . null)
+      ["config", scopeText, "--get", cName]
     where
       scopeText :: Text
       scopeText = case cScope of
@@ -112,7 +114,9 @@ data GSetConfigData
       }
 
 instance RenderGitCommand GSetConfigData where
-  commandArgs (GSetConfigData cScope cName cValue) = ["config", scopeText, cName, "\""+|cValue|+"\""]
+  commandArgs (GSetConfigData cScope cName cValue) =
+    filter (not . null)
+      ["config", scopeText, cName, cValue]
     where
       scopeText :: Text
       scopeText = case cScope of
@@ -140,14 +144,22 @@ newtype GAliasesToRemoveData
 
 instance RenderGitCommand GAliasesToRemoveData where
   commandArgs (GAliasesToRemoveData cScope) =
-    ["config", scopeText, "--name-only", "--get-regexp", "\"^alias.\"", "\"^elegant ([-a-z]+)$\""]
+    ["config", scopeText, "--name-only", "--get-regexp", "^alias.", "^elegant ([-a-z]+)$"]
     where
       scopeText :: Text
       scopeText = case cScope of
                 GlobalConfig -> "--global"
                 LocalConfig  -> "--local"
                 AutoConfig   -> ""
 
+newtype GPathToToolData
+  = GPathToToolData { name :: Text }
+
+instance RenderGitCommand GPathToToolData where
+  toolName _ = "type"
+
+  commandArgs (GPathToToolData toolName') = ["-p", toolName']
+
 newtype GGPGKeyListData
   = GGPGKeyListData { email :: Text }
 
@@ -175,7 +187,8 @@ data GitF a
   | SetConfig GSetConfigData a
   | UnsetConfig GUnsetConfigData a
   | GPGListKeys GGPGKeyListData (Maybe (NonEmpty Text) -> a)
-  | Prompt Text (Maybe Text) (Text -> a)
+  | PathToTool GPathToToolData (Maybe Text -> a)
+  | Prompt PromptConfig (Text -> a)
   | FormatInfo Text (Text -> a)
   | FormatCommand Text (Text -> a)
   | PrintText Text a
@@ -205,6 +218,21 @@ data LogType
 -- | Type alias to the `Free` `GitF` monad.
 type FreeGit t = F GitF t
 
+
+-- TODO: Make `OneTime` separate to improve the return type of the prompt
+-- OneTime should return `Maybe Text` instead of `Text` to indicate 2 possible states.
+-- Default would always return Text, as there is no possibity to go forward otherwise.
+data PromptType
+  = PromptOneTime
+  | PromptDefault (Maybe Text)
+
+
+data PromptConfig
+  = PromptConfig
+      { question   :: Text
+      , promptType :: PromptType
+      }
+
 -- | You should consider following code as a boilerplate
 --
 -- Each command should have the associated function to simplify the usage of this API.
@@ -254,8 +282,14 @@ unsetConfig cScope cName = liftF $ UnsetConfig (GUnsetConfigData cScope cName) (
 gpgListKeys :: MonadFree GitF m => Text -> m (Maybe (NonEmpty Text))
 gpgListKeys gEmail = liftF $ GPGListKeys (GGPGKeyListData gEmail) id
 
+pathToTool :: MonadFree GitF m => Text -> m (Maybe Text)
+pathToTool toolName' = liftF $ PathToTool (GPathToToolData toolName') id
+
 promptDefault :: MonadFree GitF m => Text -> Maybe Text -> m Text
-promptDefault pText pDefault = liftF $ Prompt pText pDefault id
+promptDefault pText pDefault = liftF $ Prompt (PromptConfig pText (PromptDefault pDefault)) id
+
+promptOneTime :: MonadFree GitF m => Text -> m Text
+promptOneTime pText = liftF $ Prompt (PromptConfig pText PromptOneTime) id
 
 formatInfo :: MonadFree GitF m => Text -> m Text
 formatInfo content = liftF $ FormatInfo content id
diff --git a/src/Elegit/Git/Exec.hs b/src/Elegit/Git/Exec.hs
@@ -2,9 +2,10 @@ module Elegit.Git.Exec where
 
 import           Control.Monad.Catch  as MC
 import           Data.Text            (stripEnd)
+import qualified Data.Text            as T
 import           Elegit.Git.Action
 import           GHC.IO.Handle        (hFlush)
-import           System.Process.Typed (ExitCode (ExitFailure, ExitSuccess), ProcessConfig, proc, readProcess)
+import           System.Process.Typed (ExitCode (ExitFailure, ExitSuccess), ProcessConfig, proc, readProcess, shell)
 import           Universum            as U
 
 
@@ -24,24 +25,30 @@ data GitCommand
   | GCUC GUnsetConfigData
   | GCATR GAliasesToRemoveData
   | GCGKL GGPGKeyListData
+  | GCPTT GPathToToolData
 
 
-procText :: Text -> [Text] -> ProcessConfig () () ()
-procText name args = proc (toString name) (toString <$> args)
+procCmd :: Text -> [Text] -> ProcessConfig () () ()
+procCmd tName args = proc (toString tName) (toString <$> args)
+
+
+shellCmd :: Text -> [Text] -> ProcessConfig () () ()
+shellCmd tName args = shell $ toString $ T.intercalate " " (tName:args)
 
 
 -- TODO: cover with tests
 procFromCmd :: GitCommand -> ProcessConfig () () ()
-procFromCmd (GCCB gc)  = procText (toolName gc) (commandArgs gc)
-procFromCmd (GCBU gc)  = procText (toolName gc) (commandArgs gc)
-procFromCmd (GCL gc)   = procText (toolName gc) ("-c":"color.ui=always":commandArgs gc)
-procFromCmd (GCS gc)   = procText (toolName gc) ("-c":"color.status=always":commandArgs gc)
-procFromCmd (GCSL gc)  = procText (toolName gc) (commandArgs gc)
-procFromCmd (GCRC gc)  = procText (toolName gc) (commandArgs gc)
-procFromCmd (GCSC gc)  = procText (toolName gc) (commandArgs gc)
-procFromCmd (GCUC gc)  = procText (toolName gc) (commandArgs gc)
-procFromCmd (GCATR gc) = procText (toolName gc) (commandArgs gc)
-procFromCmd (GCGKL gc) = procText (toolName gc) (commandArgs gc)
+procFromCmd (GCCB gc)  = procCmd (toolName gc) (commandArgs gc)
+procFromCmd (GCBU gc)  = procCmd (toolName gc) (commandArgs gc)
+procFromCmd (GCL gc)   = procCmd (toolName gc) ("-c":"color.ui=always":commandArgs gc)
+procFromCmd (GCS gc)   = procCmd (toolName gc) ("-c":"color.status=always":commandArgs gc)
+procFromCmd (GCSL gc)  = procCmd (toolName gc) (commandArgs gc)
+procFromCmd (GCRC gc)  = procCmd (toolName gc) (commandArgs gc)
+procFromCmd (GCSC gc)  = procCmd (toolName gc) (commandArgs gc)
+procFromCmd (GCUC gc)  = procCmd (toolName gc) (commandArgs gc)
+procFromCmd (GCATR gc) = procCmd (toolName gc) (commandArgs gc)
+procFromCmd (GCGKL gc) = procCmd (toolName gc) (commandArgs gc)
+procFromCmd (GCPTT gc) = shellCmd (toolName gc) (commandArgs gc)
 
 
 class Monad m => MonadGitExec m where
diff --git a/src/Elegit/Git/Runner/Real.hs b/src/Elegit/Git/Runner/Real.hs
@@ -41,6 +41,10 @@ executeGitF arg = case arg of
     stashes <- lines . fromMaybe "" <$> execGit (GCSL gc)
     return $ next stashes
 
+  GA.PathToTool gc next -> do
+    path <- execGit (GCPTT gc)
+    return $ next path
+
   GA.GPGListKeys gc next -> do
     mGpgKeys <- execGit (GCGKL gc)
     return $ next (mGpgKeys >>= nonEmpty . lines)
@@ -55,22 +59,24 @@ executeGitF arg = case arg of
   GA.UnsetConfig gc next -> do
     U.void $ execGit (GCUC gc)
     return next
-  GA.Prompt prompt pDefaultM next -> do
+  GA.Prompt (GA.PromptConfig prompt pType) next -> do
     let
       askPrompt = do
         pText (colored Purple Normal message)
         gLine
 
       message :: Text
       message =
-        case pDefaultM of
-          Just pDefault -> fmt ""+|prompt|+" {"+|pDefault|+"}: "
-          Nothing       -> fmt ""+|prompt|+": "
+        case pType of
+          GA.PromptOneTime                 -> fmt ""+|prompt|+": "
+          GA.PromptDefault (Just pDefault) -> fmt ""+|prompt|+" {"+|pDefault|+"}: "
+          GA.PromptDefault Nothing         -> fmt ""+|prompt|+": "
 
     answer <-
-      case pDefaultM of
-        Nothing -> until (not . null) askPrompt
-        Just pDefault -> do
+      case pType of
+        GA.PromptOneTime                 -> askPrompt
+        GA.PromptDefault Nothing         -> until (not . null) askPrompt
+        GA.PromptDefault (Just pDefault) -> do
           answer <- askPrompt
           if null answer
              then return pDefault
diff --git a/src/Elegit/Git/Runner/Simulated.hs b/src/Elegit/Git/Runner/Simulated.hs
@@ -207,7 +207,7 @@ collectImpureCommandsF cmd = case cmd of
       localConfig %= HS.delete cName
     return next
 
-  GA.Prompt prompt pDefaultM next -> do
+  GA.Prompt (GA.PromptConfig prompt pType) next -> do
     let
       -- TODO: Make configurable
       hardcodedAnswer :: Text
@@ -219,19 +219,24 @@ collectImpureCommandsF cmd = case cmd of
 
       message :: Text
       message =
-        case pDefaultM of
-         Just pDefault -> fmt ""+|prompt|+" {"+|pDefault|+"}: "
-         Nothing       -> fmt ""+|prompt|+": "
-
-    answer <- case pDefaultM of
-       Nothing -> until (not . null) promptAnswer
-       Just pDefault -> do
+        case pType of
+          GA.PromptOneTime                 -> fmt ""+|prompt|+": "
+          GA.PromptDefault (Just pDefault) -> fmt ""+|prompt|+" {"+|pDefault|+"}: "
+          GA.PromptDefault Nothing         -> fmt ""+|prompt|+": "
+
+    answer <- case pType of
+        GA.PromptOneTime                 -> promptAnswer
+        GA.PromptDefault Nothing         -> until (not . null) promptAnswer
+        GA.PromptDefault (Just pDefault) -> do
          answer <- promptAnswer
          if null answer
            then return pDefault
            else return answer
     return $ next answer
 
+  GA.PathToTool (GA.GPathToToolData toolName) next -> do
+    return $ next $ Just ("/usr/bin/"+|toolName|+"")
+
   GA.FormatInfo content next -> do
     return $ next content
   GA.FormatCommand content next -> do
diff --git a/test/Elegit/Cli/Action/AcquireRepositorySpec.hs b/test/Elegit/Cli/Action/AcquireRepositorySpec.hs
