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
|
module Channel (
Channel,
ChannelRequest, ChannelRequestData(..),
ChannelAccept, ChannelAcceptData(..),
createChannelRequest,
acceptChannelRequest,
acceptedChannel,
channelEncrypt,
channelDecrypt,
) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Fail
import Crypto.Cipher.AES
import Crypto.Cipher.Types
import Crypto.Data.Padding
import Crypto.Error
import Crypto.Random
import Data.ByteArray
import qualified Data.ByteArray as BA
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.List
import qualified Data.Text as T
import Identity
import PubKey
import Storage
data Channel = Channel
{ chPeers :: [Stored Identity]
, chKey :: ScrubbedBytes
}
deriving (Show)
type ChannelRequest = Signed ChannelRequestData
data ChannelRequestData = ChannelRequest
{ crPeers :: [Stored Identity]
, crKey :: Stored PublicKexKey
}
type ChannelAccept = Signed ChannelAcceptData
data ChannelAcceptData = ChannelAccept
{ caRequest :: Stored ChannelRequest
, caKey :: Stored PublicKexKey
}
instance Storable Channel where
store' ch = storeRec $ do
mapM_ (storeRef "peer") $ chPeers ch
storeText "enc" $ T.pack "aes-128-gcm"
storeBinary "key" $ chKey ch
load' = loadRec $ do
enc <- loadText "enc"
guard $ enc == "aes-128-gcm"
Channel
<$> loadRefs "peer"
<*> loadBinary "key"
instance Storable ChannelRequestData where
store' cr = storeRec $ do
mapM_ (storeRef "peer") $ crPeers cr
storeRef "key" $ crKey cr
load' = loadRec $ ChannelRequest
<$> loadRefs "peer"
<*> loadRef "key"
instance Storable ChannelAcceptData where
store' ca = storeRec $ do
storeRef "req" $ caRequest ca
storeText "enc" $ T.pack "aes-128-gcm"
storeRef "key" $ caKey ca
load' = loadRec $ do
enc <- loadText "enc"
guard $ enc == "aes-128-gcm"
ChannelAccept
<$> loadRef "req"
<*> loadRef "key"
createChannelRequest :: Stored Identity -> Stored Identity -> IO (Stored ChannelRequest)
createChannelRequest self peer = do
let st = storedStorage self
(_, xpublic) <- generateKeys st
Just skey <- loadKey $ idKeyMessage $ fromStored $ signedData $ fromStored self
wrappedStore st =<< sign skey =<< wrappedStore st ChannelRequest { crPeers = sort [self, peer], crKey = xpublic }
acceptChannelRequest :: Stored Identity -> Stored Identity -> Stored ChannelRequest -> ExceptT [String] IO (Stored ChannelAccept, Stored Channel)
acceptChannelRequest self peer req = do
guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort [self, peer]
guard $ (idKeyMessage $ fromStored $ signedData $ fromStored peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)
let st = storedStorage self
KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
liftIO $ do
(xsecret, xpublic) <- generateKeys st
Just skey <- loadKey $ idKeyMessage $ fromStored $ signedData $ fromStored self
acc <- wrappedStore st =<< sign skey =<< wrappedStore st ChannelAccept { caRequest = req, caKey = xpublic }
ch <- wrappedStore st Channel
{ chPeers = crPeers $ fromStored $ signedData $ fromStored req
, chKey = BA.take ksize $ dhSecret xsecret $
fromStored $ crKey $ fromStored $ signedData $ fromStored req
}
return (acc, ch)
acceptedChannel :: Stored Identity -> Stored Identity -> Stored ChannelAccept -> ExceptT [String] IO (Stored Channel)
acceptedChannel self peer acc = do
let st = storedStorage self
req = caRequest $ fromStored $ signedData $ fromStored acc
KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort [self, peer]
guard $ (idKeyMessage $ fromStored $ signedData $ fromStored peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)
guard $ (idKeyMessage $ fromStored $ signedData $ fromStored self) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)
Just xsecret <- liftIO $ loadKey $ crKey $ fromStored $ signedData $ fromStored req
liftIO $ wrappedStore st Channel
{ chPeers = crPeers $ fromStored $ signedData $ fromStored req
, chKey = BA.take ksize $ dhSecret xsecret $
fromStored $ caKey $ fromStored $ signedData $ fromStored acc
}
channelEncrypt :: (ByteArray ba, MonadRandom m, MonadFail m) => Channel -> ba -> m ba
channelEncrypt ch plain = do
CryptoPassed (cipher :: AES128) <- return $ cipherInit $ chKey ch
let bsize = blockSize cipher
(iv :: ByteString) <- getRandomBytes bsize
CryptoPassed aead <- return $ aeadInit AEAD_GCM cipher iv
let (tag, ctext) = aeadSimpleEncrypt aead B.empty (pad (PKCS7 bsize) plain) bsize
return $ BA.concat [ convert iv, convert tag, ctext ]
channelDecrypt :: (ByteArray ba, MonadFail m) => Channel -> ba -> m ba
channelDecrypt ch body = do
CryptoPassed (cipher :: AES128) <- return $ cipherInit $ chKey ch
let bsize = blockSize cipher
(iv, body') = BA.splitAt bsize body
(tag, ctext) = BA.splitAt bsize body'
CryptoPassed aead <- return $ aeadInit AEAD_GCM cipher iv
Just plain <- return $ unpad (PKCS7 bsize) =<< aeadSimpleDecrypt aead B.empty ctext (AuthTag $ convert tag)
return plain
|