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
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module GnuPGAgent
( session
, 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
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" -> 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
|
