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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
module Channel (
Channel,
ChannelRequest, ChannelRequestData(..),
ChannelAccept, ChannelAcceptData(..),
createChannelRequest,
acceptChannelRequest,
acceptedChannel,
channelEncrypt,
channelDecrypt,
) where
import Control.Monad
import Control.Monad.Except
import Crypto.Cipher.AES
import Crypto.Cipher.Types
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 (Signed IdentityData)]
, chKey :: ScrubbedBytes
}
deriving (Show)
type ChannelRequest = Signed ChannelRequestData
data ChannelRequestData = ChannelRequest
{ crPeers :: [Stored (Signed IdentityData)]
, crKey :: Stored PublicKexKey
}
deriving (Show)
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
storeText "enc" $ T.pack "aes-128-gcm"
storeRef "key" $ crKey cr
load' = loadRec $ do
enc <- loadText "enc"
guard $ enc == "aes-128-gcm"
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 :: (MonadIO m) => Storage -> UnifiedIdentity -> UnifiedIdentity -> m (Stored ChannelRequest)
createChannelRequest st self peer = liftIO $ do
(_, xpublic) <- generateKeys st
Just skey <- loadKey $ idKeyMessage self
wrappedStore st =<< sign skey =<< wrappedStore st ChannelRequest { crPeers = sort [idData self, idData peer], crKey = xpublic }
acceptChannelRequest :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Stored Channel)
acceptChannelRequest self peer req = do
when ((crPeers $ fromStored $ signedData $ fromStored req) /= sort (map idData [self, peer])) $
throwError $ "mismatched peers in channel request"
when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $
throwError $ "channel requent not signed by peer"
let st = storedStorage req
KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
liftIO $ do
(xsecret, xpublic) <- generateKeys st
Just skey <- loadKey $ idKeyMessage 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 :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m (Stored Channel)
acceptedChannel self peer acc = do
let st = storedStorage acc
req = caRequest $ fromStored $ signedData $ fromStored acc
KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
when ((crPeers $ fromStored $ signedData $ fromStored req) /= sort (map idData [self, peer])) $
throwError $ "mismatched peers in channel accept"
when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)) $
throwError $ "channel accept not signed by peer"
when (idKeyMessage self `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $
throwError $ "original channel request not signed by us"
xsecret <- liftIO (loadKey $ crKey $ fromStored $ signedData $ fromStored req) >>= \case
Just key -> return key
Nothing -> throwError $ "secret key not found"
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, MonadIO m, MonadError String m) => Channel -> ba -> m ba
channelEncrypt ch plain = do
cipher <- case cipherInit $ chKey ch of
CryptoPassed (cipher :: AES128) -> return cipher
_ -> throwError "failed to init AES128 cipher"
let bsize = blockSize cipher
(iv :: ByteString) <- liftIO $ getRandomBytes 12
aead <- case aeadInit AEAD_GCM cipher iv of
CryptoPassed aead -> return aead
_ -> throwError "failed to init AEAD_GCM"
let (tag, ctext) = aeadSimpleEncrypt aead B.empty plain bsize
return $ BA.concat [ convert iv, ctext, convert tag ]
channelDecrypt :: (ByteArray ba, MonadError String m) => Channel -> ba -> m ba
channelDecrypt ch body = do
cipher <- case cipherInit $ chKey ch of
CryptoPassed (cipher :: AES128) -> return cipher
_ -> throwError "failed to init AES128 cipher"
let bsize = blockSize cipher
(iv, body') = BA.splitAt 12 body
(ctext, tag) = BA.splitAt (BA.length body' - bsize) body'
aead <- case aeadInit AEAD_GCM cipher iv of
CryptoPassed aead -> return aead
_ -> throwError "failed to init AEAD_GCM"
case aeadSimpleDecrypt aead B.empty ctext (AuthTag $ convert tag) of
Just plain -> return plain
Nothing -> throwError "failed to decrypt data"
|