{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} module GnuPGAgent ( session , GnuPGAgent , Query(..) , QueryMode(..) , getPassphrase , clearPassphrase , quit , key_nbits) where import Debug.Trace import Control.Monad import ControlMaybe import Data.Bool import Data.Char import Data.Maybe import Data.OpenPGP import qualified Data.OpenPGP.Util import Data.Word import Network.Socket import System.Directory import System.Posix.User import System.Environment import System.IO import Text.Printf import qualified Data.ByteString.Char8 as S8 import Data.ByteArray.Encoding import LengthPrefixedBE import qualified Data.ByteString.Lazy as L import Data.Hourglass import ProcessUtils import Control.Monad.Fix import Control.Concurrent (threadDelay) fingerprint :: Packet -> String fingerprint = take 40 . show . Data.OpenPGP.Util.fingerprint data GnuPGAgent = GnuPGAgent { agentHandle :: Handle } launchAgent :: FilePath -> Maybe [(String,String)] -> IO (Maybe GnuPGAgent) launchAgent gpghome env = do e <- spawnDetached "/usr/bin/gpg-agent" -- TODO: make this configurable ["--homedir",gpghome,"--use-standard-socket","--daemon"] env -- HERE redundant (see HERE below) case e of SpawnOK -> do let secs_to_wait_for_agent = 5 flip fix secs_to_wait_for_agent $ \loop count -> do case count of 0 -> do hPutStrLn stderr "Agent timed out." return Nothing _ -> do handleIO_ (threadDelay 1000000 >> loop (count - 1)) $ do sock <- socket AF_UNIX Stream defaultProtocol connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent")) agent <- socketToHandle sock ReadWriteMode hSetBuffering agent LineBuffering maybe (return ()) (putenv $ GnuPGAgent agent) env -- HERE redundant (see HERE above) return $ Just $ GnuPGAgent agent _ -> do hPutStrLn stderr "Failed to connect to gpg-agent." return Nothing getDisplay :: IO [(String,String)] getDisplay = catMaybes <$> mapM getvar vars where vars = [ "GPG_TTY" , "TERM" , "DISPLAY" , "XAUTHORITY" , "XMODIFIERS" , "GTK_IM_MODULE" , "DBUS_SESSION_BUS_ADDRESS" , "QT_IM_MODULE" , "INSIDE_EMACS" , "PINENTRY_USER_DATA" ] getvar var = fmap (var,) <$> lookupEnv var putenv :: GnuPGAgent -> [(String,String)] -> IO () putenv (GnuPGAgent agent) env = do forM_ env $ \(var,val) -> do hPutStrLn agent ("option putenv "++var++"="++val) _ <- hGetLine agent return () findAgentSocket :: FilePath -> IO FilePath findAgentSocket gpghome = foldr ($) (return "./S.gpg-agent") [ \nope -> do uid <- show <$> getRealUserID let f = "/run/user/"++uid++"/gnupg/S.gpg-agent" b <- doesFileExist f if b then return f else nope , \nope -> do let f = gpghome ++ "/gnupg/S.gpg-agent" doesFileExist f >>= bool nope (return f) ] session :: IO (Maybe GnuPGAgent) session = do envhomedir Nothing gpgHomeSpec >>= \case Just gpghome -> do env <- getDisplay handleIO_ (launchAgent gpghome $ Just env) $ do sock <- socket AF_UNIX Stream defaultProtocol agentpath <- findAgentSocket gpghome connect sock (SockAddrUnix agentpath) agent <- socketToHandle sock ReadWriteMode hSetBuffering agent LineBuffering putenv (GnuPGAgent agent) env 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 :: GnuPGAgent -> Packet -> IO () 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" | not (null $ drop 3 r0) -> return r0 >>= unhex . drop 3 -- . (\x -> trace (show x) x) | otherwise -> hGetLine (agentHandle agent) >>= unhex . drop 3 -- . (\x -> trace (show x) x) where 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 _ {- "ERR" -} -> return Nothing quit :: GnuPGAgent -> IO () 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 :: Maybe [Char] -> HomeDir -> IO (Maybe [Char]) 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 Date year m day = timeFromElapsed (Elapsed (Seconds $ fromIntegral t)) month = fromEnum m + 1 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 :: Num a => MPI -> a 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