AcquireRepository will configure gpg signature

Port gpg signature logic from bash implementation.

#297

Author: teggotic

src/Elegit/Cli/Action/AcquireRepository.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase  #-}
 {-# LANGUAGE QuasiQuotes #-}
 module Elegit.Cli.Action.AcquireRepository
     ( cli
@@ -149,9 +150,36 @@ configureAliases cScope = do
             ]
 
 
--- TODO: port bash logic
 setupGPGSignature :: (MonadFree GA.GitF m) => m ()
-setupGPGSignature = pass
+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"
 
 
 -- | Execution description of the AcquireRepository action

src/Elegit/Git/Action.hs

@@ -38,19 +38,24 @@ import           Universum                 hiding (print)
 
 -- TODO: maybe, cover with tests
 class RenderGitCommand c where
-  renderGC :: c -> Text
+  commandArgs :: c -> Text
+  toolName :: c -> Text
+  toolName _ = "git"
+
+renderGC :: RenderGitCommand c => c -> Text
+renderGC c = toolName c|+" "+|commandArgs c|+""
 
 data GCurrentBranchData
   = GCurrentBranchData
 
 instance RenderGitCommand GCurrentBranchData where
-  renderGC _ = "rev-parse --abbrev-ref @"
+  commandArgs _ = "rev-parse --abbrev-ref @"
 
 newtype GBranchUpstreamData
   = GBranchUpstreamData { branch :: Text }
 
 instance RenderGitCommand GBranchUpstreamData where
-  renderGC (GBranchUpstreamData branchName) = "rev-parse --abbrev-ref "+|branchName|+"@{upstream}"
+  commandArgs (GBranchUpstreamData branchName) = "rev-parse --abbrev-ref "+|branchName|+"@{upstream}"
 
 data GLogData
   = GLogData
@@ -59,7 +64,7 @@ data GLogData
       , target  :: Text
       }
 instance RenderGitCommand GLogData where
-  renderGC (GLogData lType baseName targetName) = "log "+|logArg|+" "+|baseName|+".."+|targetName|+""
+  commandArgs (GLogData lType baseName targetName) = "log "+|logArg|+" "+|baseName|+".."+|targetName|+""
     where
       logArg :: Text
       logArg = case lType of
@@ -69,7 +74,7 @@ newtype GStatusData
   = GStatusData { statusType :: StatusType }
 
 instance RenderGitCommand GStatusData where
-  renderGC (GStatusData sType) = "status "+|statusFormat|+""
+  commandArgs (GStatusData sType) = "status "+|statusFormat|+""
     where
       statusFormat :: Text
       statusFormat = case sType of
@@ -78,7 +83,7 @@ instance RenderGitCommand GStatusData where
 data GStashListData
   = GStashListData
 instance RenderGitCommand GStashListData where
-  renderGC _ = "stash list"
+  commandArgs _ = "stash list"
 
 data GReadConfigData
   = GReadConfigData
@@ -87,7 +92,7 @@ data GReadConfigData
       }
 
 instance RenderGitCommand GReadConfigData where
-  renderGC (GReadConfigData cScope cName) = "config "+|scopeText|+" --get "+|cName|+""
+  commandArgs (GReadConfigData cScope cName) = "config "+|scopeText|+" --get "+|cName|+""
     where
       scopeText :: Text
       scopeText = case cScope of
@@ -103,7 +108,7 @@ data GSetConfigData
       }
 
 instance RenderGitCommand GSetConfigData where
-  renderGC (GSetConfigData cScope cName cValue) = "config "+|scopeText|+" "+|cName|+" "+|cValue|+""
+  commandArgs (GSetConfigData cScope cName cValue) = "config "+|scopeText|+" "+|cName|+" \""+|cValue|+"\""
     where
       scopeText :: Text
       scopeText = case cScope of
@@ -118,7 +123,7 @@ data GUnsetConfigData
       }
 
 instance RenderGitCommand GUnsetConfigData where
-  renderGC (GUnsetConfigData cScope cName) = "config "+|scopeText|+" --unset "+|cName|+""
+  commandArgs (GUnsetConfigData cScope cName) = "config "+|scopeText|+" --unset "+|cName|+""
     where
       scopeText :: Text
       scopeText = case cScope of
@@ -130,14 +135,21 @@ newtype GAliasesToRemoveData
   = GAliasesToRemoveData { scope :: ConfigScope }
 
 instance RenderGitCommand GAliasesToRemoveData where
-  renderGC (GAliasesToRemoveData cScope) = "config "+|scopeText|+" --name-only --get-regexp \"^alias.\" \"^elegant ([-a-z]+)$\""
+  commandArgs (GAliasesToRemoveData cScope) = "config "+|scopeText|+" --name-only --get-regexp \"^alias.\" \"^elegant ([-a-z]+)$\""
     where
       scopeText :: Text
       scopeText = case cScope of
                 GlobalConfig -> "--global"
                 LocalConfig  -> "--local"
                 AutoConfig   -> ""
 
+newtype GGPGKeyListData
+  = GGPGKeyListData { email :: Text }
+
+instance RenderGitCommand GGPGKeyListData where
+  toolName _ = "gpg"
+  commandArgs (GGPGKeyListData gEmail) = "--list-secret-keys --keyid-format long "+|gEmail|+""
+
 -- | The declaration of all posible actions we can do in the git action.
 --
 -- This describes the data of the action, and whether it can return any value
