diff options
-rw-r--r-- | kiki.cabal | 1 | ||||
-rw-r--r-- | kiki.hs | 13 | ||||
-rw-r--r-- | lib/GnuPGAgent.hs | 17 |
3 files changed, 27 insertions, 4 deletions
@@ -44,6 +44,7 @@ Executable kiki | |||
44 | unix, | 44 | unix, |
45 | openpgp-util, | 45 | openpgp-util, |
46 | network, | 46 | network, |
47 | pretty-show, | ||
47 | kiki | 48 | kiki |
48 | other-modules: DNSKey | 49 | other-modules: DNSKey |
49 | if !flag(cryptonite) | 50 | if !flag(cryptonite) |
@@ -23,6 +23,7 @@ import Data.Maybe | |||
23 | import Data.OpenPGP | 23 | import Data.OpenPGP |
24 | import Data.Ord | 24 | import Data.Ord |
25 | import Data.String | 25 | import Data.String |
26 | import Text.Show.Pretty as PP ( ppShow ) | ||
26 | import Data.Text.Encoding | 27 | import Data.Text.Encoding |
27 | import System.Posix.Files | 28 | import System.Posix.Files |
28 | import Foreign.C.Types (CTime(..)) | 29 | import Foreign.C.Types (CTime(..)) |
@@ -1309,6 +1310,8 @@ kiki "merge" [] = do | |||
1309 | , " HOMEDIR/{secring.gpg,pubring.gpg}" | 1310 | , " HOMEDIR/{secring.gpg,pubring.gpg}" |
1310 | , " HOMEDIR defaults to your GnuPG home directory." | 1311 | , " HOMEDIR defaults to your GnuPG home directory." |
1311 | , "" | 1312 | , "" |
1313 | , " --agent Use gpg-agent." | ||
1314 | , "" | ||
1312 | , " FILE A path to a key file to read or update." | 1315 | , " FILE A path to a key file to read or update." |
1313 | , "" | 1316 | , "" |
1314 | , "MODIFIERS" | 1317 | , "MODIFIERS" |
@@ -1335,15 +1338,19 @@ kiki "merge" args | "--help" `elem` args = do | |||
1335 | kiki "merge" [] | 1338 | kiki "merge" [] |
1336 | -- TODO: more help | 1339 | -- TODO: more help |
1337 | kiki "merge" args = do | 1340 | kiki "merge" args = do |
1338 | hPutStrLn stderr $ show op | 1341 | hPutStrLn stderr $ ppShow op |
1339 | KikiResult rt report <- runKeyRing op | 1342 | KikiResult rt report <- runKeyRing (mbAgent op) |
1340 | case rt of | 1343 | case rt of |
1341 | KikiSuccess rt -> return () | 1344 | KikiSuccess rt -> return () |
1342 | err -> putStrLn $ errorString err | 1345 | err -> putStrLn $ errorString err |
1343 | forM_ report $ \(fname,act) -> do | 1346 | forM_ report $ \(fname,act) -> do |
1344 | putStrLn $ fname ++ ": " ++ reportString act | 1347 | putStrLn $ fname ++ ": " ++ reportString act |
1345 | where | 1348 | where |
1346 | (_,(_,op)) = foldl' buildOp (True,(flow0,noop)) args | 1349 | (_,(_,op)) = foldl' buildOp (True,(flow0,noop)) args' |
1350 | (args',mbAgent) = case break (=="--agent") args of | ||
1351 | (as,[]) -> (args, id) | ||
1352 | (as,_:bs) -> ( as++bs | ||
1353 | , \op -> op { opPassphrases = withAgent (opPassphrases op) }) | ||
1347 | noop = KeyRingOperation | 1354 | noop = KeyRingOperation |
1348 | { opFiles = Map.empty | 1355 | { opFiles = Map.empty |
1349 | , opTransforms = [] | 1356 | , opTransforms = [] |
diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs index 2a68b4e..1e40269 100644 --- a/lib/GnuPGAgent.hs +++ b/lib/GnuPGAgent.hs | |||
@@ -14,6 +14,7 @@ module GnuPGAgent | |||
14 | import Debug.Trace | 14 | import Debug.Trace |
15 | import Control.Monad | 15 | import Control.Monad |
16 | import ControlMaybe | 16 | import ControlMaybe |
17 | import Data.Bool | ||
17 | import Data.Char | 18 | import Data.Char |
18 | import Data.Maybe | 19 | import Data.Maybe |
19 | import Data.OpenPGP | 20 | import Data.OpenPGP |
@@ -21,6 +22,7 @@ import Data.OpenPGP.Util | |||
21 | import Data.Word | 22 | import Data.Word |
22 | import Network.Socket | 23 | import Network.Socket |
23 | import System.Directory | 24 | import System.Directory |
25 | import System.Posix.User | ||
24 | import System.Environment | 26 | import System.Environment |
25 | import System.IO | 27 | import System.IO |
26 | import Text.Printf | 28 | import Text.Printf |
@@ -92,6 +94,18 @@ putenv (GnuPGAgent agent) env = do | |||
92 | _ <- hGetLine agent | 94 | _ <- hGetLine agent |
93 | return () | 95 | return () |
94 | 96 | ||
97 | findAgentSocket :: FilePath -> IO FilePath | ||
98 | findAgentSocket gpghome = foldr ($) (return "./S.gpg-agent") | ||
99 | [ \nope -> do | ||
100 | uid <- show <$> getRealUserID | ||
101 | let f = "/run/user/"++uid++"/gnupg/S.gpg-agent" | ||
102 | b <- doesFileExist f | ||
103 | if b then return f else nope | ||
104 | , \nope -> do | ||
105 | let f = gpghome ++ "/gnupg/S.gpg-agent" | ||
106 | doesFileExist f >>= bool nope (return f) | ||
107 | ] | ||
108 | |||
95 | session :: IO (Maybe GnuPGAgent) | 109 | session :: IO (Maybe GnuPGAgent) |
96 | session = do | 110 | session = do |
97 | envhomedir Nothing gpgHomeSpec >>= \case | 111 | envhomedir Nothing gpgHomeSpec >>= \case |
@@ -99,7 +113,8 @@ session = do | |||
99 | env <- getDisplay | 113 | env <- getDisplay |
100 | handleIO_ (launchAgent gpghome $ Just env) $ do | 114 | handleIO_ (launchAgent gpghome $ Just env) $ do |
101 | sock <- socket AF_UNIX Stream defaultProtocol | 115 | sock <- socket AF_UNIX Stream defaultProtocol |
102 | connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent")) | 116 | agentpath <- findAgentSocket gpghome |
117 | connect sock (SockAddrUnix agentpath) | ||
103 | agent <- socketToHandle sock ReadWriteMode | 118 | agent <- socketToHandle sock ReadWriteMode |
104 | hSetBuffering agent LineBuffering | 119 | hSetBuffering agent LineBuffering |
105 | putenv (GnuPGAgent agent) env | 120 | putenv (GnuPGAgent agent) env |