diff options
author | joe <joe@jerkface.net> | 2016-09-02 17:21:03 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2016-09-02 17:34:46 -0400 |
commit | ad1aec70e7a38ba55c600e5d89fca3125d14b0c6 (patch) | |
tree | e48927ee9054f396cb198b34f341ed5e5486b028 /lib/GnuPGAgent.hs | |
parent | bbd209a3b83b11d1c46b13bea35b534598827c12 (diff) |
Kiki now launches gpg-agent if neccessary.
Diffstat (limited to 'lib/GnuPGAgent.hs')
-rw-r--r-- | lib/GnuPGAgent.hs | 66 |
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 #-} |
4 | module GnuPGAgent | 4 | module GnuPGAgent |
5 | ( session | 5 | ( session |
6 | , GnuPGAgent | 6 | , GnuPGAgent |
@@ -15,8 +15,10 @@ import Debug.Trace | |||
15 | import Control.Monad | 15 | import Control.Monad |
16 | import ControlMaybe | 16 | import ControlMaybe |
17 | import Data.Char | 17 | import Data.Char |
18 | import Data.Maybe | ||
18 | import Data.OpenPGP | 19 | import Data.OpenPGP |
19 | import Data.OpenPGP.Util | 20 | import Data.OpenPGP.Util |
21 | import Data.Word | ||
20 | import Network.Socket | 22 | import Network.Socket |
21 | import System.Directory | 23 | import System.Directory |
22 | import System.Environment | 24 | import System.Environment |
@@ -37,26 +39,70 @@ import Data.Time.Calendar | |||
37 | import Data.Time.Clock | 39 | import Data.Time.Clock |
38 | import Data.Time.Clock.POSIX | 40 | import Data.Time.Clock.POSIX |
39 | #endif | 41 | #endif |
40 | import Data.Word | 42 | import ProcessUtils |
43 | import Control.Monad.Fix | ||
44 | import Control.Concurrent (threadDelay) | ||
41 | 45 | ||
42 | data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } | 46 | data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } |
43 | 47 | ||
48 | launchAgent :: FilePath -> Maybe [(String,String)] -> IO (Maybe GnuPGAgent) | ||
49 | launchAgent 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 | |||
72 | getDisplay :: IO [(String,String)] | ||
73 | getDisplay = 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 | |||
88 | putenv :: GnuPGAgent -> [(String,String)] -> IO () | ||
89 | putenv (GnuPGAgent agent) env = do | ||
90 | forM_ env $ \(var,val) -> do | ||
91 | hPutStrLn agent ("option putenv "++var++"="++val) | ||
92 | _ <- hGetLine agent | ||
93 | return () | ||
94 | |||
44 | session :: IO (Maybe GnuPGAgent) | 95 | session :: IO (Maybe GnuPGAgent) |
45 | session = do | 96 | session = 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." |