summaryrefslogtreecommitdiff
path: root/lib/GnuPGAgent.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2016-09-02 17:21:03 -0400
committerjoe <joe@jerkface.net>2016-09-02 17:34:46 -0400
commitad1aec70e7a38ba55c600e5d89fca3125d14b0c6 (patch)
treee48927ee9054f396cb198b34f341ed5e5486b028 /lib/GnuPGAgent.hs
parentbbd209a3b83b11d1c46b13bea35b534598827c12 (diff)
Kiki now launches gpg-agent if neccessary.
Diffstat (limited to 'lib/GnuPGAgent.hs')
-rw-r--r--lib/GnuPGAgent.hs66
1 files changed, 56 insertions, 10 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 @@
1{-# LANGUAGE LambdaCase #-} 1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE CPP #-} 2{-# LANGUAGE CPP #-}
3{-# LANGUAGE PatternGuards #-} 3{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-}
4module GnuPGAgent 4module GnuPGAgent
5 ( session 5 ( session
6 , GnuPGAgent 6 , GnuPGAgent
@@ -15,8 +15,10 @@ import Debug.Trace
15import Control.Monad 15import Control.Monad
16import ControlMaybe 16import ControlMaybe
17import Data.Char 17import Data.Char
18import Data.Maybe
18import Data.OpenPGP 19import Data.OpenPGP
19import Data.OpenPGP.Util 20import Data.OpenPGP.Util
21import Data.Word
20import Network.Socket 22import Network.Socket
21import System.Directory 23import System.Directory
22import System.Environment 24import System.Environment
@@ -37,26 +39,70 @@ import Data.Time.Calendar
37import Data.Time.Clock 39import Data.Time.Clock
38import Data.Time.Clock.POSIX 40import Data.Time.Clock.POSIX
39#endif 41#endif
40import Data.Word 42import ProcessUtils
43import Control.Monad.Fix
44import Control.Concurrent (threadDelay)
41 45
42data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } 46data GnuPGAgent = GnuPGAgent { agentHandle :: Handle }
43 47
48launchAgent :: FilePath -> Maybe [(String,String)] -> IO (Maybe GnuPGAgent)
49launchAgent gpghome env = do
50 e <- spawnDetached "/usr/bin/gpg-agent" -- TODO: make this configurable
51 ["--homedir",gpghome,"--use-standard-socket","--daemon"]
52 env -- HERE redundant (see HERE below)
53 case e of
54 SpawnOK -> do
55 let secs_to_wait_for_agent = 5
56 flip fix secs_to_wait_for_agent $ \loop count -> do
57 case count of
58 0 -> do hPutStrLn stderr "Agent timed out."
59 return Nothing
60 _ -> do
61 handleIO_ (threadDelay 1000000 >> loop (count - 1)) $ do
62 sock <- socket AF_UNIX Stream defaultProtocol
63 connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent"))
64 agent <- socketToHandle sock ReadWriteMode
65 hSetBuffering agent LineBuffering
66 maybe (return ()) (putenv $ GnuPGAgent agent) env -- HERE redundant (see HERE above)
67 return $ Just $ GnuPGAgent agent
68 _ -> do
69 hPutStrLn stderr "Failed to connect to gpg-agent."
70 return Nothing
71
72getDisplay :: IO [(String,String)]
73getDisplay = catMaybes <$> mapM getvar vars
74 where
75 vars = [ "GPG_TTY"
76 , "TERM"
77 , "DISPLAY"
78 , "XAUTHORITY"
79 , "XMODIFIERS"
80 , "GTK_IM_MODULE"
81 , "DBUS_SESSION_BUS_ADDRESS"
82 , "QT_IM_MODULE"
83 , "INSIDE_EMACS"
84 , "PINENTRY_USER_DATA"
85 ]
86 getvar var = fmap (var,) <$> lookupEnv var
87
88putenv :: GnuPGAgent -> [(String,String)] -> IO ()
89putenv (GnuPGAgent agent) env = do
90 forM_ env $ \(var,val) -> do
91 hPutStrLn agent ("option putenv "++var++"="++val)
92 _ <- hGetLine agent
93 return ()
94
44session :: IO (Maybe GnuPGAgent) 95session :: IO (Maybe GnuPGAgent)
45session = do 96session = do
46 envhomedir Nothing gpgHomeSpec >>= \case 97 envhomedir Nothing gpgHomeSpec >>= \case
47 Just gpghome -> do 98 Just gpghome -> do
48 -- TODO: Launch gpg-agent if neccessary. 99 env <- getDisplay
49 handleIO_ (hPutStrLn stderr "Failed to connect to gpg-agent." >> return Nothing) $ do 100 handleIO_ (launchAgent gpghome $ Just env) $ do
50 sock <- socket AF_UNIX Stream defaultProtocol 101 sock <- socket AF_UNIX Stream defaultProtocol
51 connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent")) 102 connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent"))
52 agent <- socketToHandle sock ReadWriteMode 103 agent <- socketToHandle sock ReadWriteMode
53 hSetBuffering agent LineBuffering 104 hSetBuffering agent LineBuffering
54 lookupEnv "DISPLAY" >>= \case 105 putenv (GnuPGAgent agent) env
55 Just display -> do hPutStrLn agent ("option putenv DISPLAY="++display)
56 _ <- hGetLine agent
57 return ()
58 Nothing -> return ()
59 -- TODO: GPG_TTY
60 return $ Just $ GnuPGAgent agent 106 return $ Just $ GnuPGAgent agent
61 Nothing -> do 107 Nothing -> do
62 hPutStrLn stderr "Unable to find home directory." 108 hPutStrLn stderr "Unable to find home directory."