path: root/lib/GnuPGAgent.hs

{-# 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.OpenPGP.Util hiding (fingerprint)
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 = 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