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
|
{-# LANGUAGE OverloadedStrings, RankNTypes, DeriveGeneric #-}
module Crypto where
import Val
import Hash
import Types
import Serialization
import qualified Crypto.PubKey.Ed25519 as Ed25519
import Crypto.Error
import Crypto.Random.Entropy
import Data.ByteArray (convert)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import System.IO
import System.Process
import System.Exit
import Data.List
dummySignature :: Signature
dummySignature = OtherSignature (Val mempty)
class Signed t where
getSignature :: t -> Signature
hashExceptSignature :: t -> Hash
mkSigned :: MySessionKey -> (Signature -> t) -> t
mkSigned sk mk =
let tmp = mk dummySignature
in mk (sign sk tmp)
instance Hashable a => Signed (Activity a) where
getSignature = activitySignature
hashExceptSignature (Activity a mp mt _s) = hash $
Tagged "Activity" [hash a, hash mp, hash mt]
instance Signed Control where
getSignature = controlSignature
hashExceptSignature (Control a _s) = hash $
Tagged "Control" a
instance Hashable t => Signed (Message t) where
getSignature (ActivityMessage a) = getSignature a
getSignature (ControlMessage c) = getSignature c
hashExceptSignature (ActivityMessage a) = hashExceptSignature a
hashExceptSignature (ControlMessage c) = hashExceptSignature c
sign :: Signed v => MySessionKey -> v -> Signature
sign (MySessionKey sk pk) v = Ed25519Signature $ Val $ convert $
Ed25519.sign sk pk (toSign v)
toSign :: Signed v => v -> B.ByteString
toSign = val . hashValue . hashExceptSignature
-- | Verifiy the signature of a Signed value.
verifySigned :: Signed v => SigVerifier -> v -> Bool
verifySigned (SigVerifier verifier) v =
case getSignature v of
Ed25519Signature (Val s) ->
case Ed25519.signature s of
CryptoPassed sig -> verifier (toSign v) sig
CryptoFailed _ -> False
OtherSignature _ -> False
data SigVerifier = SigVerifier (B.ByteString -> Ed25519.Signature -> Bool)
mkSigVerifier :: PublicKey -> SigVerifier
mkSigVerifier (PublicKey (Val pk)) =
case Ed25519.publicKey pk of
CryptoPassed pk' -> SigVerifier (Ed25519.verify pk')
CryptoFailed _ -> mempty
instance Monoid SigVerifier where
mempty = SigVerifier $ \_b _s -> False
mappend (SigVerifier a) (SigVerifier b) =
SigVerifier $ \d s -> b d s || a d s
data MySessionKey = MySessionKey Ed25519.SecretKey Ed25519.PublicKey
genMySessionKey :: IO MySessionKey
genMySessionKey = do
-- Crypto.Random.Entropy may use rdrand, or /dev/random.
-- Even if you don't trust rdrand to be free of backdoors,
-- it seems safe enough to use it for a session key that
-- is only used for signing, not encryption.
rand32 <- getEntropy 32 :: IO B.ByteString
sk <- throwCryptoErrorIO $ Ed25519.secretKey rand32
return $ MySessionKey sk (Ed25519.toPublic sk)
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."
(Just hin, Just hout, _, pid) <- createProcess $
(proc "gpg" ["--clearsign", "-a"])
{ std_in = CreatePipe
, std_out = CreatePipe
}
L.hPut hin $ encode pk
hClose hin
hSetBinaryMode hout True
sig <- GpgSig . Val <$> B.hGetContents hout
st <- waitForProcess pid
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
out <- L.hGetContents hout
st <- waitForProcess pid
return $ case st of
ExitFailure _ -> False
ExitSuccess -> Just pk == decode out
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"
]
|
