summaryrefslogtreecommitdiff
path: root/src/Network/Tox/Crypto/Handlers.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2017-11-21 13:28:44 -0500
committerjoe <joe@jerkface.net>2017-11-21 13:28:44 -0500
commitbe968e3f3fb15bfcc1f2f58b04bf55c883c42bb1 (patch)
treef8ec8c4dca8e455f1549acaf3ddd3aa4604d5f18 /src/Network/Tox/Crypto/Handlers.hs
parent570b5f9983292117ed8cd34c88f65a47915edebb (diff)
Style clean-up: columns and spacing. No syntax change.
Diffstat (limited to 'src/Network/Tox/Crypto/Handlers.hs')
-rw-r--r--src/Network/Tox/Crypto/Handlers.hs234
1 files changed, 123 insertions, 111 deletions
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index e6669c3e..6e1623de 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -53,6 +53,7 @@ type NetCryptoHook = IOHook NetCryptoSession CryptoData
53type MsgTypeArray = A.UArray Word8 Word16 53type MsgTypeArray = A.UArray Word8 Word16
54type MsgOutMap = W64.Word64Map Word8 54type MsgOutMap = W64.Word64Map Word8
55-- type MsgOutMap = A.UArray Word64 Word8 -- if above is too slow, switch to this, but use reasonable bounds 55-- type MsgOutMap = A.UArray Word64 Word8 -- if above is too slow, switch to this, but use reasonable bounds
56
56msgOutMapLookup :: Word64 -> MsgOutMap -> Maybe Word8 57msgOutMapLookup :: Word64 -> MsgOutMap -> Maybe Word8
57msgOutMapLookup = W64.lookup 58msgOutMapLookup = W64.lookup
58 59
@@ -60,65 +61,75 @@ msgOutMapLookup = W64.lookup
60-- as displayed in some way to the user via mutiple views. 61-- as displayed in some way to the user via mutiple views.
61-- 62--
62data SessionView = SessionView 63data SessionView = SessionView
63 { svNick :: TVar ByteString 64 { svNick :: TVar ByteString
64 , svStatus :: TVar UserStatus 65 , svStatus :: TVar UserStatus
65 , svStatusMsg :: TVar ByteString 66 , svStatusMsg :: TVar ByteString
66 , svNoSpam :: TVar (Maybe NoSpam) 67 , svNoSpam :: TVar (Maybe NoSpam)
67 , svGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr)) 68 , svGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr))
69
68 -- allthough these directories are not visible to others on the net 70 -- allthough these directories are not visible to others on the net
69 -- they are included in this type, because it facilitates organizing 71 -- they are included in this type, because it facilitates organizing
70 -- the disk according to your public image. 72 -- the disk according to your public image.
71 , svCacheDir :: FilePath -- ^ directory path used if the session has to use the disk for cache 73
72 -- clean up only if space is needed 74 , svCacheDir :: FilePath -- ^ directory path used if the session has
73 , svTmpDir :: FilePath -- ^ Once off storage goes here, should clean up quickly 75 -- to use the disk for cache clean up only
74 , svConfigDir :: FilePath -- ^ profile related storage, etc, never clean up 76 -- if space is needed
77
78 , svTmpDir :: FilePath -- ^ Once off storage goes here, should
79 -- clean up quickly
80
81 , svConfigDir :: FilePath -- ^ profile related storage, etc, never clean up
75 , svDownloadDir :: TVar FilePath -- ^ where to put files the user downloads 82 , svDownloadDir :: TVar FilePath -- ^ where to put files the user downloads
76 } 83 }
77 84
78type SessionID = Word64 85type SessionID = Word64
79 86
80data NetCryptoSession = NCrypto { ncState :: TVar NetCryptoSessionStatus 87data NetCryptoSession = NCrypto
81 , ncSessionId :: SessionID 88 { ncState :: TVar NetCryptoSessionStatus
82 , ncTheirPublicKey :: PublicKey -- Tox id w/o nospam 89 , ncSessionId :: SessionID
83 , ncTheirBaseNonce :: TVar Nonce24 -- base nonce + packet number 90 , ncTheirPublicKey :: PublicKey -- Tox id w/o nospam
84 , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number 91 , ncTheirBaseNonce :: TVar Nonce24 -- base nonce + packet number
85 , ncHandShake :: TVar (Maybe (Handshake Encrypted)) 92 , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number
86 , ncCookie :: TVar (Maybe Cookie) -- ^ Cookie issued by remote peer 93 , ncHandShake :: TVar (Maybe (Handshake Encrypted))
87 , ncTheirDHTKey :: PublicKey 94 , ncCookie :: TVar (Maybe Cookie) -- ^ Cookie issued by remote peer
88 , ncTheirSessionPublic :: Maybe PublicKey 95 , ncTheirDHTKey :: PublicKey
89 , ncSessionSecret :: SecretKey 96 , ncTheirSessionPublic :: Maybe PublicKey
90 , ncSockAddr :: SockAddr 97 , ncSessionSecret :: SecretKey
91 , ncHooks :: TVar (Map.Map MessageType [NetCryptoHook]) 98 , ncSockAddr :: SockAddr
92 , ncUnrecognizedHook :: TVar (MessageType -> NetCryptoHook) 99 , ncHooks :: TVar (Map.Map MessageType [NetCryptoHook])
93 , ncIncomingTypeArray :: TVar MsgTypeArray 100 , ncUnrecognizedHook :: TVar (MessageType -> NetCryptoHook)
94 -- ^ supported messages, 0 for unsupported, 101 , ncIncomingTypeArray :: TVar MsgTypeArray -- ^ supported messages, 0 for unsupported,
95 -- otherwise the messageType, some message types 102 -- otherwise the messageType, some message types
96 -- may not be in ncHooks yet, but they should appear 103 -- may not be in ncHooks yet, but they should appear
97 -- here if ncUnrecognizedHook will add them to ncHooks 104 -- here if ncUnrecognizedHook will add them to ncHooks
98 -- on an as-need basis. 105 -- on an as-need basis.
99 , ncOutgoingIdMap :: TVar MsgOutMap 106 , ncOutgoingIdMap :: TVar MsgOutMap
100 , ncAllSessions :: NetCryptoSessions -- ^ may be needed if one net-crypto session 107 , ncAllSessions :: NetCryptoSessions -- ^ may be needed if one net-crypto session
101 -- needs to possibly start another, as is 108 -- needs to possibly start another, as is
102 -- the case in group chats 109 -- the case in group chats
103 , ncView :: TVar SessionView 110 , ncView :: TVar SessionView
104 , ncPacketQueue :: PacketQueue CryptoData 111 , ncPacketQueue :: PacketQueue CryptoData
105 , ncBufferStart :: TVar Word32 112 , ncBufferStart :: TVar Word32
106 , ncPingMachine :: Maybe PingMachine 113 , ncPingMachine :: Maybe PingMachine
107 , ncOutgoingQueue :: PQ.PacketOutQueue (State,Nonce24,TVar MsgOutMap) CryptoMessage (CryptoPacket Encrypted) CryptoData 114 , ncOutgoingQueue :: PQ.PacketOutQueue (State,Nonce24,TVar MsgOutMap)
108 } 115 CryptoMessage
109 116 (CryptoPacket Encrypted)
110data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession) 117 CryptoData
111 , netCryptoSessionsByKey :: TVar (Map.Map PublicKey [NetCryptoSession]) 118 }
112 , transportCrypto :: TransportCrypto 119
113 , defaultHooks :: Map.Map MessageType [NetCryptoHook] 120data NetCryptoSessions = NCSessions
114 , defaultUnrecognizedHook :: MessageType -> NetCryptoHook 121 { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession)
115 , sessionView :: SessionView 122 , netCryptoSessionsByKey :: TVar (Map.Map PublicKey [NetCryptoSession])
116 , msgTypeArray :: MsgTypeArray 123 , transportCrypto :: TransportCrypto
117 , inboundQueueCapacity :: Word32 124 , defaultHooks :: Map.Map MessageType [NetCryptoHook]
118 , outboundQueueCapacity :: Word32 125 , defaultUnrecognizedHook :: MessageType -> NetCryptoHook
119 , nextSessionId :: TVar SessionID 126 , sessionView :: SessionView
120 , announceNewSessionHooks :: TVar [IOHook (Maybe NoSpam) NetCryptoSession] 127 , msgTypeArray :: MsgTypeArray
121 } 128 , inboundQueueCapacity :: Word32
129 , outboundQueueCapacity :: Word32
130 , nextSessionId :: TVar SessionID
131 , announceNewSessionHooks :: TVar [IOHook (Maybe NoSpam) NetCryptoSession]
132 }
122 133
123type NewSessionHook = IOHook (Maybe NoSpam) NetCryptoSession 134type NewSessionHook = IOHook (Maybe NoSpam) NetCryptoSession
124 135
@@ -141,7 +152,7 @@ forgetCrypto crypto (NCSessions {netCryptoSessions,netCryptoSessionsByKey}) sess
141 ys -> Just ys) sPubKey) 152 ys -> Just ys) sPubKey)
142 153
143newSessionsState :: TransportCrypto 154newSessionsState :: TransportCrypto
144 -> (MessageType -> NetCryptoHook) -- ^ default hook 155 -> (MessageType -> NetCryptoHook) -- ^ default hook
145 -> Map.Map MessageType [NetCryptoHook] -- ^ all hooks, can be empty to start 156 -> Map.Map MessageType [NetCryptoHook] -- ^ all hooks, can be empty to start
146 -> IO NetCryptoSessions 157 -> IO NetCryptoSessions
147newSessionsState crypto unrechook hooks = do 158newSessionsState crypto unrechook hooks = do
@@ -160,37 +171,39 @@ newSessionsState crypto unrechook hooks = do
160 svDownloadDir0 <- atomically $ newTVar (homedir </> "Downloads") 171 svDownloadDir0 <- atomically $ newTVar (homedir </> "Downloads")
161 nextSessionId0 <- atomically $ newTVar 0 172 nextSessionId0 <- atomically $ newTVar 0
162 announceNewSessionHooks0 <- atomically $ newTVar [] 173 announceNewSessionHooks0 <- atomically $ newTVar []
163 return NCSessions { netCryptoSessions = x 174 return NCSessions { netCryptoSessions = x
164 , netCryptoSessionsByKey = x2 175 , netCryptoSessionsByKey = x2
165 , transportCrypto = crypto 176 , transportCrypto = crypto
166 , defaultHooks = hooks 177 , defaultHooks = hooks
167 , defaultUnrecognizedHook = unrechook 178 , defaultUnrecognizedHook = unrechook
168 , sessionView = SessionView { svNick = nick 179 , sessionView = SessionView
169 , svStatus = status 180 { svNick = nick
170 , svStatusMsg = statusmsg 181 , svStatus = status
171 , svNoSpam = nospam 182 , svStatusMsg = statusmsg
172 , svGroups = grps 183 , svNoSpam = nospam
173 , svCacheDir = cachedir 184 , svGroups = grps
174 , svTmpDir = tmpdir 185 , svCacheDir = cachedir
175 , svConfigDir = configdir 186 , svTmpDir = tmpdir
176 , svDownloadDir = svDownloadDir0 187 , svConfigDir = configdir
177 } 188 , svDownloadDir = svDownloadDir0
178 , msgTypeArray = allMsgTypes -- todo make this a parameter 189 }
179 , inboundQueueCapacity = 200 190 , msgTypeArray = allMsgTypes -- todo make this a parameter
180 , outboundQueueCapacity = 400 191 , inboundQueueCapacity = 200
181 , nextSessionId = nextSessionId0 192 , outboundQueueCapacity = 400
193 , nextSessionId = nextSessionId0
182 , announceNewSessionHooks = announceNewSessionHooks0 194 , announceNewSessionHooks = announceNewSessionHooks0
183 } 195 }
184 196
185data HandshakeParams 197data HandshakeParams
186 = HParam 198 = HParam
187 { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own 199 { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own
188 , hpOtherCookie :: Cookie 200 , hpOtherCookie :: Cookie
189 , hpTheirSessionKeyPublic :: PublicKey 201 , hpTheirSessionKeyPublic :: PublicKey
190 , hpMySecretKey :: SecretKey 202 , hpMySecretKey :: SecretKey
191 , hpCookieRemotePubkey :: PublicKey 203 , hpCookieRemotePubkey :: PublicKey
192 , hpCookieRemoteDhtkey :: PublicKey 204 , hpCookieRemoteDhtkey :: PublicKey
193 } 205 }
206
194newHandShakeData :: TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> IO (Maybe HandshakeData) 207newHandShakeData :: TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> IO (Maybe HandshakeData)
195newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr 208newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr
196 = do 209 = do
@@ -198,11 +211,11 @@ newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieR
198 <- case nodeInfo (key2id hpCookieRemoteDhtkey) addr of 211 <- case nodeInfo (key2id hpCookieRemoteDhtkey) addr of
199 Right nodeinfo -> Just <$> cookieRequestH crypto nodeinfo (CookieRequest hpCookieRemotePubkey) 212 Right nodeinfo -> Just <$> cookieRequestH crypto nodeinfo (CookieRequest hpCookieRemotePubkey)
200 Left er -> return Nothing 213 Left er -> return Nothing
201 let hinit = hashInit 214 let hinit = hashInit
202 Cookie n24 encrypted = hpOtherCookie 215 Cookie n24 encrypted = hpOtherCookie
203 hctx = hashUpdate hinit n24 216 hctx = hashUpdate hinit n24
204 hctx' = hashUpdate hctx encrypted 217 hctx' = hashUpdate hctx encrypted
205 digest = hashFinalize hctx' 218 digest = hashFinalize hctx'
206-- parameters addr {--> SockAddr -} 219-- parameters addr {--> SockAddr -}
207-- mbcookie <- case hpOtherCookie of 220-- mbcookie <- case hpOtherCookie of
208-- Nothing -> case (nodeInfo hpCookieRemoteDhtkey addr) of 221-- Nothing -> case (nodeInfo hpCookieRemoteDhtkey addr) of
@@ -213,9 +226,9 @@ newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieR
213 return $ 226 return $
214 fmap (\freshCookie' -> 227 fmap (\freshCookie' ->
215 HandshakeData 228 HandshakeData
216 { baseNonce = basenonce 229 { baseNonce = basenonce
217 , sessionKey = toPublic hpMySecretKey 230 , sessionKey = toPublic hpMySecretKey
218 , cookieHash = digest 231 , cookieHash = digest
219 , otherCookie = freshCookie' 232 , otherCookie = freshCookie'
220 }) freshCookie 233 }) freshCookie
221 234
@@ -275,8 +288,7 @@ receiveCrypto nc@NCrypto { ncState, ncPacketQueue } = do
275 Accepted -> Just <$> PQ.dequeue ncPacketQueue 288 Accepted -> Just <$> PQ.dequeue ncPacketQueue
276 Confirmed -> Just <$> PQ.dequeue ncPacketQueue 289 Confirmed -> Just <$> PQ.dequeue ncPacketQueue
277 _ -> pure Nothing 290 _ -> pure Nothing
278 tid <- myThreadId 291 forM_ cd $ runCryptoHook nc -- TODO: Is this useful?
279 forM_ cd $ runCryptoHook nc
280 return $ bufferData <$> cd 292 return $ bufferData <$> cd
281 293
282-- | called when we recieve a crypto handshake with valid cookie 294-- | called when we recieve a crypto handshake with valid cookie
@@ -334,23 +346,23 @@ freshCryptoSession sessions
334 return (return (f n24, n24, ncOutgoingIdMap0)) 346 return (return (f n24, n24, ncOutgoingIdMap0))
335 pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0 347 pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0
336 let netCryptoSession0 = 348 let netCryptoSession0 =
337 NCrypto { ncState = ncState0 349 NCrypto { ncState = ncState0
338 , ncSessionId = sessionId 350 , ncSessionId = sessionId
339 , ncTheirPublicKey = remotePublicKey 351 , ncTheirPublicKey = remotePublicKey
340 , ncTheirBaseNonce= ncTheirBaseNonce0 352 , ncTheirBaseNonce = ncTheirBaseNonce0
341 , ncMyPacketNonce = ncMyPacketNonce0 353 , ncMyPacketNonce = ncMyPacketNonce0
342 , ncHandShake = ncHandShake0 354 , ncHandShake = ncHandShake0
343 , ncCookie = cookie0 355 , ncCookie = cookie0
344 , ncTheirDHTKey = remoteDhtPublicKey 356 , ncTheirDHTKey = remoteDhtPublicKey
345 , ncTheirSessionPublic = Just theirSessionKey 357 , ncTheirSessionPublic = Just theirSessionKey
346 , ncSessionSecret = newsession 358 , ncSessionSecret = newsession
347 , ncSockAddr = addr 359 , ncSockAddr = addr
348 , ncHooks = ncHooks0 360 , ncHooks = ncHooks0
349 , ncUnrecognizedHook = ncUnrecognizedHook0 361 , ncUnrecognizedHook = ncUnrecognizedHook0
350 , ncAllSessions = sessions 362 , ncAllSessions = sessions
351 , ncIncomingTypeArray = ncIncomingTypeArray0 363 , ncIncomingTypeArray = ncIncomingTypeArray0
352 , ncOutgoingIdMap = ncOutgoingIdMap0 364 , ncOutgoingIdMap = ncOutgoingIdMap0
353 , ncView = ncView0 365 , ncView = ncView0
354 , ncPacketQueue = pktq 366 , ncPacketQueue = pktq
355 , ncBufferStart = bufstart 367 , ncBufferStart = bufstart
356 , ncPingMachine = Nothing -- error "you want the NetCrypto-PingMachine, but is it started?" 368 , ncPingMachine = Nothing -- error "you want the NetCrypto-PingMachine, but is it started?"
@@ -438,22 +450,22 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non
438 -- talk to not yet existent Network-Manager to ascertain current permissions 450 -- talk to not yet existent Network-Manager to ascertain current permissions
439 return 451 return
440 HParam 452 HParam
441 { hpTheirBaseNonce = Just baseNonce 453 { hpTheirBaseNonce = Just baseNonce
442 , hpOtherCookie = otherCookie 454 , hpOtherCookie = otherCookie
443 , hpTheirSessionKeyPublic = sessionKey 455 , hpTheirSessionKeyPublic = sessionKey
444 , hpMySecretKey = key 456 , hpMySecretKey = key
445 , hpCookieRemotePubkey = remotePubkey 457 , hpCookieRemotePubkey = remotePubkey
446 , hpCookieRemoteDhtkey = remoteDhtkey 458 , hpCookieRemoteDhtkey = remoteDhtkey
447 } 459 }
448 case lr of 460 case lr of
449 Left _ -> return () 461 Left _ -> return ()
450 Right hp@(HParam 462 Right hp@(HParam
451 { hpTheirBaseNonce = Just theirBaseNonce 463 { hpTheirBaseNonce = Just theirBaseNonce
452 , hpOtherCookie = otherCookie 464 , hpOtherCookie = otherCookie
453 , hpTheirSessionKeyPublic = theirSessionKey 465 , hpTheirSessionKeyPublic = theirSessionKey
454 , hpMySecretKey = key 466 , hpMySecretKey = key
455 , hpCookieRemotePubkey = remotePublicKey 467 , hpCookieRemotePubkey = remotePublicKey
456 , hpCookieRemoteDhtkey = remoteDhtPublicKey 468 , hpCookieRemoteDhtkey = remoteDhtPublicKey
457 }) -> do 469 }) -> do
458 sessionsmap <- atomically $ readTVar allsessions 470 sessionsmap <- atomically $ readTVar allsessions
459 -- Do a lookup, so we can handle the update case differently 471 -- Do a lookup, so we can handle the update case differently
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 18:01:04 +0000