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
|
{- Copyright 2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Gpg where
import Val
import Hash
import Types
import Crypto
import Data.ByteArray (convert)
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as B8
import System.IO
import System.Posix.IO hiding (createPipe)
import System.Process
import System.Exit
import Control.Exception
import System.Directory
import Control.Concurrent.Async
newtype GpgKeyId = GpgKeyId String
deriving (Show)
newtype GpgSign = GpgSign Bool
myPublicKey :: MySessionKey -> GpgSign -> IO (PerhapsSigned PublicKey)
myPublicKey (MySessionKey _ epk) (GpgSign gpgsign) = do
let pk = PublicKey (Val $ convert epk)
if gpgsign
then gpgSign pk
else return (UnSigned pk)
-- | Sign a debug-me session PublicKey with gpg.
gpgSign :: PublicKey -> IO (PerhapsSigned PublicKey)
gpgSign pk = do
putStrLn "Using gpg to sign the debug-me session key."
-- Write it to a temp file because gpg sometimes is unhappy
-- about password prompting when stdin is not connected to
-- the console.
tmpdir <- getTemporaryDirectory
(tmpfile, tmph) <- openTempFile tmpdir "debug-me.tmp"
B.hPut tmph $ val $ hashValue $ hash pk
hClose tmph
(_, Just hout, _, pid) <- createProcess $
(proc "gpg" ["--output", "-", "--clearsign", "-a", tmpfile])
{ std_out = CreatePipe
}
hSetBinaryMode hout True
sig <- GpgSig . Val <$> B.hGetContents hout
st <- waitForProcess pid
_ <- try (removeFile tmpfile) :: IO (Either IOException ())
case st of
ExitSuccess -> do
-- Verify the just signed data to determine
-- the gpg public key used to sign it. The gpg
-- public key is included in the GpgSigned data.
v <- fst <$> gpgVerifyClearSigned sig
case v of
Just (gpgkeyid, _) -> do
pubkey <- gpgExportPublicKey gpgkeyid
return $ GpgSigned pk sig pubkey
Nothing -> error "gpg sign verification failed"
ExitFailure _ -> error "gpg sign failed"
-- | Export gpg public key in minimal form.
gpgExportPublicKey :: GpgKeyId -> IO GpgKeyExport
gpgExportPublicKey (GpgKeyId gpgkeyid) = do
(_, Just hout, _, pid) <- createProcess $
(proc "gpg" opts)
{ std_out = CreatePipe
}
hSetBinaryMode hout True
b <- B.hGetContents hout
st <- waitForProcess pid
if st == ExitSuccess
then return $ GpgKeyExport $ Val b
else error "gpg --export failed"
where
opts =
[ "-a"
, "--export-options", "no-export-attributes,export-minimal"
, "--export", gpgkeyid
]
gpgImportPublicKey :: GpgKeyExport -> IO ()
gpgImportPublicKey (GpgKeyExport (Val b)) = do
(Just hin, Just hout, Just herr, pid) <- createProcess $
(proc "gpg" [ "--import"] )
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
hSetBinaryMode hin True
B.hPut hin b
hClose hin
_ <- B.hGetContents hout
`concurrently` B.hGetContents herr
_ <- waitForProcess pid
return ()
-- | Verify the gpg signature and return the keyid that signed it.
-- Also makes sure that the gpg signed data is the hash of the
-- debug-me PublicKey.
gpgVerify :: PerhapsSigned PublicKey -> IO (Maybe GpgKeyId, SignInfoDesc)
gpgVerify (UnSigned _) = return (Nothing, mempty)
gpgVerify (GpgSigned pk gpgsig keyexport) = do
gpgImportPublicKey keyexport
go =<< gpgVerifyClearSigned gpgsig
where
go (Nothing, s) = return (Nothing, s)
go (Just (gpgkeyid, signeddata), s) = do
let norm = filter (not . B.null) . B8.lines
let pkissigned = norm signeddata == norm (val (hashValue (hash pk)))
return $ if pkissigned
then (Just gpgkeyid, s)
else (Nothing, s)
type SignInfoDesc = B.ByteString
-- | Verify a clearsigned GpgSig, returning the key id used to sign it,
-- and the data that was signed.
--
-- Gpg outputs to stderr information about who signed the
-- data, and that is returned also.
gpgVerifyClearSigned :: GpgSig -> IO (Maybe (GpgKeyId, B.ByteString), SignInfoDesc)
gpgVerifyClearSigned (GpgSig (Val sig)) = do
(statusreadh, statuswriteh) <- createPipe
statuswritefd <- handleToFd statuswriteh
(Just hin, Just hout, Just herr, pid) <- createProcess $
(proc "gpg" (verifyopts statuswritefd))
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
closeFd statuswritefd
B.hPut hin sig
hClose hin
hSetBinaryMode hout True
((signeddata, sigdesc), mgpgkeyid) <- B.hGetContents hout
`concurrently` B.hGetContents herr
`concurrently` (parseStatusFd <$> hGetContents statusreadh)
st <- waitForProcess pid
let siginfo = if st == ExitSuccess
then case mgpgkeyid of
Just gpgkeyid -> Just (gpgkeyid, signeddata)
Nothing -> Nothing
else Nothing
return (siginfo, sigdesc)
where
verifyopts statuswritefd =
[ "--status-fd", show statuswritefd
, "--verify"
, "--output", "-"
]
parseStatusFd :: String -> Maybe GpgKeyId
parseStatusFd = go . map words . lines
where
go [] = Nothing
go ((_:"VALIDSIG":_:_:_:_:_:_:_:_:_:keyid:_):_) = Just (GpgKeyId keyid)
go (_:rest) = go rest
|
