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
|
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 Data.List
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)
gpgSign :: PublicKey -> IO (PerhapsSigned PublicKey)
gpgSign pk = do
-- 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 -> return $ GpgSigned pk sig
ExitFailure _ -> error "gpg failed"
-- | 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.
--
-- The gpg key will be retrieved from a keyserver if necessary.
--
-- Gpg outputs to stderr information about who signed the
-- data, so that will be visible to the user when eg, prompting
-- them if they want to accept a connection from that person.
--
-- This relies on gpgSign using --clearsign, so on successful
-- verification, the JSON encoded PublicKey is output to gpg's
-- stdout.
gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO (Maybe GpgKeyId)
gpgVerify _ (UnSigned _) = return Nothing
gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do
(statusreadh, statuswriteh) <- createPipe
statuswritefd <- handleToFd statuswriteh
(Just hin, Just hout, _, pid) <- createProcess $
(proc "gpg" (verifyopts statuswritefd))
{ std_in = CreatePipe
, std_out = CreatePipe
}
closeFd statuswritefd
B.hPut hin sig
hClose hin
hSetBinaryMode hout True
(signeddata, gpgkeyid) <- B.hGetContents hout
`concurrently` (parseStatusFd <$> hGetContents statusreadh)
st <- waitForProcess pid
let norm = filter (not . B.null) . B8.lines
let pkissigned = norm (val (hashValue (hash pk))) == norm signeddata
return $ if st == ExitSuccess && pkissigned
then gpgkeyid
else Nothing
where
extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts
then gpgopts
else concatMap (\s -> ["--keyserver", s]) defaultKeyServers
++ gpgopts
verifyopts statuswritefd = extraopts ++
[ "--status-fd", show statuswritefd
, "--verify"
, "--output", "-"
]
-- | Default keyservers to use. Note that only gpg 1 uses these;
-- gpg 2 has a default keyserver and ignores this option.
defaultKeyServers :: [String]
defaultKeyServers =
[ "pool.sks-keyservers.net"
, "pgpkeys.mit.edu"
]
parseStatusFd :: String -> Maybe GpgKeyId
parseStatusFd = go . map words . lines
where
go [] = Nothing
go ((_:"VALIDSIG":_:_:_:_:_:_:_:_:_:keyid:_):_) = Just (GpgKeyId keyid)
go (_:rest) = go rest
|
