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
|
{-# LANGUAGE OverloadedStrings, RankNTypes, DeriveGeneric #-}
module Gpg where
import Val
import Hash
import Types
import Crypto
import Data.ByteArray (convert)
import qualified Data.ByteString as B
import System.IO
import System.Process
import System.Exit
import Data.List
import Control.Exception
import System.Directory
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
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 -> return $ GpgSigned pk sig
ExitFailure _ -> error "gpg failed"
-- | Verify the gpg signature. The key will be retrieved from a keyserver
-- if possible. 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.
gpgVerify :: [String] -> PerhapsSigned PublicKey -> IO Bool
gpgVerify _ (UnSigned _) = return False
gpgVerify gpgopts (GpgSigned pk (GpgSig (Val sig))) = do
-- This relies on gpgSign using --clearsign, so on successful
-- verification, the JSON encoded PublicKey is output to gpg's
-- stdout.
(Just hin, Just hout, _, pid) <- createProcess $
(proc "gpg" (extraopts ++ ["--verify", "--output", "-"]))
{ std_in = CreatePipe
, std_out = CreatePipe
}
B.hPut hin sig
hClose hin
hSetBinaryMode hout True
signeddata <- B.hGetContents hout
st <- waitForProcess pid
return $ case st of
ExitFailure _ -> False
ExitSuccess -> val (hashValue (hash pk)) == signeddata
where
extraopts = if any ("--keyserver" `isPrefixOf`) gpgopts
then gpgopts
else map ("--keyserver=" ++) defaultKeyServers ++ gpgopts
-- | Default keyservers to use.
defaultKeyServers :: [String]
defaultKeyServers =
[ "pool.sks-keyservers.net"
, "pgpkeys.mit.edu"
]
|
