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
|
module PubKey (
PublicKey, SecretKey,
KeyPair(generateKeys), loadKey,
Signature(sigKey), Signed, signedData, signedSignature,
sign, signAdd, isSignedBy,
PublicKexKey, SecretKexKey,
dhSecret,
) where
import Control.Monad
import Control.Monad.Except
import Crypto.Error
import qualified Crypto.PubKey.Ed25519 as ED
import qualified Crypto.PubKey.Curve25519 as CX
import Data.ByteArray
import Data.ByteString (ByteString)
import qualified Data.Text as T
import Storage
import Storage.Key
data PublicKey = PublicKey ED.PublicKey
deriving (Show)
data SecretKey = SecretKey ED.SecretKey (Stored PublicKey)
data Signature = Signature
{ sigKey :: Stored PublicKey
, sigSignature :: ED.Signature
}
deriving (Show)
data Signed a = Signed
{ signedData_ :: Stored a
, signedSignature_ :: [Stored Signature]
}
deriving (Show)
signedData :: Signed a -> Stored a
signedData = signedData_
signedSignature :: Signed a -> [Stored Signature]
signedSignature = signedSignature_
instance KeyPair SecretKey PublicKey where
keyGetPublic (SecretKey _ pub) = pub
keyGetData (SecretKey sec _) = convert sec
keyFromData kdata spub = SecretKey <$> maybeCryptoError (ED.secretKey kdata) <*> pure spub
generateKeys st = do
secret <- ED.generateSecretKey
public <- wrappedStore st $ PublicKey $ ED.toPublic secret
let pair = SecretKey secret public
storeKey pair
return (pair, public)
instance Storable PublicKey where
store' (PublicKey pk) = storeRec $ do
storeText "type" $ T.pack "ed25519"
storeBinary "pubkey" pk
load' = loadRec $ do
ktype <- loadText "type"
guard $ ktype == "ed25519"
maybe (throwError "Public key decoding failed") (return . PublicKey) .
maybeCryptoError . (ED.publicKey :: ByteString -> CryptoFailable ED.PublicKey) =<<
loadBinary "pubkey"
instance Storable Signature where
store' sig = storeRec $ do
storeRef "key" $ sigKey sig
storeBinary "sig" $ sigSignature sig
load' = loadRec $ Signature
<$> loadRef "key"
<*> loadSignature "sig"
where loadSignature = maybe (throwError "Signature decoding failed") return .
maybeCryptoError . (ED.signature :: ByteString -> CryptoFailable ED.Signature) <=< loadBinary
instance Storable a => Storable (Signed a) where
store' sig = storeRec $ do
storeRef "data" $ signedData sig
mapM_ (storeRef "sig") $ signedSignature sig
load' = loadRec $ do
sdata <- loadRef "data"
sigs <- loadRefs "sig"
forM_ sigs $ \sig -> do
let PublicKey pubkey = fromStored $ sigKey $ fromStored sig
when (not $ ED.verify pubkey (storedRef sdata) $ sigSignature $ fromStored sig) $
throwError "signature verification failed"
return $ Signed sdata sigs
sign :: SecretKey -> Stored a -> IO (Signed a)
sign secret val = signAdd secret $ Signed val []
signAdd :: SecretKey -> Signed a -> IO (Signed a)
signAdd (SecretKey secret spublic) (Signed val sigs) = do
let PublicKey public = fromStored spublic
sig = ED.sign secret public $ storedRef val
ssig <- wrappedStore (storedStorage val) $ Signature spublic sig
return $ Signed val (ssig : sigs)
isSignedBy :: Signed a -> Stored PublicKey -> Bool
isSignedBy sig key = key `elem` map (sigKey . fromStored) (signedSignature sig)
data PublicKexKey = PublicKexKey CX.PublicKey
deriving (Show)
data SecretKexKey = SecretKexKey CX.SecretKey (Stored PublicKexKey)
instance KeyPair SecretKexKey PublicKexKey where
keyGetPublic (SecretKexKey _ pub) = pub
keyGetData (SecretKexKey sec _) = convert sec
keyFromData kdata spub = SecretKexKey <$> maybeCryptoError (CX.secretKey kdata) <*> pure spub
generateKeys st = do
secret <- CX.generateSecretKey
public <- wrappedStore st $ PublicKexKey $ CX.toPublic secret
let pair = SecretKexKey secret public
storeKey pair
return (pair, public)
instance Storable PublicKexKey where
store' (PublicKexKey pk) = storeRec $ do
storeText "type" $ T.pack "x25519"
storeBinary "pubkey" pk
load' = loadRec $ do
ktype <- loadText "type"
guard $ ktype == "x25519"
maybe (throwError "public key decoding failed") (return . PublicKexKey) .
maybeCryptoError . (CX.publicKey :: ScrubbedBytes -> CryptoFailable CX.PublicKey) =<<
loadBinary "pubkey"
dhSecret :: SecretKexKey -> PublicKexKey -> ScrubbedBytes
dhSecret (SecretKexKey secret _) (PublicKexKey public) = convert $ CX.dh public secret
|