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
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
|
{-# 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
|
