1 files changed, 198 insertions, 0 deletions

diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs
new file mode 100644
index 0000000..7161b92
--- /dev/null
+++ b/lib/GnuPGAgent.hs
@@ -0,0 +1,198 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
+module GnuPGAgent
+    ( session
+    , Query(..)
+    , QueryMode(..)
+    , getPassphrase
+    , clearPassphrase
+    , quit
+    , key_nbits) where
+
+import Debug.Trace
+import Control.Monad
+import Data.Char
+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
+            lookupEnv "DISPLAY" >>= \case
+                Just display -> do hPutStrLn agent ("option putenv DISPLAY="++display)
+                                   _ <- hGetLine agent
+                                   return ()
+                Nothing      -> return ()
+            -- TODO: GPG_TTY
+            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 --mode=normal "++fingerprint key
+    hPutStrLn (agentHandle agent) cmd
+
+data Query = Query
+    { queryPacket  :: Packet
+    , queryUID     :: String
+    , queryMainKey :: Maybe Packet
+    }
+ deriving Show
+
+data QueryMode = AskNot | AskAgain String | AskExisting | AskNew
+ deriving (Show,Eq,Ord)
+
+getPassphrase :: GnuPGAgent -> QueryMode -> Query -> IO (Maybe String)
+getPassphrase agent ask (Query key uid masterkey) = do
+    let (er0,pr,desc) = prompts key uid masterkey
+        (er,askopt) = case ask of
+                        AskNot         -> (er0,"--no-ask ")
+                        AskAgain ermsg -> (ermsg,"")
+                        AskExisting    -> (er0,"")
+                        AskNew         -> (er0,"--repeat=1 ")
+        cmd = "get_passphrase "++askopt++fingerprint key++" "++unwords (map percentPlusEscape [er,pr,desc])
+    hPutStrLn stderr $ "gpg-agent <- " ++ cmd
+    hPutStrLn (agentHandle agent) cmd
+    r0 <- hGetLine (agentHandle agent)
+    -- hPutStrLn stderr $ "agent says: " ++ r0
+    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 -> do
+                                -- Useful for debugging but insecure generally ;)
+                                -- putStrLn $ "convertFromBase error for input "++show hx++": "++show e
+                                return Nothing
+                            Right bs -> return $ Just $ S8.unpack bs
+#elif defined(VERSION_dataenc)
+                unhex hx = maybe (return () {- putStrLn $ "dataenc error for input "++show 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
+