@@ -155,6 +167,7 @@ data GitF a
   | AliasesToRemove GAliasesToRemoveData (Maybe (NonEmpty Text) -> a)
   | SetConfig GSetConfigData a
   | UnsetConfig GUnsetConfigData a
+  | GPGListKeys GGPGKeyListData (Maybe (NonEmpty Text) -> a)
   | Prompt Text (Maybe Text) (Text -> a)
   | FormatInfo Text (Text -> a)
   | FormatCommand Text (Text -> a)
@@ -231,6 +244,9 @@ setConfig cScope cName cValue = liftF $ SetConfig (GSetConfigData cScope cName c
 unsetConfig :: MonadFree GitF m => ConfigScope -> Text -> m ()
 unsetConfig cScope cName = liftF $ UnsetConfig (GUnsetConfigData cScope cName) ()
 
+gpgListKeys :: MonadFree GitF m => Text -> m (Maybe (NonEmpty Text))
+gpgListKeys gEmail = liftF $ GPGListKeys (GGPGKeyListData gEmail) id
+
 promptDefault :: MonadFree GitF m => Text -> Maybe Text -> m Text
 promptDefault pText pDefault = liftF $ Prompt pText pDefault id
 
@@ -246,7 +262,7 @@ print content = liftF $ PrintText content ()
 -- Derived actions
 
 formatGitCommand :: (RenderGitCommand gc, MonadFree GitF m) => gc -> m Text
-formatGitCommand gc = formatCommand ("git "+|renderGC gc|+"")
+formatGitCommand gc = formatCommand (renderGC gc)
 
 setConfigVerbose :: MonadFree GitF m => ConfigScope -> Text -> Text -> m ()
 setConfigVerbose cScope cName cValue = do
@@ -258,6 +274,12 @@ unsetConfigVerbose cScope cName = do
   unsetConfig cScope cName
   print =<< formatGitCommand (GUnsetConfigData cScope cName)
 
+gpgListKeysVerbose :: MonadFree GitF m => Text -> m (Maybe (NonEmpty Text))
+gpgListKeysVerbose gEmail = do
+  gpgKeys <- gpgListKeys gEmail
+  print =<< formatGitCommand (GGPGKeyListData gEmail)
+  return gpgKeys
+
 freshestDefaultBranch :: MonadFree GitF m => m Text
 freshestDefaultBranch = do
     -- TODO: Port bash logic

src/Elegit/Git/Exec.hs

@@ -5,8 +5,8 @@ import           Data.Text            (stripEnd)
 import           Elegit.Git.Action
 import           Fmt
 import           GHC.IO.Handle        (hFlush)
-import           System.Process.Typed (ExitCode (ExitFailure, ExitSuccess), proc, readProcess)
-import           Universum
+import           System.Process.Typed (ExitCode (ExitFailure, ExitSuccess), readProcess, shell)
+import           Universum            as U
 
 
 newtype GitExecT m a
@@ -24,6 +24,7 @@ data GitCommand
   | GCSC GSetConfigData
   | GCUC GUnsetConfigData
   | GCATR GAliasesToRemoveData
+  | GCGKL GGPGKeyListData
 
 
 -- TODO: cover with tests
@@ -37,6 +38,7 @@ renderGitCommand (GCRC gc)  = renderGC gc
 renderGitCommand (GCSC gc)  = renderGC gc
 renderGitCommand (GCUC gc)  = renderGC gc
 renderGitCommand (GCATR gc) = renderGC gc
+renderGitCommand (GCGKL gc) = renderGC gc
 
 
 class Monad m => MonadGitExec m where
@@ -47,7 +49,8 @@ class Monad m => MonadGitExec m where
 
 instance MonadIO m => MonadGitExec (GitExecT m) where
   execGit gc = do
-    (eCode, outputBS, _errBS) <- readProcess $ proc "git" (toString <$> words (renderGitCommand gc))
+    let shellString = toString (renderGitCommand gc)
+    (eCode, outputBS, _errBS) <- readProcess $ shell ("git "+|shellString|+"")
     case eCode of
       -- TODO: Handle error codes per `gc`
       ExitFailure _ -> do

src/Elegit/Git/Runner/Real.hs

@@ -41,6 +41,9 @@ executeGitF arg = case arg of
     stashes <- lines . fromMaybe "" <$> execGit (GCSL gc)
     return $ next stashes
 
+  GA.GPGListKeys gc next -> do
+    mGpgKeys <- execGit (GCGKL gc)
+    return $ next (mGpgKeys >>= nonEmpty . lines)
   GA.AliasesToRemove gc next -> do
     oldAliasesM <- execGit (GCATR gc)
     return $ next (oldAliasesM >>= nonEmpty . lines)

src/Elegit/Git/Runner/Simulated.hs

@@ -156,6 +156,10 @@ collectImpureCommandsF cmd = case cmd of
       [ fmt "stash@{"+||i||+"}: "+|(stash^.gsName)|+" on "+|(stash^.gsBranchName)|+"" | (i, stash) <- zip [(0 :: Int)..] stashes
       ] -- this is excessive, I guess? @teggotic
 
+  GA.GPGListKeys (GA.GGPGKeyListData _email) next -> do
+    -- Ideally we want to see this
+    return $ next (Just ("3AA5C34371567BD2":|[]))
+
   GA.AliasesToRemove (GA.GAliasesToRemoveData cScope) next -> do
     case cScope of
      GA.LocalConfig -> do