summaryrefslogtreecommitdiff
path: root/lib/GnuPGAgent.hs
blob: 06784dd0c1b7fc036b274076519a215ea455e076 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
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.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 :: IO (Maybe GnuPGAgent)
session = do
    envhomedir Nothing gpgHomeSpec >>= \case
        Just gpghome -> do
            -- TODO: Launch gpg-agent if neccessary.
            handleIO_ (hPutStrLn stderr "Failed to connect to gpg-agent." >> return Nothing) $ 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" | 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