Added module for talking to gpg-agent.

2 files changed, 175 insertions, 1 deletions

diff --git a/kiki.cabal b/kiki.cabal
index 85461c7..44abdb5 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -89,7 +89,8 @@ library
                      Numeric.Interval,
                      Numeric.Interval.Bounded,
                      SuperOrd,
-                     FunctorToMaybe
+                     FunctorToMaybe,
+                     GnuPGAgent
     other-modules:   TimeUtil,
                      ControlMaybe,
                      Compat
diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs
new file mode 100644
index 0000000..8bffd1b
--- /dev/null
+++ b/lib/GnuPGAgent.hs
@@ -0,0 +1,173 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
+module GnuPGAgent
+    ( session
+    , getPassphrase
+    , clearPassphrase
+    , quit ) where
+
+import Debug.Trace
+import Control.Monad
+import Data.Char
+import Data.String
+import Data.OpenPGP
+import Data.OpenPGP.Util
+import Network.Socket
+import System.Directory
+import System.Environment
+import System.IO
+import Text.Printf
+#if defined(VERSION_memory)
+import qualified Data.ByteString.Char8 as S8
+import Data.ByteArray.Encoding
+#elif defined(VERSION_dataenc)
+import qualified Codec.Binary.Base16 as Base16
+#endif
+import LengthPrefixedBE
+import qualified Data.ByteString.Lazy as L
+#if defined(VERSION_hourglass)
+import Data.Hourglass
+#else
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+#endif
+import Data.Word
+
+data GnuPGAgent = GnuPGAgent { agentHandle :: Handle }
+
+session = do
+    envhomedir Nothing gpgHomeSpec >>= \case
+        Just gpghome -> do
+            sock <- socket AF_UNIX Stream defaultProtocol
+            connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent"))
+            agent <- socketToHandle sock ReadWriteMode
+            hSetBuffering agent LineBuffering
+            return $ Just $ GnuPGAgent agent
+        Nothing -> do
+            hPutStrLn stderr "Unable to find home directory."
+            return Nothing
+
+percentPlusEscape :: String -> String
+percentPlusEscape s = do
+    c <- s
+    case c of
+        ' ' -> "+"
+        '+' -> "%2B"
+        '"' -> "%22"
+        '%' -> "%25"
+        _ | c < ' ' -> printf "%%%02X" (ord c)
+        _ -> return c
+
+clearPassphrase agent key = do
+    let cmd = "clear_passphrase "++fingerprint key
+    hPutStrLn (agentHandle agent) cmd
+
+getPassphrase :: GnuPGAgent -> Bool -> Packet -> String -> Maybe Packet -> IO (Maybe String)
+getPassphrase agent ask key uid masterkey = do
+    let askopt = if ask then "" else "--no-ask "
+        (er,pr,desc) = prompts key uid masterkey
+        cmd = "get_passphrase "++askopt++fingerprint key++" "++unwords (map percentPlusEscape [er,pr,desc])
+    putStrLn cmd
+    hPutStrLn (agentHandle agent) cmd
+    r0 <- hGetLine (agentHandle agent)
+    case takeWhile (/=' ') r0 of
+        "OK" -> hGetLine (agentHandle agent) >>= unhex . drop 3
+            where
+#if defined(VERSION_memory)
+                unhex hx = case convertFromBase Base16 (S8.pack hx) of
+                            Left e -> return Nothing
+                            Right bs -> return $ Just $ S8.unpack bs
+#elif defined(VERSION_dataenc)
+                unhex hx = return $ fmap (map $ chr . fromIntegral) $ Base16.decode hx
+#endif
+        "ERR" -> return Nothing
+
+quit (GnuPGAgent h) = hClose h
+
+prompts :: Packet -> String -> Maybe Packet -> (String,String,String)
+prompts key uid masterkey = ("X","X",atext)
+ where
+    atext = printf (concat [ "Please enter the passphrase to unlock the"
+                           , " secret key for the OpenPGP certificate:\n"
+                           , "\"%s\"\n"
+                           , "%d-bit %s key, ID %s,\n"
+                           , "created %s%s.\n"])
+                   uid
+                   (key_nbits key) algo_name (keystr key)
+                   timestr maink
+
+    maink
+        | Just k <- masterkey = printf " (main key ID %s)" (drop 32 $ fingerprint k)
+        | otherwise           = ""
+
+    algo_name =
+        case key_algorithm key of
+            a | a `elem` [RSA,RSA_E,RSA_S] -> "RSA"
+            ELGAMAL                        -> "ELG" -- also PUBKEY_ALGO_ELGAMAL_E
+            DSA                            -> "DSA"
+            ECDSA                          -> "ECDSA"
+            ECC                            -> "ECDH"
+            _                              -> "?" -- also "EDDSA";
+
+
+    keystr k = drop 32 $ fingerprint k -- FCD7BFB7
+
+    timestr = timeString $ timestamp key -- 2014-01-04
+
+data HomeDir = HomeDir { homevar :: String, appdir :: String }
+gpgHomeSpec :: HomeDir
+gpgHomeSpec = HomeDir
+    { homevar = "GNUPGHOME"
+    , appdir  = ".gnupg"
+    }
+
+envhomedir opt home = do
+        gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home)
+        homed <- fmap (mfilter (/="") . Just) getHomeDirectory
+        let homegnupg = (++('/':(appdir home))) <$> homed
+        let val = (opt `mplus` gnupghome `mplus` homegnupg)
+        return $ val
+
+
+timeString :: Word32 -> String
+timeString t = printf "%d-%d-%d" year month day
+ where
+#if defined(VERSION_hourglass)
+    Date year m day = timeFromElapsed (Elapsed (Seconds $ fromIntegral t))
+    month = fromEnum m + 1
+#else
+    (year,month,day) = toGregorian . utctDay $ posixSecondsToUTCTime (realToFrac t)
+#endif
+
+key_nbits :: Packet -> Int
+key_nbits p@(SecretKeyPacket {}) = _key_nbits (key_algorithm p) (key p)
+key_nbits p@(PublicKeyPacket {}) = _key_nbits (key_algorithm p) (key p)
+key_nbits _ = 0
+
+_key_nbits :: KeyAlgorithm -> [(Char,MPI)] -> Int
+_key_nbits RSA     toks | Just n <- lookup 'n' toks = mpi_nbits n
+_key_nbits DSA     toks | Just n <- lookup 'p' toks = mpi_nbits n
+_key_nbits ECDSA   toks | Just n <- lookup 'c' toks = curve_oid_nbits n
+_key_nbits ELGAMAL toks | Just n <- lookup 'p' toks = mpi_nbits n
+_key_nbits _ _ = 0
+-- unimplemented: RSA_E RSA_S ECC DH / KeyAlgorithm Word8
+
+curve_oid_nbits :: MPI -> Int
+curve_oid_nbits (MPI 0x2a8648ce3d030107 ) = 256 -- SEC p256r1 ( NIST P-256 )
+curve_oid_nbits (MPI 0x2B81040022 )       = 384 -- SEC p384r1 ( NIST P-384 )
+curve_oid_nbits (MPI 0x2B81040023 )       = 521 -- SEC p521r1 ( NIST P-521 )
+curve_oid_nbits (MPI 0x2b8104000a )       = 256 -- SEC p256k1 ( bitcoin curve )
+curve_oid_nbits n = trace ("Unknown curve: "++ show n) 0
+
+
+mpi_nbits (MPI n) = 8 * fromIntegral len
+ where
+    len = case encode_bigendian n of
+            b | L.head b == 0x0 -> L.length b - 1
+              | otherwise       -> L.length b
+
+
+testkey = SecretKeyPacket {version = 4, timestamp = 1472243938, key_algorithm = RSA, key = [('n',MPI 925098108806375345974135594703587915335809897839280536758475464131261107271275275932941944111979646806461228101207851537942631933552941000008763874178530420365203962506983368285394789190952706134189777248228503641959576566803847321978843353927484729746589488105067415601601958095348374608399772919464713280387221943804165023869848572344992805664813501588760551986737643636299927619834836785540438897016892383261773529795165480003163651143689566476205133258213375814625458146741502313336447508506512546267421431425245630464604235460425475063276208764001900603879017446724640013942643622160007288636580727874256816955228499258020260878806702335205106422310450767943433083341074984990460601274996333576709631004285781450883843918772938883789506765607663117687871326332910317916884385080960167806232865135145253097892026144191502423556603525411279749089026836608340578157620006555362884552555447347323681257897414720771902270571787966952008017289476385955943926940452534284336204814865498532173422146165623516746915729611768809058047983375615970447956865689598628436093143714990376442967204932522864539829901037938858768502028897029767875742018399924904388125541551233394021154526824492768592689377932549076041702724833113848612007956279),('e',MPI 65537)], s2k_useage = 255, s2k = IteratedSaltedS2K SHA1 4073382889203176146 7864320, symmetric_algorithm = CAST5, encrypted_data = fromString "\NUL\ESC\145\219\220k\SOH\147}\236K\165\207\&9g\245Nl\\)l\193\224{\251\180T\240\150\184\164:Fbx\t\SI\143\213\202?\137\158zd\247\188W\227l\NUL\154s\173\NUL\"k\162\243\rh\233\215\181\207\&7\223\DC3^t\187\158\248\177\ENQ\225\\\186\168\EM\177\211\162U\132\229Nx\227\&8\SYN\234\136\229\142;\252\&90L;\161\181\SO\152\198\&4\153\SUBs\235\195\153N\196\194 [\244+\217\242l\217.\183\186\205(\186\NUL\164\143>\215\168\207}\191\172($\168\139)O\ESCq\GS\138\213\243\229<\187\252\153)\NUL\128\136\237\RS\ETX\216\185\176I\239\185\228\v(\251\&4\233\&3$\236\195\NAKr\234\190J\216y\DC1\av\159\164\CAN\EOT\167\202})\128\182j\195\145]\144\r\232(\215\187\&1K\245\170\218\144\179\205\SOH\180-\185\DC1\168l\195\149\196\191\&9\156\196E\253\159h\154II\180\f\r\211\242\167~\214\223\219S\194\239\192\250\211Z\162\NAK\183M\209\230\&1yd\145\SOH\249\129\ESC\147\EM\237y\vK12O\205\ESC\r\224J\188\189\231\132\153JT\151f8\209\220#~S\165Q\249\SOH\182)\182\244\222\198i\180\221\170Q\238X\206\218\222\164gy\239\&7\136\183P\204\&5\NAK&\ESCC\GS\192\202\SO\241x\145MM\207\229\135\151\189,t\231r\194\196\233[\225\136\234\164r\176NXY\157\&2?\129% g\200\222\150\209\DLEQ\144\FS\181\&4#\US\DC28\179\190\240y3gr\170&\194\CAN)3r\235\252\153\EM\211\a\195\251\187\236\&1\197:\192\158\US\US\163v\153\223\141\254\209\206n\178h\140\&1-\fM\b\SOH\207\155\USb.,\NAKw\247\US\225\b)\236\EM\ENQn}\SUB-\193\f\138F\255P\216\242\164\145\136\213\171\252\254t\178\v\207\187\211\229\161\133\238\146\162\166SrT\168\135\244d6]\151\a\153\156\232\207|\152\223\174\EMj\130\240\211\141\203\167Kl\163\179R\152\225\221m\224!\238\176\217\162\158 fv\149wX\226\132\137H\138\235\207vwN\DC1\DEL'T\171\219\222\n\220V@\249U\227\SUBr\223NE\158=c\189\ACK3H\220\174\&3\139\135\254\246\165\EOTT\248\RS\132\160\219\EMb\188\200\165\138\178\163\STX\170\161\248\217\&1\186\&2r~\243\143\145b\154(\138\161\179\217\ACK\176\243\163IC\176\189Q_\206w\188=\254\143=\175\188\ENQaP\197\SI*\151\242m\178\184\208\SYN@\128\143\DC3-J\163\164{\206<\SUBxG\SI\NUL\153%\187\142\&6\f\186O\142\128'\128\150{\165\156e\201\175\159\185\b\NAK\246M\182\&4\SOH\161\231UV\220\148\245$\173\247-C\212\179\190Z$\184\RSZ\130~\t\249\138r?\201\231\200\190m\128%c\204\ENQH3S\140\228\&8\243\NAK\DC4O\218\162\146R\221\134\217%%\164@#\139\a\STX\218Y\132h\ETX(=\245\135\239|rN\\2\250\\\FS\155:p\247\213\252D']*\137\220\128\232\ar\134\DC4\131\194\SUB\169\130\&6\SI\131\151J!\220\135V\210m!\EM\241\134\158v\200~\190;z\237\218\DC3\NULT\164\151\135|\185\EOT\161c\196QA\228.\ENQ\227d\220\128\238\191&Pw\f'\153\180\DC3\201\SI=0\218\130~\167\t5\172EBA\238D\219\208\168\b\252Y\236\220,\144\&1\239\177\n\DC4\DLE\238\v\ETB\168\246\185\212\239\231\212\212sl\254.\197\216\130g\163\&5\211*\150\243g\220\247\140M\190\172\216\250\248\130\207\&5f\223;=}qU?\\\237\243\ENQ\241[\198\248u\139\a\139\175\247\224\252_N\146G\201\NUL\170{\191\237\140\SYNH2\ESCg\RS\233\175}\189\136\250\240\129\US\187\193\194\189\SUBK\SO\209\177F\200\SOH\173\196kw_)_\227\162\186\DC2\132\181\b@\ACKGo\222f\251br\CAN3~\139\DC2U\bQ\241\CAN:\213\135s\138\GSPIk*\236\&2a;o\247\239\202\145\212(2\223\DEL\bz\157\242@\STX\180g\193\202\230\186\135\189\177l\163\216o\230\&6\DC2\198\164\182\&5\ETX%\228\"!\245\ENQ\180\234\ACK\US\174\249\SO\US\168\STX,\ETB\n\249/\177\179\247Fw$\DLEB\ACK\224\231\EOT\ETB\247\213\182v\180\FS\247\205\222+P&\228\213\216\138ez\189N9x\v\228\217\207L}\ETX&\133\206\vRSM)\SOH\217\253\RS\204\252\249p\v\ACKL!u\SI\\\ETXD\128\&9\152\fy\241\202\204\164\151p\142\147c\207)\130\179'm\211\128I\207\ENQ\r\bcMWt\222\156\&1\199\DLE\157\&0z[H\146\SOHg\238\234\185\181\141\172c\245[\NUL\197\205\ENQ\fM\177\230\253\209~^\213W1'\GS\142\249\SIZ\204\254\240\DC3\231=b!\225@\247x\135\135\226\251[\RS&;\135}\196t\SUBi\CAN\DC14]e\206-l\205\SI\253\222\139y\139V\242\150k\248\191\231\195\211W\226t\170\DLE\174\243\186\211\189\152D\216\235\163\220+\194\247!o^F\198\145M", is_subkey = False}
+