Kiki now launches gpg-agent if neccessary.

3 files changed, 97 insertions, 12 deletions

diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs
index 06784dd..18f1c25 100644
--- a/lib/GnuPGAgent.hs
+++ b/lib/GnuPGAgent.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-}
 module GnuPGAgent
     ( session
     , GnuPGAgent
@@ -15,8 +15,10 @@ import Debug.Trace
 import Control.Monad
 import ControlMaybe
 import Data.Char
+import Data.Maybe
 import Data.OpenPGP
 import Data.OpenPGP.Util
+import Data.Word
 import Network.Socket
 import System.Directory
 import System.Environment
@@ -37,26 +39,70 @@ import Data.Time.Calendar
 import Data.Time.Clock
 import Data.Time.Clock.POSIX
 #endif
-import Data.Word
+import ProcessUtils
+import Control.Monad.Fix
+import Control.Concurrent (threadDelay)
 
 data GnuPGAgent = GnuPGAgent { agentHandle :: Handle }
 
+launchAgent :: FilePath -> Maybe [(String,String)] -> IO (Maybe GnuPGAgent)
+launchAgent gpghome env = do
+    e <- spawnDetached "/usr/bin/gpg-agent" -- TODO: make this configurable
+            ["--homedir",gpghome,"--use-standard-socket","--daemon"]
+            env -- HERE redundant (see HERE below)
+    case e of
+        SpawnOK -> do
+            let secs_to_wait_for_agent = 5
+            flip fix secs_to_wait_for_agent $ \loop count -> do
+            case count of
+                0 -> do hPutStrLn stderr "Agent timed out."
+                        return Nothing
+                _ -> do
+                    handleIO_ (threadDelay 1000000 >> loop (count - 1)) $ do
+                    sock <- socket AF_UNIX Stream defaultProtocol
+                    connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent"))
+                    agent <- socketToHandle sock ReadWriteMode
+                    hSetBuffering agent LineBuffering
+                    maybe (return ()) (putenv $ GnuPGAgent agent) env -- HERE redundant (see HERE above)
+                    return $ Just $ GnuPGAgent agent
+        _ -> do
+            hPutStrLn stderr "Failed to connect to gpg-agent."
+            return Nothing
+
+getDisplay :: IO [(String,String)]
+getDisplay = catMaybes <$> mapM getvar vars
+ where
+    vars = [ "GPG_TTY"
+           , "TERM"
+           , "DISPLAY"
+           , "XAUTHORITY"
+           , "XMODIFIERS"
+           , "GTK_IM_MODULE"
+           , "DBUS_SESSION_BUS_ADDRESS"
+           , "QT_IM_MODULE"
+           , "INSIDE_EMACS"
+           , "PINENTRY_USER_DATA"
+           ]
+    getvar var = fmap (var,) <$> lookupEnv var
+
+putenv :: GnuPGAgent -> [(String,String)] -> IO ()
+putenv (GnuPGAgent agent) env = do
+    forM_ env $ \(var,val) -> do
+        hPutStrLn agent ("option putenv "++var++"="++val)
+        _ <- hGetLine agent
+        return ()
+
 session :: IO (Maybe GnuPGAgent)
 session = do
     envhomedir Nothing gpgHomeSpec >>= \case
         Just gpghome -> do
-            -- TODO: Launch gpg-agent if neccessary.
-            handleIO_ (hPutStrLn stderr "Failed to connect to gpg-agent." >> return Nothing) $ do
+            env <- getDisplay
+            handleIO_ (launchAgent gpghome $ Just env) $ do
             sock <- socket AF_UNIX Stream defaultProtocol
             connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent"))
             agent <- socketToHandle sock ReadWriteMode
             hSetBuffering agent LineBuffering
-            lookupEnv "DISPLAY" >>= \case
-                Just display -> do hPutStrLn agent ("option putenv DISPLAY="++display)
-                                   _ <- hGetLine agent
-                                   return ()
-                Nothing      -> return ()
-            -- TODO: GPG_TTY
+            putenv (GnuPGAgent agent) env
             return $ Just $ GnuPGAgent agent
         Nothing -> do
             hPutStrLn stderr "Unable to find home directory."
diff --git a/lib/ProcessUtils.hs b/lib/ProcessUtils.hs
index 1a9cc04..31f5cc9 100644
--- a/lib/ProcessUtils.hs
+++ b/lib/ProcessUtils.hs
@@ -6,6 +6,8 @@ module ProcessUtils
     , readPipe
     , readProcessWithErrorH
     , runExternal
+    , SpawnError(..)
+    , spawnDetached
     ) where
 
 import GHC.IO.Exception ( ioException, IOErrorType(..) )
