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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
module Network.Tox.Crypto.Handlers where
import Network.Tox.Crypto.Transport
import Network.Tox.DHT.Transport (Cookie(..),CookieData(..))
import Crypto.Tox
import Control.Concurrent.STM
import Network.Address
import qualified Data.Map.Strict as Map
import Crypto.Hash
import Control.Applicative
import Control.Monad
import Data.Time.Clock.POSIX
import qualified Data.ByteString as B
import Control.Lens
import Data.Function
import Data.Serialize as S
import Data.Word
import GHC.Conc (unsafeIOToSTM)
-- util, todo: move to another module
maybeToEither :: Maybe b -> Either String b
maybeToEither (Just x) = Right x
maybeToEither Nothing = Left "maybeToEither"
data NetCryptoSessionStatus = Unaccepted | Accepted | Confirmed
deriving (Eq,Ord,Show,Enum)
type IOHook addr x = addr -> x -> IO (Maybe (x -> x))
type NetCryptoHook = IOHook NetCryptoSession CryptoData
data NetCryptoSession = NCrypto { ncState :: TVar NetCryptoSessionStatus
, ncTheirBaseNonce :: TVar Nonce24 -- base nonce + packet number
, ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number
, ncHandShake :: TVar (Maybe (Handshake Encrypted))
, ncCookie :: TVar (Maybe Cookie)
, ncTheirSessionPublic :: Maybe PublicKey
, ncSessionSecret :: SecretKey
, ncSockAddr :: SockAddr
, ncHooks :: TVar (Map.Map MessageType [NetCryptoHook])
, ncUnrecognizedHook :: TVar (MessageType -> NetCryptoHook)
, ncAllSessions :: NetCryptoSessions -- ^ may be needed if one net-crypto session
-- needs to possibly start another, as is
-- the case in group chats
}
data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession)
, transportCrypto :: TransportCrypto
, defaultHooks :: Map.Map MessageType [NetCryptoHook]
, defaultUnrecognizedHook :: MessageType -> NetCryptoHook
}
newSessionsState :: TransportCrypto -> (MessageType -> NetCryptoHook) -> Map.Map MessageType [NetCryptoHook] -> IO NetCryptoSessions
newSessionsState crypto unrechook hooks = do
x <- atomically $ newTVar Map.empty
return NCSessions { netCryptoSessions = x
, transportCrypto = crypto
, defaultHooks = hooks
, defaultUnrecognizedHook = unrechook
}
data HandshakeParams
= HParam
{ hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own
, hpOtherCookie :: Maybe Cookie
, hpTheirSessionKeyPublic :: PublicKey
, hpMySecretKey :: SecretKey
, hpCookieRemotePubkey :: PublicKey
, hpCookieRemoteDhtkey :: PublicKey
}
newHandShakeData :: TransportCrypto -> HandshakeParams -> HandshakeData
newHandShakeData = error "todo"
cryptoNetHandler :: NetCryptoSessions -> SockAddr -> NetCrypto -> IO (Maybe (NetCrypto -> NetCrypto))
cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) nonce24 encrypted)) = do
-- Handle Handshake Message
let crypto = transportCrypto sessions
allsessions = netCryptoSessions sessions
anyRight xs f = foldr1 (<|>) $ map f xs
seckeys <- map fst <$> atomically (readTVar (userKeys crypto))
symkey <- atomically $ transportSymmetric crypto
now <- getPOSIXTime
let lr = do -- Either Monad
(CookieData cookieTime remotePubkey remoteDhtkey) <- (decodePlain =<< decryptSymmetric symkey n24 ecookie)
(key,HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie })
<- anyRight seckeys $ \key -> (key,) <$> (decodePlain =<< decrypt (computeSharedSecret key remotePubkey nonce24) encrypted)
-- check cookie time < 15 seconds ago
guard (now - fromIntegral cookieTime < 15)
-- cookie hash is valid? sha512 of ecookie
let hinit = hashInit
hctx = hashUpdate hinit n24
hctx' = hashUpdate hctx ecookie
digest = hashFinalize hctx'
guard (cookieHash == digest)
-- known friend?
-- todo
return
HParam
{ hpTheirBaseNonce = Just baseNonce
, hpOtherCookie = Just otherCookie
, hpTheirSessionKeyPublic = sessionKey
, hpMySecretKey = key
, hpCookieRemotePubkey = remotePubkey
, hpCookieRemoteDhtkey = remoteDhtkey
}
case lr of
Left _ -> return ()
Right hp@(HParam
{ hpTheirBaseNonce = Just theirBaseNonce
, hpOtherCookie = Just otherCookie
, hpTheirSessionKeyPublic = theirSessionKey
, hpMySecretKey = key
, hpCookieRemotePubkey = remotePublicKey
, hpCookieRemoteDhtkey = remoteDhtPublicKey
}) -> do
sessionsmap <- atomically $ readTVar allsessions
-- Do a lookup, in case we decide to handle the update case differently
case Map.lookup addr sessionsmap of
_ -> do -- create new session
ncState0 <- atomically $ newTVar Accepted
ncTheirBaseNonce0 <- atomically $ newTVar theirBaseNonce
n24 <- atomically $ transportNewNonce crypto
let myhandshakeData = newHandShakeData crypto hp
plain = encodePlain myhandshakeData
state = computeSharedSecret key remoteDhtPublicKey n24
encrypted = encrypt state plain
myhandshake = Handshake { handshakeCookie = otherCookie
, handshakeNonce = n24
, handshakeData = encrypted
}
ncMyPacketNonce0 <- atomically $ newTVar (baseNonce myhandshakeData)
ncHandShake0 <- atomically $ newTVar (Just myhandshake)
cookie0 <- atomically $ newTVar (Just otherCookie)
newsession <- generateSecretKey
ncHooks0 <- atomically $ newTVar (defaultHooks sessions)
ncUnrecognizedHook0 <- atomically $ newTVar (defaultUnrecognizedHook sessions)
let netCryptoSession =
NCrypto { ncState = ncState0
, ncTheirBaseNonce= ncTheirBaseNonce0
, ncMyPacketNonce = ncMyPacketNonce0
, ncHandShake = ncHandShake0
, ncCookie = cookie0
, ncTheirSessionPublic = Just theirSessionKey
, ncSessionSecret = newsession
, ncSockAddr = addr
, ncHooks = ncHooks0
, ncUnrecognizedHook = ncUnrecognizedHook0
, ncAllSessions = sessions
}
atomically $ modifyTVar allsessions (Map.insert addr netCryptoSession)
return Nothing
cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
let crypto = transportCrypto sessions
allsessions = netCryptoSessions sessions
sessionsmap <- atomically $ readTVar allsessions
-- Handle Encrypted Message
case Map.lookup addr sessionsmap of
Nothing -> return Nothing -- drop packet, we have no session
Just session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce}) -> do
theirBaseNonce <- atomically $ readTVar ncTheirBaseNonce
-- Try to decrypt message
let diff :: Word16
diff = nonce16 - fromIntegral (last2Bytes theirBaseNonce) -- truncating to Word16
tempNonce <- addtoNonce24 theirBaseNonce (fromIntegral diff) -- expanding to Word
let lr = do -- Either Monad --
pubkey <- maybeToEither ncTheirSessionPublic
decodePlain =<< decrypt (computeSharedSecret ncSessionSecret pubkey tempNonce) encrypted
case lr of
Left _ -> return Nothing -- decryption failed, ignore packet
Right cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm}) -> do -- decryption succeeded,
-- TODO: Why do I need bufferStart & bufferEnd?
--
-- buffer_start = highest packet number handled + 1
-- , recvbuffers buffer_start
--
-- bufferEnd = sendbuffer buffer_end if lossy, otherwise packet number
-- update ncTheirBaseNonce if necessary
when (diff > 2 * dATA_NUM_THRESHOLD)$
atomically $ do
y <- readTVar ncTheirBaseNonce
-- all because Storable forces IO...
x <- unsafeIOToSTM $ addtoNonce24 y (fromIntegral dATA_NUM_THRESHOLD)
writeTVar ncTheirBaseNonce y
-- then set session confirmed,
atomically $ writeTVar ncState Confirmed
hookmap <- atomically $ readTVar ncHooks
-- run hook
flip fix (cd,hookmap) $ \lookupAgain (cd,hookmap) -> do
let msgTyp = cd ^. messageType
case Map.lookup msgTyp hookmap of
Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result
unrecognize <- atomically $ readTVar (ncUnrecognizedHook session)
mbConsume <- unrecognize msgTyp session cd
case mbConsume of
Just f -> do
-- ncUnrecognizedHook0 may have updated the hookmap
hookmap' <- atomically $ readTVar ncHooks
lookupAgain (f cd,hookmap')
Nothing -> return Nothing
Just hooks -> flip fix (hooks,cd,msgTyp) $ \loop (hooks,cd,typ) -> do
let _ = cd :: CryptoData
case (hooks,cd) of
([],_) -> return Nothing
(hook:more,cd) -> do
r <- hook session cd :: IO (Maybe (CryptoData -> CryptoData))
case r of
Just f -> let newcd = f cd
newtyp = newcd ^. messageType
in if newtyp == typ then loop (more,newcd,newtyp)
else lookupAgain (newcd,hookmap)
Nothing -> return Nothing -- message consumed
where
last2Bytes :: Nonce24 -> Word
last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of
Right n -> n
_ -> error "unreachable-last2Bytes"
dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3
-- | handles nothing
defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook]
defaultCryptoDataHooks = Map.empty
-- | discards all unrecognized packets
defaultUnRecHook :: MessageType -> NetCryptoHook
defaultUnRecHook _ _ _ = return Nothing
-- | use to add a single hook to a specific session.
addCryptoDataHook1 :: Map.Map MessageType [NetCryptoHook] -> MessageType -> NetCryptoHook -> Map.Map MessageType [NetCryptoHook]
addCryptoDataHook1 mp typ hook = case Map.lookup typ mp of
Nothing -> Map.insert typ [hook] mp
Just hooks -> Map.insert typ (hook:hooks) mp
|
