{-# LANGUAGE LambdaCase #-} {-# LANGUAGE CPP #-} {-# 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.Char import Data.Maybe import Data.OpenPGP import Data.OpenPGP.Util import Data.Word 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 ProcessUtils import Control.Monad.Fix import Control.Concurrent (threadDelay) 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 () 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 connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent")) 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 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 #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