@@ -13,16 +15,20 @@ import System.FilePath
 import System.Directory
 import System.Process
 import System.Posix.Signals
+import System.Posix.Process
 import System.Process.Internals (runGenProcess_,defaultSignal)
 import System.Environment
-import Data.Maybe ( isNothing, fromMaybe )
+import Data.Maybe ( isNothing, fromMaybe, isJust, fromJust )
 import System.IO.Error ( mkIOError, ioeSetErrorString ) 
 import System.Exit ( ExitCode(..) )
 import System.IO
 import Control.Applicative
 import Control.Exception (bracket)
 import qualified Data.ByteString as S
-
+import ControlMaybe (handleIO,handleIO_)
+import System.Posix.Files (fileAccess)
+import System.Posix.User (getRealUserID,getEffectiveUserID)
+import DotLock (dotlock_disable)
 
 -- | systemEnv
 -- This is like System.Process.system except that it lets you set
@@ -152,3 +158,34 @@ runExternal cmd input = do
                     ExitFailure x -> x
     return (code,(out,err))
 
+
+data SpawnError = SpawnOK | SpawnUIDCheck | SpawnBadAccess IOError | SpawnWaitPID | SpawnFork
+ deriving (Eq,Show)
+
+spawnDetached :: FilePath -> [String] -> Maybe [(String,String)] -> IO SpawnError
+spawnDetached filepath args env = do
+    uidcheck <- (==) <$> getRealUserID <*> getEffectiveUserID
+    if not uidcheck then return SpawnUIDCheck else do
+    accesscheck <- do
+        handleIO (return . Just . SpawnBadAccess) $ do
+            b <- fileAccess filepath False False True
+            if not b then return $ Just $ SpawnBadAccess (userError $ "No execute permission on "++filepath)
+                     else return Nothing
+    if isJust accesscheck then return (fromJust accesscheck) else do
+    handleIO_ (return SpawnFork) $ do
+        pid <- forkProcess $ do
+            dotlock_disable -- Disable dotlock atexit handler.
+                            -- This wouldn't be neccessary if we used exec*
+                            -- instead of fork.
+            -- clean up secure memory:
+            -- gcry_control (GCRYCTL_TERM_SECMEM);
+            -- if (setsid() == -1 || chdir ("/")) _exit (1);
+
+            -- Double fork to let init take over the new child.
+            handleIO_ (exitImmediately $ ExitFailure 1) $ do
+                pid2 <- forkProcess $ executeFile filepath False args env
+                exitImmediately ExitSuccess
+            exitImmediately ExitSuccess
+        handleIO_ (return SpawnWaitPID) $ do
+            _ <- getProcessStatus True False pid
+            return SpawnOK
diff --git a/lib/dotlock.c b/lib/dotlock.c
index c111159..e091686 100644
--- a/lib/dotlock.c
+++ b/lib/dotlock.c
@@ -1286,6 +1286,8 @@ dotlock_remove_lockfiles (void)
 {
   dotlock_t h, h2;
 
+  if( never_lock ) return;
+
   /* First set the lockfiles list to NULL so that for example
      dotlock_release is ware that this fucntion is currently
      running.  */