summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--dht-client.cabal2
-rw-r--r--examples/testTox.hs8
-rw-r--r--src/Network/Tox/Crypto/Handlers.hs1576
-rw-r--r--stack.ghc-8.6.yaml16
-rw-r--r--stack.lts-10.yaml14
-rw-r--r--stack.lts-11.yaml14
-rw-r--r--stack.lts-12.yaml14
-rw-r--r--[l---------]stack.yaml14
8 files changed, 20 insertions, 1638 deletions
diff --git a/dht-client.cabal b/dht-client.cabal
index 54b644d3..971363d8 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -74,6 +74,7 @@ library
74 Network.SocketLike 74 Network.SocketLike
75 Data.Digest.CRC32C 75 Data.Digest.CRC32C
76 Data.Bits.ByteString 76 Data.Bits.ByteString
77 Data.TableMethods
77 Data.Wrapper.PSQ 78 Data.Wrapper.PSQ
78 Data.Wrapper.PSQInt 79 Data.Wrapper.PSQInt
79 Data.MinMaxPSQ 80 Data.MinMaxPSQ
@@ -342,5 +343,6 @@ executable testTox
342 , containers 343 , containers
343 , network 344 , network
344 , unordered-containers 345 , unordered-containers
346 , dependent-sum
345 if flag(thread-debug) 347 if flag(thread-debug)
346 cpp-options: -DTHREAD_DEBUG 348 cpp-options: -DTHREAD_DEBUG
diff --git a/examples/testTox.hs b/examples/testTox.hs
index e82ca2d3..67c4daef 100644
--- a/examples/testTox.hs
+++ b/examples/testTox.hs
@@ -34,7 +34,8 @@ import qualified Data.HashMap.Strict as HashMap
34import qualified Data.Map.Strict as Map 34import qualified Data.Map.Strict as Map
35import Data.Time.Clock.POSIX 35import Data.Time.Clock.POSIX
36import System.Exit 36import System.Exit
37 37import Data.Dependent.Sum
38import Data.Tox.Msg
38 39
39makeToxNode :: UDPTransport -> Maybe SecretKey 40makeToxNode :: UDPTransport -> Maybe SecretKey
40 -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) 41 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
@@ -46,6 +47,7 @@ makeToxNode udp sec onSessionF = do
46 onSessionF 47 onSessionF
47 sec 48 sec
48 udp 49 udp
50 (\_ _ -> return ())
49 51
50 52
51setToxID :: Tox () -> Maybe SecretKey -> IO () 53setToxID :: Tox () -> Maybe SecretKey -> IO ()
@@ -161,7 +163,7 @@ main = do
161 case Map.lookup b_public mp_a of 163 case Map.lookup b_public mp_a of
162 Just [session] -> do 164 Just [session] -> do
163 dput XUnused "----------------- HOWDY ---------------" 165 dput XUnused "----------------- HOWDY ---------------"
164 sendMessage (sTransport session) () (UpToN MESSAGE "Howdy") 166 sendMessage (sTransport session) () (Pkt MESSAGE :=> "Howdy")
165 Just xs -> dput XUnused "Unexpectedly a has TOO MANY sesions for b" 167 Just xs -> dput XUnused "Unexpectedly a has TOO MANY sesions for b"
166 Nothing -> dput XUnused "Unexpectedly a has NO session for b" 168 Nothing -> dput XUnused "Unexpectedly a has NO session for b"
167 -- b says "Hey you!" 169 -- b says "Hey you!"
@@ -169,7 +171,7 @@ main = do
169 case Map.lookup a_public mp_b of 171 case Map.lookup a_public mp_b of
170 Just [session] -> do 172 Just [session] -> do
171 dput XUnused "----------------- HEY YOU ---------------" 173 dput XUnused "----------------- HEY YOU ---------------"
172 sendMessage (sTransport session) () (UpToN MESSAGE "Hey you!") 174 sendMessage (sTransport session) () (Pkt MESSAGE :=> "Hey you!")
173 Just xs -> dput XUnused "Unexpectedly b has TOO MANY sesions for a" 175 Just xs -> dput XUnused "Unexpectedly b has TOO MANY sesions for a"
174 Nothing -> dput XUnused "Unexpectedly b has NO session for a" 176 Nothing -> dput XUnused "Unexpectedly b has NO session for a"
175 177
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
deleted file mode 100644
index 94dde8e3..00000000
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ /dev/null
@@ -1,1576 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE NamedFieldPuns #-}
4{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE ViewPatterns #-}
8module Network.Tox.Crypto.Handlers where
9
10import Connection
11import Network.Tox.NodeId
12import Network.Tox.Crypto.Transport
13import Network.Tox.DHT.Transport (Cookie(..), NoSpam(..))
14import Crypto.Tox
15import Control.Arrow
16import Control.Concurrent.STM
17import Control.Concurrent.STM.TMChan
18import Network.Address
19import qualified Data.Map.Strict as Map
20import Control.Monad
21import Data.Time.Clock.POSIX
22import qualified Data.ByteString as B
23import Data.ByteString (ByteString)
24import Control.Lens
25import Data.Function
26import Data.PacketBuffer as PB
27import qualified Data.CyclicBuffer as CB
28 ;import Data.CyclicBuffer (CyclicBuffer)
29import Data.Serialize as S
30import Data.Word
31import Data.Maybe
32import qualified Data.Word64Map as W64
33import Data.Word64RangeMap
34import qualified Data.Set as Set
35import qualified Data.Word64RangeMap.Unboxed as U
36import qualified Data.Array.Unboxed as U
37import qualified Data.Array as A
38import SensibleDir
39import System.FilePath
40import System.Environment
41import System.Directory
42import System.Timeout
43#ifdef THREAD_DEBUG
44import Control.Concurrent.Lifted.Instrument
45#else
46import Control.Concurrent
47import GHC.Conc (labelThread)
48#endif
49import PingMachine
50import qualified Data.IntMap.Strict as IntMap
51import Control.Concurrent.Supply
52import Data.InOrOut
53import DPut
54import DebugTag
55import Text.Printf
56import Data.Bool
57import Network.Tox.Handshake
58
59type LookupPolicyFunction = ToxContact -> STM Policy
60
61-- * These types are isomorphic to Maybe, but have the advantage of documenting
62-- when an item is expected to become known.
63data UponDHTKey a = NeedDHTKey | HaveDHTKey a deriving (Functor,Show,Eq)
64data UponCookie a = NeedCookie | HaveCookie a deriving (Functor,Show,Eq)
65data UponHandshake a = NeedHandshake | HaveHandshake a deriving (Functor,Show,Eq)
66data UponCryptoPacket a = NeedCryptoPacket | HaveCryptoPacket a deriving (Functor,Show,Eq)
67
68-- util, todo: move to another module
69maybeToEither :: AsMaybe f => f b -> Either String b
70maybeToEither y | Just x <- toMaybe y = Right x
71maybeToEither _ = Left "maybeToEither"
72
73-- | type class encoding of isomorphism to Maybe
74class AsMaybe f where
75 toMaybe :: f a -> Maybe a
76 -- | The o in from is left out so as not to colide with 'Data.Maybe.fromMaybe'
77 frmMaybe :: Maybe a -> f a
78
79instance AsMaybe Maybe where
80 toMaybe x = x
81 frmMaybe x = x
82
83instance AsMaybe UponDHTKey where
84 toMaybe NeedDHTKey = Nothing
85 toMaybe (HaveDHTKey x) = Just x
86 frmMaybe Nothing = NeedDHTKey
87 frmMaybe (Just x) = HaveDHTKey x
88
89instance AsMaybe UponCookie where
90 toMaybe NeedCookie = Nothing
91 toMaybe (HaveCookie x) = Just x
92 frmMaybe Nothing = NeedCookie
93 frmMaybe (Just x) = HaveCookie x
94
95instance AsMaybe UponHandshake where
96 toMaybe NeedHandshake = Nothing
97 toMaybe (HaveHandshake x) = Just x
98 frmMaybe Nothing = NeedHandshake
99 frmMaybe (Just x) = HaveHandshake x
100
101instance AsMaybe UponCryptoPacket where
102 toMaybe NeedCryptoPacket = Nothing
103 toMaybe (HaveCryptoPacket x) = Just x
104 frmMaybe Nothing = NeedCryptoPacket
105 frmMaybe (Just x) = HaveCryptoPacket x
106
107
108--data NetCryptoSessionStatus = Unaccepted | Accepted {- InProgress AwaitingSessionPacket -} | Confirmed {- Established -}
109-- deriving (Eq,Ord,Show,Enum)
110
111
112-- | The idea of IOHook is to replicate the familiar pattern
113-- where a function returns Nothing to consume a value
114-- or a function used to modify the value and pass it
115-- to be processed by another hook.
116type IOHook addr x = addr -> x -> IO (Maybe (x -> x))
117
118-- | NetCryptoHook's use the Session as their 'addr' and the
119-- value they consume or modify is CryptoMessage.
120type NetCryptoHook = IOHook NetCryptoSession CryptoMessage
121
122-- | Convert an id byte to it's type (in Word64 format)
123-- Although the type doesn't enforce it, MsgTypeArray
124-- should always have 256 entries.
125type MsgTypeArray = U.UArray Word8 Word64
126
127-- | Information, that may be made visible in multiple sessions, as well
128-- as displayed in some way to the user via mutiple views.
129--
130data SessionView = SessionView
131 { svNick :: TVar ByteString
132 , svStatus :: TVar UserStatus
133 , svStatusMsg :: TVar ByteString
134 , svTyping :: TVar TypingStatus
135 , svNoSpam :: TVar (Maybe NoSpam)
136 , svTheirNick :: TVar ByteString
137 , svTheirStatus :: TVar UserStatus
138 , svTheirStatusMsg :: TVar ByteString
139 , svTheirTyping :: TVar TypingStatus
140 , svTheirNoSpam :: TVar (Maybe NoSpam)
141 , svGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr))
142
143 -- allthough these directories are not visible to others on the net
144 -- they are included in this type, because it facilitates organizing
145 -- the disk according to your public image.
146
147 , svCacheDir :: FilePath -- ^ directory path used if the session has
148 -- to use the disk for cache clean up only
149 -- if space is needed
150
151 , svTmpDir :: FilePath -- ^ Once off storage goes here, should
152 -- clean up quickly
153
154 , svConfigDir :: FilePath -- ^ profile related storage, etc, never clean up
155 , svDownloadDir :: TVar FilePath -- ^ where to put files the user downloads
156 }
157
158-- | A static version of 'SessionView'
159-- useful for serializing to logs
160-- or storing in the ncLastNMsgs queue
161data ViewSnapshot = ViewSnapshot
162 { vNick :: ByteString
163 , vStatus :: UserStatus
164 , vStatusMsg :: ByteString
165 , vTyping :: TypingStatus
166 , vNoSpam :: Maybe NoSpam
167 , vTheirNick :: ByteString
168 , vTheirStatus :: UserStatus
169 , vTheirStatusMsg :: ByteString
170 , vTheirTyping :: TypingStatus
171 , vTheirNoSpam :: Maybe NoSpam
172 , vGroups :: Map.Map GroupChatId (Set.Set SockAddr)
173 }
174
175instance Serialize ViewSnapshot where
176 get = ViewSnapshot <$> get <*> get <*> get <*> get <*> get
177 <*> get <*> get <*> get <*> get <*> get <*> (pure Map.empty)
178 put (ViewSnapshot nick status statusmsg typing nospam
179 nick' status' statusmsg' typing' nospam' grps)
180 = do
181 put nick
182 put status
183 put statusmsg
184 put typing
185 put nospam
186 put nick'
187 put status'
188 put statusmsg'
189 put typing'
190 put nospam'
191
192-- | Take snapshot of SessionView
193--
194-- This is useful for storing the context of
195-- remembered messages.
196viewSnapshot :: SessionView -> STM ViewSnapshot
197viewSnapshot v = do
198 nick <- readTVar (svNick v)
199 status <- readTVar (svStatus v)
200 statusMsg <- readTVar (svStatusMsg v)
201 typing <- readTVar (svTyping v)
202 noSpam <- readTVar (svNoSpam v)
203 theirNick <- readTVar (svTheirNick v)
204 theirStatus <- readTVar (svTheirStatus v)
205 theirStatusMsg <- readTVar (svTheirStatusMsg v)
206 theirTyping <- readTVar (svTheirTyping v)
207 theirNoSpam <- readTVar (svTheirNoSpam v)
208 groups <- readTVar (svGroups v)
209 return ViewSnapshot
210 { vNick = nick
211 , vStatus = status
212 , vStatusMsg = statusMsg
213 , vTyping = typing
214 , vNoSpam = noSpam
215 , vTheirNick = theirNick
216 , vTheirStatus = theirStatus
217 , vTheirStatusMsg = theirStatusMsg
218 , vTheirTyping = theirTyping
219 , vTheirNoSpam = theirNoSpam
220 , vGroups = groups
221 }
222
223type SessionID = Word64
224
225-- | Application specific listener type (Word64)
226--
227-- This is some kind of information associated with a listening TChan.
228-- It may be used to indicate what kind of packets it is interested in.
229--
230-- 0 means listen to all messages and is done automatically in 'defaultUnRecHook'
231-- any other values are left open to application specific convention.
232--
233-- This module does not know what the different values here
234-- mean, but code that sets hooks may adhere to a convention
235-- defined elsewhere.
236--
237type ListenerType = Word64
238
239data NetCryptoSession = NCrypto
240 { ncState :: TVar (Status ToxProgress)
241 , ncMyPublicKey :: PublicKey
242 , ncSessionId :: SessionID
243 , ncTheirPublicKey :: PublicKey -- Tox id w/o nospam
244 , ncTheirBaseNonce :: TVar (UponHandshake Nonce24) -- base nonce + packet number
245 , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number
246 , ncHandShake :: TVar (UponHandshake (Handshake Encrypted))
247 , ncCookie :: TVar (UponCookie (Cookie Encrypted)) -- ^ Cookie issued by remote peer
248 , ncTheirDHTKey :: UponDHTKey PublicKey
249 , ncTheirSessionPublic :: TVar (UponHandshake PublicKey)
250 , ncSessionSecret :: SecretKey
251 , ncSockAddr :: UponDHTKey SockAddr
252 -- The remaining fields correspond to implementation specific state --
253 -- where as the prior fields will be used in any implementation --
254 , ncHooks :: TVar (Map.Map MessageType [NetCryptoHook])
255 , ncOutHooks :: RangeMap TArray
256 (TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted)))
257 TVar
258 , ncUnrecognizedHook :: TVar (MessageType -> NetCryptoHook)
259 , ncIdleEventHooks :: TVar [(Int,NetCryptoSession -> IO ())]
260 , ncDestoryHooks :: TVar [(Int,NetCryptoSession -> IO ())]
261 , ncIncomingTypeArray :: TVar MsgTypeArray
262 -- ^ This array maps 255 Id bytes to MessageType
263 -- It should contain all messages this session understands.
264 -- Use 0 for unsupported. It is used when a message comes
265 -- in, and should ordinarily be the identity map.
266 --
267 -- Id's 0xC7 and 0x63 should contain range-specifying types only, if
268 -- such things come to be defined, because these MessageId's are
269 -- always escapes.
270 --
271 -- Currently, the values at these indices are ignored.
272 , ncOutgoingIdMap :: U.RangeMap TArray Word8 TVar
273 -- ^ used to lookup the outgoing id for a type when sending an outoing message
274 , ncOutgoingIdMapEscapedLossy :: TVar (A.Array Word8 Word8)
275 -- ^ mapping of secondary id, when primary id is 0xC7
276 -- (These Id's are called 'MessageName' in 'Network.Tox.Crypto.Transport')
277 -- used when sending an outoing message
278 , ncOutgoingIdMapEscapedLossless :: TVar (A.Array Word8 Word8)
279 -- ^ mapping of secondary id, when primary id is 0x63
280 -- (These Id's are called 'MessageName' in 'Network.Tox.Crypto.Transport')
281 -- used when sending an outoing message
282 , ncAllSessions :: NetCryptoSessions
283 -- ^ needed if one net-crypto session
284 -- needs to possibly start another, as is
285 -- the case in group chats
286 , ncView :: TVar SessionView
287 -- ^ contains your nick, status etc
288 , ncPacketBuffer :: PacketBuffer CryptoData (CryptoPacket Encrypted)
289 -- ^ a buffer in which incoming packets may be stored out of order
290 -- but from which they may be extracted in sequence,
291 -- helps ensure lossless packets are processed in order
292 , ncStoredRequests :: CyclicBuffer CryptoData
293 -- ^ Store the last 5 packet requests, try handling in any order
294 -- if the connection seems like it is locked (TODO)
295 , ncRequestInterval :: TVar Int
296 -- ^ How long (in miliseconds) to wait between packet requests
297 , ncAliveInterval :: TVar Int
298 -- ^ How long before the next ALIVE packet ("PING")
299 -- is to be sent regardless of activity
300 , ncTimeOut :: TVar Int
301 -- ^ How many miliseconds of inactivity before this session is abandoned
302 , ncIdleEvent :: TVar Int
303 -- ^ How many miliseconds of inactivity before emergency measures are taken
304 -- Emergency measures = (rehandle the packet requests stored in ncStoredRequests)
305 , ncRequestThread :: TVar (Maybe ThreadId)
306 -- ^ thread which sends packet requests
307 , ncDequeueThread :: TVar (Maybe ThreadId)
308 -- ^ when the thread which dequeues from ncPacketQueue
309 -- is started, its ThreadId is stored here
310 , ncDequeueOutGoingThread :: TVar (Maybe ThreadId)
311 -- ^ the thread which actually sends lossless packets
312 , ncPingMachine :: TVar (Maybe PingMachine)
313 -- ^ thread which triggers ping events
314 , ncPingThread :: TVar (Maybe ThreadId)
315 -- ^ thread which actually queues outgoing pings
316 , ncIdleEventThread :: TVar (Maybe ThreadId)
317 , ncOutgoingQueue :: TVar (UponHandshake NetCryptoOutQueue)
318 {-
319 (PQ.PacketOutQueue
320 (State,Nonce24,U.RangeMap TArray Word8 TVar)
321 CryptoMessage
322 (CryptoPacket Encrypted)
323 CryptoData)) -}
324 -- ^ To send a message add it to this queue, by calling 'tryAppendQueueOutgoing'
325 -- but remember to call 'readyOutGoing' first, because the shared secret cache
326 -- presently requires the IO monad.
327 -- This specialized queue handles setting buffer_start and buffer_end and encrypting
328 -- 'readyOutGoing' provides the first parameter to 'tryAppendQueueOutgoing'
329 , ncLastNMsgs :: CyclicBuffer (Bool{-Handled?-},(ViewSnapshot,InOrOut CryptoMessage))
330 -- ^ cyclic buffer, holds the last N non-handshake crypto messages
331 -- even if there is no attached user interface.
332 , ncListeners :: TVar (IntMap.IntMap (ListenerType,TMChan CryptoMessage))
333 -- ^ user interfaces may "listen" by inserting themselves into this map
334 -- with a unique id and a new TChan, and then reading from the TChan
335 }
336instance Eq NetCryptoSession where
337 x == y = ncSessionId x == ncSessionId y
338
339data NetCryptoSessions = NCSessions
340 { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession)
341 , netCryptoSessionsByKey :: TVar (Map.Map PublicKey [NetCryptoSession])
342 , netCryptoPolicyByKey :: LookupPolicyFunction
343 , transportCrypto :: TransportCrypto
344 , defaultHooks :: Map.Map MessageType [NetCryptoHook]
345 , defaultUnrecognizedHook :: MessageType -> NetCryptoHook
346 , defaultIdleEventHooks :: [(Int,NetCryptoSession -> IO ())]
347 , defaultDestroyHook :: [(Int,NetCryptoSession -> IO ())]
348 , sessionView :: SessionView
349 , msgTypeArray :: MsgTypeArray
350 , inboundQueueCapacity :: Word32
351 , outboundQueueCapacity :: Word32
352 , nextSessionId :: TVar SessionID
353 , announceNewSessionHooks :: TVar [IOHook (Maybe NoSpam) NetCryptoSession]
354 , sendHandshake :: SockAddr -> Handshake Encrypted -> IO ()
355 , sendSessionPacket :: SockAddr -> CryptoPacket Encrypted -> IO ()
356 , listenerIDSupply :: TVar Supply
357 }
358
359-- | This is the type of a hook to run when a session is created.
360type NewSessionHook = IOHook (Maybe NoSpam) NetCryptoSession
361
362addNewSessionHook :: NetCryptoSessions -> NewSessionHook -> STM ()
363addNewSessionHook allsessions@(NCSessions { announceNewSessionHooks }) hook = modifyTVar announceNewSessionHooks (hook:)
364
365addDestroySessionHook :: NetCryptoSession -> (Maybe Int) -> (NetCryptoSession -> IO ()) -> STM Int
366addDestroySessionHook netcrypto mbkey hook = do
367 modifyTVar (ncDestoryHooks netcrypto) $ \hooklist ->
368 case mbkey of
369 Just key -> ((key,hook):filter ((/=key) . fst) hooklist)
370 Nothing -> let maxkey = maximum (map fst hooklist)
371 in if null hooklist then [(0,hook)] else (maxkey+1,hook):hooklist
372 fst . head <$> readTVar (ncDestoryHooks netcrypto)
373
374forgetCrypto :: TransportCrypto -> NetCryptoSessions -> NetCryptoSession -> STM ()
375forgetCrypto crypto (NCSessions {netCryptoSessions,netCryptoSessionsByKey}) session = do
376 let HaveDHTKey addr = ncSockAddr session
377 sid = ncSessionId session
378 sPubKey = ncTheirPublicKey session
379 byAddrMap <- readTVar netCryptoSessions
380 {- byKeyMap <- readTVar netCryptoSessionsByKey -}
381 case Map.lookup addr byAddrMap of
382 Nothing -> return () -- already gone
383 Just _ -> do
384 modifyTVar netCryptoSessions (Map.delete addr)
385 modifyTVar netCryptoSessionsByKey (Map.update (\xs -> case filter (\x -> ncSessionId x /= sid) xs of
386 [] -> Nothing
387 ys -> Just ys) sPubKey)
388
389newSessionsState :: TransportCrypto
390 -> (NetCryptoSession -> IO ()) -- ^ default destroy hook
391 -> (MessageType -> NetCryptoHook) -- ^ default hook
392 -> Map.Map MessageType [NetCryptoHook] -- ^ all hooks, can be empty to start
393 -> IO NetCryptoSessions
394newSessionsState crypto destroyHook unrechook hooks = do
395 x <- atomically $ newTVar Map.empty
396 x2 <- atomically $ newTVar Map.empty
397 nick <- atomically $ newTVar B.empty
398 status <- atomically $ newTVar Online
399 statusmsg <- atomically $ newTVar B.empty
400 typing <- atomically $ newTVar NotTyping
401 nospam <- atomically $ newTVar Nothing
402 theirnick <- atomically $ newTVar B.empty
403 theirstatus <- atomically $ newTVar Online
404 theirstatusmsg <- atomically $ newTVar B.empty
405 theirtyping <- atomically $ newTVar NotTyping
406 theirnospam <- atomically $ newTVar Nothing
407 grps <- atomically $ newTVar Map.empty
408 pname <- getProgName
409 cachedir <- sensibleCacheDirCreateIfMissing pname
410 tmpdir <- (</> pname) <$> (getTemporaryDirectory >>= canonicalizePath) -- getCanonicalTemporaryDirectory
411 configdir <- sensibleVarLib pname
412 homedir <- getHomeDirectory
413 svDownloadDir0 <- atomically $ newTVar (homedir </> "Downloads")
414 nextSessionId0 <- atomically $ newTVar 0
415 announceNewSessionHooks0 <- atomically $ newTVar []
416 lsupply <- newSupply
417 lsupplyVar <- atomically (newTVar lsupply)
418 return NCSessions { netCryptoSessions = x
419 , netCryptoSessionsByKey = x2
420 , netCryptoPolicyByKey = \_ -> return OpenToConnect
421 , transportCrypto = crypto
422 , defaultHooks = hooks
423 , defaultUnrecognizedHook = unrechook
424 , defaultIdleEventHooks = [] -- [(0,handleRequestsOutOfOrder)]
425 , defaultDestroyHook = [(0,destroyHook)]
426 , sessionView = SessionView
427 { svNick = nick
428 , svStatus = status
429 , svStatusMsg = statusmsg
430 , svTyping = typing
431 , svNoSpam = nospam
432 , svTheirNick = theirnick
433 , svTheirStatus = theirstatus
434 , svTheirStatusMsg = theirstatusmsg
435 , svTheirTyping = theirtyping
436 , svTheirNoSpam = theirnospam
437 , svGroups = grps
438 , svCacheDir = cachedir
439 , svTmpDir = tmpdir
440 , svConfigDir = configdir
441 , svDownloadDir = svDownloadDir0
442 }
443 , msgTypeArray = allMsgTypes id -- todo make this a parameter
444 , inboundQueueCapacity = 200
445 , outboundQueueCapacity = 400
446 , nextSessionId = nextSessionId0
447 , announceNewSessionHooks = announceNewSessionHooks0
448 , sendHandshake = error "Need to set sendHandshake field of NetCryptoSessions!"
449 , sendSessionPacket = error "Need to set sendSessionPacket field of NetCryptoSessions!"
450 , listenerIDSupply = lsupplyVar
451 }
452
453type XMessage = CryptoMessage -- todo
454
455-- THIS Would work if not for the IO shared secret cache...
456-- increments packet nonce, only call when actually queuing an outgoing packet
457-- getOutGoingParam crypto session = do
458-- n24 <- (ncMyPacketNonce session)
459-- let state = computeSharedSecret (transportSecret crypto) (ncTheirPublicKey session) n24
460-- modifyTVar (ncMyPacketNonce session) (+1)
461-- rangemap <- readTVar (ncOutgoingIdMap session)
462-- return (state,n24,rangemap)
463
464ncToWire :: STM (State,Nonce24,U.RangeMap TArray Word8 TVar)
465 -> Word32{- packet number we expect to recieve -}
466 -> Word32{- buffer_end -}
467 -> Word32{- packet number -}
468 -> XMessage
469 -> STM (Maybe (CryptoPacket Encrypted,Word32{-next packet no-}))
470ncToWire getState seqno bufend pktno msg = do
471 dtrace XNetCrypto ("ncToWire TOP OF FUNCTION " ++ show msg) (return ())
472 let typ = getMessageType msg
473 typ64 = toWord64 typ
474 let lsness msg =
475 case typ of
476 Msg mid -> lossyness mid
477 GrpMsg KnownLossy _ -> Lossy
478 GrpMsg KnownLossless _ -> Lossless
479 (state,n24,msgOutMapVar) <- getState
480 -- msgOutMap <- readTVar msgOutMapVar
481 result1 <- dtrace XNetCrypto ("lookupInRangeMap typ64=" ++ show typ64 ++ " " ++ show typ ++ show msg)
482 $ U.lookupInRangeMap typ64 msgOutMapVar
483 case result1 of -- msgOutMapLookup typ64 msgOutMap of
484 Nothing -> dtrace XNetCrypto "lookupInRangeMap gave Nothing!" $ return Nothing
485 Just outid -> dtrace XNetCrypto ("encrypting packet with Nonce: " ++ show n24) $ do
486 let setMessageId (OneByte _) mid = OneByte (toEnum8 mid)
487 setMessageId (TwoByte _ x) mid = TwoByte (toEnum8 mid) x
488 setMessageId (UpToN _ x) mid = UpToN (toEnum8 mid) x
489 msg' = setMessageId msg outid
490 in case lsness msg of
491 Lossy -> let cd =
492 CryptoData
493 { bufferStart = seqno
494 , bufferEnd = bufend
495 , bufferData = msg'
496 }
497 plain = encodePlain cd
498 encrypted = encrypt state plain
499 pkt = CryptoPacket { pktNonce = let r = nonce24ToWord16 n24
500 in dtrace XNetCrypto (printf "converting n24 to word16: 0x%x" r) r
501 , pktData = encrypted }
502 in return (Just (pkt, pktno))
503 Lossless -> let cd =
504 CryptoData
505 { bufferStart = seqno
506 , bufferEnd = pktno
507 , bufferData = msg'
508 }
509 plain = encodePlain cd
510 encrypted = encrypt state plain
511 pkt = CryptoPacket { pktNonce = nonce24ToWord16 n24, pktData = encrypted }
512 in return (Just (pkt, pktno+1))
513
514-- | called when we recieve a crypto handshake with valid cookie
515-- TODO set priority on contact addr to 0 if it is older than ForgetPeriod,
516-- then increment it regardless. (Keep addr in MinMaxPSQ in Roster.Contact)
517--
518-- This function sends a handshake response packet.
519freshCryptoSession :: NetCryptoSessions -> SockAddr -> SecretKey -> POSIXTime -> HandshakeParams -> STM (Maybe (Handshake Encrypted),IO ())
520freshCryptoSession sessions
521 addr
522 newsession
523 timestamp
524 hp@(HParam
525 { hpTheirBaseNonce = mbtheirBaseNonce
526 , hpOtherCookie = otherCookie
527 , hpTheirSessionKeyPublic = mbtheirSessionKey
528 , hpMySecretKey = key
529 , hpCookieRemotePubkey = remotePublicKey
530 , hpCookieRemoteDhtkey = remoteDhtPublicKey
531 }) = do
532 let crypto = transportCrypto sessions
533 allsessions = netCryptoSessions sessions
534 allsessionsByKey = netCryptoSessionsByKey sessions
535 dmsg msg = dtrace XNetCrypto msg (return ())
536 sessionId <- do
537 x <- readTVar (nextSessionId sessions)
538 modifyTVar (nextSessionId sessions) (+1)
539 return x
540 -- ncState0 <- newTVar Accepted -- (InProgress AwaitingSessionPacket)
541 ncState0 <- newTVar (if isJust mbtheirBaseNonce
542 then InProgress AwaitingSessionPacket
543 else InProgress AwaitingHandshake)
544 ncTheirBaseNonce0 <- newTVar (frmMaybe mbtheirBaseNonce)
545 newBaseNonce <- transportNewNonce crypto
546 mbMyhandshakeData <- case nodeInfo (key2id $ hpCookieRemoteDhtkey hp) addr of
547 Right nodeinfo -> Just <$> newHandShakeData timestamp crypto newBaseNonce hp nodeinfo (toPublic newsession)
548 Left er -> return Nothing -- Unable to send handshake to non-internet socket!
549 myhandshake <- mapM (encodeHandshake timestamp crypto key remotePublicKey otherCookie) mbMyhandshakeData
550 ncHandShake0 <- newTVar (frmMaybe myhandshake)
551 ncMyPacketNonce0 <- newTVar newBaseNonce
552 cookie0 <- newTVar (HaveCookie otherCookie)
553 ncHooks0 <- newTVar (defaultHooks sessions)
554 ncUnrecognizedHook0 <- newTVar (defaultUnrecognizedHook sessions)
555 ncIdleEventHooks0 <- newTVar (defaultIdleEventHooks sessions)
556 ncDestoryHooks0 <- newTVar (defaultDestroyHook sessions)
557 ncIncomingTypeArray0 <- newTVar (msgTypeArray sessions)
558 let idMap = foldl (\mp (x,y) -> W64.insert x y mp) W64.empty (zip [0..255] [0..255])
559 (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap,ncOutHooks0) <- do
560 idmap <- U.emptySTMRangeMap
561 U.insertArrayAt idmap 0 (U.listArray (0,255) [0 .. 255])
562 -- the 2 escape ranges are adjacent, so put them in one array:
563 U.insertArrayAt idmap 512 (U.listArray (512,1023) ( replicate 256 0xC7 -- lossy escaped
564 ++ replicate 256 0x63 -- lossless escapped
565 ))
566 -- lossless as separate range could have been done:
567 -- > insertArrayAt idmap 768 (A.listArray (768,1023) (replicate 256 0x63))
568 lossyEsc <- newTVar $ U.listArray (0,255) [0 .. 255]
569 losslessEsc <- newTVar $ U.listArray (0,255) [0 .. 255]
570 outHooks <- emptySTMRangeMap
571 let doNothingHook crypto session msg = return (Left "unsupported")
572 assignHook 2 = (2,sendKillHook)
573 assignHook 16 = (16,sendLossless{-Ping-})
574 assignHook 24 = (24,sendOnlineHook)
575 assignHook 25 = (25,sendLossless{-Offline-})
576 assignHook 48 = (48,sendNickHook)
577 assignHook 49 = (49,sendStatusMsgHook)
578 assignHook 50 = (50,sendStatusHook)
579 assignHook 51 = (51,sendTypingHook)
580 assignHook 63 = (63,sendMessageHook)
581 assignHook 64 = (64,sendMessageHook{-ACTION-})
582 assignHook other = (other,doNothingHook)
583 insertArrayAt outHooks 0 (A.array (0,64) (map assignHook [0..64]))
584 return (idmap,lossyEsc,losslessEsc,outHooks)
585 ncView0 <- newTVar (sessionView sessions)
586 pktq <- PB.newPacketBuffer
587 bufstart <- newTVar 0
588 mbpktoq
589 <- case mbtheirSessionKey of
590 Nothing -> return NeedHandshake
591 Just theirSessionKey -> createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0
592 mbpktoqVar <- newTVar mbpktoq
593 lastNQ <- CB.new 10 0 :: STM (CyclicBuffer (Bool,(ViewSnapshot,InOrOut CryptoMessage)))
594 ncStoredRequests0 <- CB.new 5 0 :: STM (CyclicBuffer CryptoData)
595 listeners <- newTVar IntMap.empty
596 msgNum <- newTVar 0
597 dropNum <- newTVar 0
598 theirbasenonce <- readTVar ncTheirBaseNonce0
599 dmsg $ "freshCryptoSession: Session ncTheirBaseNonce=" ++ show theirbasenonce
600 dmsg $ "freshCryptoSession: My Session Public =" ++ show (key2id $ toPublic newsession)
601 ncTheirSessionPublic0 <- newTVar (frmMaybe mbtheirSessionKey)
602 ncRequestThread0 <- newTVar Nothing
603 ncDequeueThread0 <- newTVar Nothing
604 ncDequeueOutGoingThread0 <- newTVar Nothing
605 ncPingMachine0 <- newTVar Nothing
606 ncPingThread0 <- newTVar Nothing
607 ncIdleEventThread0 <- newTVar Nothing
608 ncRequestInterval0 <- newTVar 1000 -- (TODO: shrink this) long interval while debugging slows trace flood
609 ncAliveInterval0 <- newTVar 8000 -- 8 seconds
610 -- ping Machine parameters
611 fuzz <- return 0 -- randomRIO (0,2000) -- Fuzz to prevent simultaneous ping/pong exchanges.
612 -- Disabled because tox has no pong event.
613 ncTimeOut0 <- newTVar 32000 -- 32 seconds
614 ncIdleEvent0 <- newTVar (5000 + fuzz) -- 5 seconds
615 let netCryptoSession0 =
616 NCrypto { ncState = ncState0
617 , ncMyPublicKey = toPublic key
618 , ncSessionId = sessionId
619 , ncTheirPublicKey = remotePublicKey
620 , ncTheirBaseNonce = ncTheirBaseNonce0
621 , ncMyPacketNonce = ncMyPacketNonce0
622 , ncHandShake = ncHandShake0
623 , ncCookie = cookie0
624 , ncTheirDHTKey = HaveDHTKey remoteDhtPublicKey
625 , ncTheirSessionPublic = ncTheirSessionPublic0
626 , ncSessionSecret = newsession
627 , ncSockAddr = HaveDHTKey addr
628 , ncHooks = ncHooks0
629 , ncOutHooks = ncOutHooks0
630 , ncUnrecognizedHook = ncUnrecognizedHook0
631 , ncIdleEventHooks = ncIdleEventHooks0
632 , ncDestoryHooks = ncDestoryHooks0
633 , ncAllSessions = sessions
634 , ncIncomingTypeArray = ncIncomingTypeArray0
635 , ncOutgoingIdMap = ncOutgoingIdMap0
636 , ncOutgoingIdMapEscapedLossy = lossyEscapeIdMap
637 , ncOutgoingIdMapEscapedLossless = losslessEscapeIdMap
638 , ncView = ncView0
639 , ncPacketBuffer = pktq
640 , ncStoredRequests = ncStoredRequests0
641 , ncRequestInterval = ncRequestInterval0
642 , ncAliveInterval = ncAliveInterval0
643 , ncTimeOut = ncTimeOut0
644 , ncIdleEvent = ncIdleEvent0
645 , ncRequestThread = ncRequestThread0
646 , ncDequeueThread = ncDequeueThread0
647 , ncDequeueOutGoingThread = ncDequeueOutGoingThread0
648 , ncPingMachine = ncPingMachine0
649 , ncPingThread = ncPingThread0
650 , ncIdleEventThread = ncIdleEventThread0
651 , ncOutgoingQueue = mbpktoqVar
652 , ncLastNMsgs = lastNQ
653 , ncListeners = listeners
654 }
655 -- addSessionToMap sessions addr netCryptoSession0
656 addSessionToMapIfNotThere sessions addr netCryptoSession0
657 maybeLaunchMissles
658 <- case mbpktoq of
659 NeedHandshake -> return (return ())
660 HaveHandshake pktoq -> return (runUponHandshake netCryptoSession0 addr pktoq)
661 return (myhandshake,maybeLaunchMissles)
662
663{-
664type NetCryptoOutQueue = PQ.PacketOutQueue (State,Nonce24,U.RangeMap TArray Word8 TVar)
665 CryptoMessage
666 (CryptoPacket Encrypted)
667 CryptoData
668-}
669data NetCryptoOutQueue = NetCryptoOutQueue
670 { nqPacketBuffer :: PacketBuffer CryptoData (CryptoPacket Encrypted)
671 , nqToWire :: STM (State, Nonce24, U.RangeMap TArray Word8 TVar)
672 -> Word32
673 -> Word32
674 -> Word32
675 -> XMessage
676 -> STM (Maybe (CryptoPacket Encrypted, Word32))
677 , nqToWireIO :: IO (STM (State, Nonce24, U.RangeMap TArray Word8 TVar))
678 , nqPacketNo :: TVar Word32
679 }
680
681createNetCryptoOutQueue :: NetCryptoSessions -> SecretKey -> PublicKey -> PacketBuffer CryptoData (CryptoPacket Encrypted)
682 -> TVar Nonce24 -> U.RangeMap TArray Word8 TVar -> STM (UponHandshake NetCryptoOutQueue)
683createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 = do
684 let crypto = transportCrypto sessions
685 let toWireIO = do
686 dput XNetCrypto "=========== toWireIO TOP ==================="
687 f <- lookupNonceFunction crypto newsession theirSessionKey
688 atomically $ do
689 n24 <- readTVar ncMyPacketNonce0
690 let n24plus1 = incrementNonce24 n24
691 dtrace XNetCrypto ("ncMyPacketNonce+1=" ++ show n24plus1
692 ++ "\n toWireIO: theirSessionKey = " ++ show (key2id theirSessionKey)
693 ++ "\n toWireIO: my public session key = " ++ show (key2id (toPublic newsession))
694 ) $ writeTVar ncMyPacketNonce0 n24plus1
695 return (return (f n24, n24, ncOutgoingIdMap0))
696 seqnoVar <- newTVar 0
697 return (HaveHandshake NetCryptoOutQueue
698 { nqPacketBuffer = pktq
699 , nqToWire = ncToWire
700 , nqToWireIO = toWireIO
701 , nqPacketNo = seqnoVar
702 })
703
704-- | add new session to the lookup maps
705addSessionToMap :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM ()
706addSessionToMap sessions addrRaw netCryptoSession = do
707 let addr = either id id $ either4or6 addrRaw
708 let dmsg msg = tput XNetCrypto msg
709 dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession)
710 let remotePublicKey = ncTheirPublicKey netCryptoSession
711 allsessions = netCryptoSessions sessions
712 allsessionsByKey= netCryptoSessionsByKey sessions
713 byAddrResult <- readTVar allsessions >>= return . Map.lookup addr
714 mp <- readTVar allsessionsByKey
715 modifyTVar allsessions (Map.insert addr netCryptoSession)
716 modifyTVar allsessionsByKey (Map.insertWith (++) remotePublicKey [netCryptoSession])
717
718-- | add this session to the lookup maps, overwrite if its already in them
719addSessionToMapIfNotThere :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM ()
720addSessionToMapIfNotThere sessions addrRaw netCryptoSession = do
721 let addr = either id id $ either4or6 addrRaw
722 let dmsg msg = tput XNetCrypto msg
723 dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession)
724 let remotePublicKey = ncTheirPublicKey netCryptoSession
725 allsessions = netCryptoSessions sessions
726 allsessionsByKey= netCryptoSessionsByKey sessions
727 byAddrResult <- readTVar allsessions >>= return . Map.lookup addr
728 mp <- readTVar allsessions
729 case byAddrResult of
730 Just (NCrypto { ncSessionId = staleId }) -> do
731 dmsg $ "addSessionToMapIfNotThere: addr(" ++ show addr ++") already in map(" ++ show (map (second ncSessionId) (Map.assocs mp)) ++ ")"
732 dmsg $ "addSessionToMapIfNotThere: considering it stale(staleId=" ++ show staleId ++") and removing it from the by-key map, so remove it from by-key map."
733 dmsg $ "addSessionToMapIfNotThere: leave it in the by-addr map, and overwrite it shortly."
734 -- manually remove the stale session from the by-key map
735 modifyTVar allsessionsByKey (Map.map (filter ((/=staleId) . ncSessionId)))
736 Nothing -> -- nothing to remove
737 dmsg $ "addSessionToMapIfNotThere: addr(" ++ show addr ++") not yet in map(" ++ show (map (second ncSessionId) (Map.assocs mp)) ++ ")"
738 dmsg $ "addSessionToMapIfNotThere: Inserting addr(" ++ show addr ++") into map(" ++ show (map (second ncSessionId) (Map.assocs mp)) ++ ")"
739 -- write session to by-addr map regardless of whether one is in there,
740 -- it should overwrite on match
741 modifyTVar allsessions (Map.insert addr netCryptoSession)
742 -- Now insert new session into by-key map
743 byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey
744 case byKeyResult of
745 Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession])
746 Just xs -> do
747 -- in case we're using the same long term key on different IPs ...
748 modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs))
749
750data OutGoingResult a = OGSuccess a | OGFull | OGEncodeFail
751 deriving (Show)
752
753-- | Convert a message to packet format and append it to the front of a queue
754-- used for outgoing messages. (Note that ‘front‛ usually means the higher
755-- index in this implementation.)
756--
757-- Called from 'runUponHandshake' and 'sendCrypto'.
758--
759-- Whenever this is called, you should also send the resulting packet out on
760-- the network.
761
762tryAppendQueueOutgoing :: STM (State, Nonce24, U.RangeMap TArray Word8 TVar)
763 -> NetCryptoOutQueue
764 -> CryptoMessage
765 -> STM (OutGoingResult (CryptoPacket Encrypted))
766tryAppendQueueOutgoing getExtra outq msg = do
767 dtrace XNetCrypto ("tryAppendQueueOutgoing=========>DEBUG====?> " ++ show msg) (return ())
768 pktno <- readTVar (nqPacketNo outq)
769 nextno <- PB.expectingSequenceNumber (nqPacketBuffer outq)
770 be <- PB.nextToSendSequenceNumber (nqPacketBuffer outq)
771 mbWire <- nqToWire outq getExtra nextno be pktno msg
772 case mbWire of
773 Just (payload,seqno) -> do
774 (isFull,_) <- PB.grokOutboundPacket (nqPacketBuffer outq) (PacketSent seqno payload)
775 if isFull then return OGFull
776 else return $ OGSuccess payload
777 Nothing -> return OGEncodeFail
778
779
780runUponHandshake :: NetCryptoSession -> SockAddr -> NetCryptoOutQueue -> IO ()
781runUponHandshake netCryptoSession0 addr pktoq = do
782 dput XNetCrypto "(((((((runUponHandshake))))))) Launching threads"
783 let sessions = ncAllSessions netCryptoSession0
784 pktq = ncPacketBuffer netCryptoSession0
785 remotePublicKey = ncTheirPublicKey netCryptoSession0
786 crypto = transportCrypto sessions
787 allsessions = netCryptoSessions sessions
788 allsessionsByKey = netCryptoSessionsByKey sessions
789 sidStr = printf "(%x)" (ncSessionId netCryptoSession0)
790 -- launch dequeue thread
791 -- (In terms of data dependency, this thread could be launched prior to handshake)
792 threadid <- forkIO $ do
793 tid <- myThreadId
794 atomically $ writeTVar (ncDequeueThread netCryptoSession0) (Just tid)
795 labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey) ++ sidStr)
796 fix $ \loop -> do
797 cd <- atomically $ PB.awaitReadyPacket pktq
798 if msgID (bufferData cd) == PacketRequest
799 then do
800 dput XNetCrypto $ "Dequeued::PacketRequest seqno=" ++ show (bufferStart cd) ++ " " ++ show (bufferData cd)
801 handlePacketRequest netCryptoSession0 cd
802 else do
803 dput XNetCrypto $ "Dequeued::" ++ show (bufferData cd) ++ " now running hook..."
804 void $ runCryptoHook netCryptoSession0 (bufferData cd)
805 loop
806 dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoDequeue." ++ show (key2id remotePublicKey) ++ sidStr
807
808 -- launch request thread
809 -- (In terms of data dependency, this thread could be launched prior to handshake)
810 reqthreadId <- forkIO $ do
811 tid <- myThreadId
812 atomically $ writeTVar (ncRequestThread netCryptoSession0) (Just tid)
813 labelThread tid ("NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr)
814 fix $ \loop -> do
815 atomically (readTVar (ncRequestInterval netCryptoSession0)) >>= threadDelay . (* 1000)
816 (nums,seqno) <- atomically $ PB.packetNumbersToRequest pktq
817 dput XNetCrypto $ "(Request Thread) Missing Packets detected:" ++ show nums
818 getOutGoingParam <- nqToWireIO pktoq
819 sendPacketRequestResult <- sendLossless crypto netCryptoSession0 (createRequestPacket seqno nums)
820 case sendPacketRequestResult of
821 Left e -> dput XNetCrypto ("SEND PACKET REQUEST FAILED: " ++ e)
822 _ -> dput XNetCrypto ( "SENT PACKET REQUEST (seqno=" ++ show seqno ++") " ++ show nums)
823 loop
824 dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr
825
826 -- launch dequeueOutgoing thread
827 {-
828 -- TODO
829 threadidOutgoing <- forkIO $ do
830 tid <- myThreadId
831 atomically $ writeTVar (ncDequeueOutGoingThread netCryptoSession0) (Just tid)
832 labelThread tid ("NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey) ++ sidStr)
833 fix $ \loop -> do
834 (_,pkt) <- atomically $ PQ.dequeueOutgoing pktoq
835 dput XNetCrypto "NetCryptoDequeueOutgoing thread... Sending encrypted Packet"
836 sendSessionPacket sessions addr pkt
837 loop
838 -}
839 dput XNetCrypto $ "runUponHandshake: " ++ show "threadidOutgoing" ++ " = NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey) ++ sidStr
840
841 -- launch ping Machine thread
842 pingMachine <- forkPingMachineDynamic ("NetCrypto." ++ show (key2id remotePublicKey) ++ sidStr) (ncIdleEvent netCryptoSession0) (ncTimeOut netCryptoSession0)
843 atomically $ writeTVar (ncPingMachine netCryptoSession0) (Just pingMachine)
844
845 -- launch ping thread
846 pingThreadId <- forkIO $ do
847 tid <- myThreadId
848 atomically $ writeTVar (ncPingThread netCryptoSession0) (Just tid)
849 labelThread tid ("NetCryptoPingSender." ++ show (key2id remotePublicKey) ++ sidStr)
850 fix $ \loop -> do
851 atomically (readTVar (ncAliveInterval netCryptoSession0)) >>= threadDelay . (* 1000)
852 dput XNetCryptoOut $ "pingThread (session: " ++ show (ncSessionId netCryptoSession0) ++ ") Sending Alive(PING) Packet"
853 lr <- sendPing crypto netCryptoSession0
854 case lr of
855 Left s -> dput XNetCryptoOut $ "(pingThread session: " ++ show (ncSessionId netCryptoSession0) ++ ") " ++ s
856 Right _ -> return ()
857 loop
858
859 -- launch IdleEvent thread
860 idleThreadId <- forkIO $ do
861 tid <- myThreadId
862 atomically $ writeTVar (ncIdleEventThread netCryptoSession0) (Just tid)
863 labelThread tid ("NetCryptoIdleEvent." ++ show (key2id remotePublicKey) ++ sidStr)
864 event <- atomically $ pingWait pingMachine
865 case event of
866 PingIdle -> do
867 hooks <- atomically (readTVar (ncIdleEventHooks netCryptoSession0))
868 mapM_ (($ netCryptoSession0) . snd) hooks
869 PingTimeOut -> destroySession netCryptoSession0
870
871 -- update session with thread ids
872 let netCryptoSession = netCryptoSession0
873 -- add this session to the lookup maps
874 -- atomically $ addSessionToMapIfNotThere sessions addr netCryptoSession
875 -- run announceNewSessionHooks
876 dput XNetCrypto $ "runUponHandshake: Announcing new session"
877 hooks <- atomically $ readTVar (announceNewSessionHooks sessions)
878 sendOnline crypto netCryptoSession
879 -- Run new session hooks
880 flip fix (hooks,netCryptoSession) $ \loop (hooks,session) ->
881 case hooks of
882 [] -> return ()
883 (h:hs) -> do
884 r <- h Nothing session
885 case r of
886 Just f -> loop (hs, f session)
887 Nothing -> return ()
888
889destroySession :: NetCryptoSession -> IO ()
890destroySession session = do
891 -- first run all destory hooks
892 hooks <- atomically (readTVar (ncDestoryHooks session))
893 forM_ hooks $ \(key,hook) -> hook session
894 -- now clean up threads
895 let allsessions = ncAllSessions session
896 sid = ncSessionId session
897 stopThread :: TVar (Maybe ThreadId) -> IO ()
898 stopThread x = atomically (readTVar x) >>= maybe (return ()) killThread
899 stopMachine :: TVar (Maybe PingMachine) -> IO ()
900 stopMachine x = atomically (readTVar x) >>= maybe (return ()) pingCancel
901 atomically $ do
902 modifyTVar (netCryptoSessionsByKey allsessions)
903 $ Map.map (filter ((/=sid) . ncSessionId))
904 modifyTVar (netCryptoSessions allsessions)
905 $ Map.filterWithKey (\k v -> ncSessionId v /= sid)
906 stopMachine (ncPingMachine session)
907 stopThread (ncPingThread session)
908 stopThread (ncDequeueThread session)
909 stopThread (ncDequeueOutGoingThread session)
910 stopThread (ncRequestThread session)
911 stopThread (ncIdleEventThread session)
912
913-- | Called when we get a handshake, but there's already a session entry.
914--
915-- 1) duplicate packet ... ignore
916-- 2) handshake for new session (old session is lost?)
917
918-- 3) we initiated, this a response
919updateCryptoSession :: NetCryptoSessions -> SockAddr -> SecretKey -> POSIXTime -> HandshakeParams
920 -> NetCryptoSession -> Handshake Encrypted -> STM (Maybe (Handshake Encrypted), IO ())
921updateCryptoSession sessions addr newsession timestamp hp session handshake = do
922 let dmsg msg = tput XNetCrypto msg
923 ncState0 <- readTVar (ncState session)
924 ncTheirBaseNonce0 <- readTVar (ncTheirBaseNonce session)
925 if (ncState0 >= {-Accepted-}InProgress AwaitingSessionPacket)
926 -- If the nonce in the handshake and the dht key are both the same as
927 -- the ones we have saved, assume we already handled this and this is a
928 -- duplicate handshake packet, otherwise disregard everything, and
929 -- refresh all state.
930 --
931 then do
932 dmsg "updateCryptoSession already accepted.."
933 dmsg (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0
934 ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp)
935 ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp))
936 dmsg (" ncTheirDHTKey=" ++ show (ncTheirDHTKey session)
937 ++ bool "{/=}" "{==}" (ncTheirDHTKey session == HaveDHTKey (hpCookieRemoteDhtkey hp))
938 ++ "hpCookieRemoteDhtkey=" ++ show (hpCookieRemoteDhtkey hp))
939 if ( toMaybe ncTheirBaseNonce0 /= hpTheirBaseNonce hp
940 ||
941 ncTheirDHTKey session /= HaveDHTKey (hpCookieRemoteDhtkey hp)
942 )
943 then do
944 (r,action) <- freshCryptoSession sessions addr newsession timestamp hp
945 return (r,destroySession session >> action)
946 else return (Nothing,return ())
947 else do
948 dmsg "updateCryptoSession else clause"
949 dmsg (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0
950 ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp)
951 ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp))
952 if ( ncTheirBaseNonce0 /= frmMaybe (hpTheirBaseNonce hp))
953 then do
954 case ncTheirBaseNonce0 of
955 NeedHandshake | Just theirSessionPublic <- hpTheirSessionKeyPublic hp -> do
956 writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp))
957 writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp))
958 writeTVar (ncTheirSessionPublic session) (frmMaybe (hpTheirSessionKeyPublic hp))
959 writeTVar (ncHandShake session) (HaveHandshake handshake)
960 writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket)
961 mbpktoq <- createNetCryptoOutQueue
962 sessions
963 newsession
964 theirSessionPublic
965 (ncPacketBuffer session)
966 (ncMyPacketNonce session)
967 (ncOutgoingIdMap session)
968 writeTVar (ncOutgoingQueue session) mbpktoq
969 return (Nothing,maybe (dput XNetCrypto "ERROR: something went wrong creating the ncOutgoingQueue")
970 (runUponHandshake session addr)
971 (toMaybe mbpktoq))
972 HaveHandshake _ -> do
973 dmsg "basenonce mismatch, trigger refresh"
974 (r,action) <- freshCryptoSession sessions addr newsession timestamp hp -- basenonce mismatch, trigger refresh
975 return (r, destroySession session >> action)
976 _ -> do
977 dmsg "updateCryptoSession -- unexpected condition! have hpTheirSessionKeyPublic but missing hpTheirBaseNonce?"
978 return (Nothing,return ())
979 else do
980 writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket)
981 return (Nothing,return ())
982
983handshakeH :: NetCryptoSessions -> SockAddr -> Handshake Encrypted -> IO (Maybe a)
984handshakeH sessions addrRaw hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
985 let addr = either id id $ either4or6 addrRaw
986 dput XNetCrypto ("RECIEVED HANDSHAKE from " ++ show addr)
987 -- Handle Handshake Message
988 let crypto = transportCrypto sessions :: TransportCrypto
989 allsessions = netCryptoSessions sessions :: TVar (Map.Map SockAddr NetCryptoSession)
990 seckeys <- map fst <$> atomically (userKeys crypto)
991 dput XNetCrypto "trying the following keys:"
992 forM_ seckeys $ \k -> dput XNetCrypto $ " " ++ show (key2id . toPublic $ k)
993 symkey <- atomically $ transportSymmetric crypto
994 now <- getPOSIXTime
995 dput XNetCrypto ("Decrypt cookie with n24=" ++ show n24 ++ "\n symkey= " ++ show symkey)
996 lr <- fmap toHandshakeParams <$> decryptHandshake crypto hshake
997 case lr of
998 Left s -> dput XNetCrypto ("(NetCrypto)handshakeH: " ++ s)
999 Right hp@(HParam
1000 { hpTheirBaseNonce = Just theirBaseNonce
1001 , hpOtherCookie = otherCookie
1002 , hpTheirSessionKeyPublic = theirSessionKey
1003 , hpMySecretKey = key
1004 , hpCookieRemotePubkey = remotePublicKey
1005 , hpCookieRemoteDhtkey = remoteDhtPublicKey
1006 }) -> do
1007 dput XNetCrypto ("(NetCrypto)handshakeH: hpTheirBaseNonce = " ++ show theirBaseNonce)
1008 -- IO action to get a new session key in case we need it in transaction to come
1009 newsession <- generateSecretKey
1010 -- Do a lookup, so we can handle the update case differently
1011 let dmsg msg = dtrace XNetCrypto msg (return ())
1012 timestamp <- getPOSIXTime
1013 (myhandshake,launchThreads)
1014 <- atomically $ do
1015 sessionsmap <- readTVar allsessions
1016 case Map.lookup addr sessionsmap of
1017 Nothing -> do
1018 dmsg $ "sockaddr(" ++ show addr ++ ") not in session map(" ++ show (map (second ncSessionId) (Map.assocs sessionsmap)) ++ "), so freshCryptoSession"
1019 let k = ToxContact (key2id . toPublic $ key) (key2id remotePublicKey)
1020 policy <- netCryptoPolicyByKey sessions k
1021 case policy of
1022 x | x `elem` [OpenToConnect,TryingToConnect] ->
1023 freshCryptoSession sessions addr newsession timestamp hp -- create new session
1024 x -> do
1025 dmsg $ "Ignoring Handshake from " ++ show (key2id remotePublicKey) ++ " due to policy: " ++ show x
1026 return (Nothing,return ())
1027 Just session -> do
1028 dmsg "sockaddr ALREADY in session map, so updateCryptoSession"
1029 updateCryptoSession sessions addr (ncSessionSecret session) timestamp hp session hshake -- update existing session
1030 launchThreads
1031 forM myhandshake $ \response_handshake -> do
1032 sendHandshake sessions addr response_handshake
1033 return ()
1034 return Nothing
1035
1036sessionPacketH :: NetCryptoSessions -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (x -> x))
1037sessionPacketH sessions addrRaw (CryptoPacket nonce16 encrypted) = do
1038 let addr = either id id $ either4or6 addrRaw
1039 dput XNetCrypto ("RECIEVED CRYPTOPACKET from " ++ show addr)
1040 let crypto = transportCrypto sessions
1041 allsessions = netCryptoSessions sessions
1042 sessionsmap <- atomically $ readTVar allsessions
1043 -- Handle Encrypted Message
1044 case Map.lookup addr sessionsmap of
1045 Nothing -> do
1046 dput XNetCrypto "Dropping packet.. no session"
1047 return Nothing -- drop packet, we have no session
1048 Just session@(NCrypto { ncIncomingTypeArray, ncState, ncPacketBuffer, ncHooks,
1049 ncSessionSecret, ncTheirSessionPublic, ncTheirBaseNonce,
1050 ncPingMachine, ncSessionId, ncStoredRequests}) -> do
1051 -- Unrecognized packets, try them thrice so as to give
1052 -- handshakes some time to come in
1053 -- TODO: Remove this loop, as it is probably unnecessary.
1054 -- If it is necessary, use a queue instead.
1055 flip fix (0::Int) $ \loop i -> do
1056 mbTheirBaseNonce <- atomically $ readTVar ncTheirBaseNonce
1057 case mbTheirBaseNonce of
1058 NeedHandshake -> do
1059 dput XNetCrypto "CryptoPacket recieved, but we still dont have their base nonce?"
1060 if (i < 3)
1061 then do
1062 dput XNetCrypto $ "Trying again (maybe handshake is on its way) ... i == " ++ show i
1063 loop (i+1)
1064 else do
1065 dput XNetCrypto "Tried 3 times.. giving up on this packet"
1066 return Nothing
1067 HaveHandshake theirBaseNonce -> do
1068 -- Try to decrypt message
1069 let diff :: Word16
1070 diff = nonce16 - (last2Bytes theirBaseNonce) -- truncating to Word16
1071 tempNonce = addtoNonce24 theirBaseNonce (fromIntegral diff) -- expanding to Word
1072 mbpublickey <- atomically (readTVar ncTheirSessionPublic)
1073 lr <- fmap join $ sequence $ do -- Either Monad --
1074 pubkey <- maybeToEither mbpublickey
1075 Right $ do -- IO Monad
1076 secret <- lookupSharedSecret crypto ncSessionSecret pubkey tempNonce
1077 let step1 = decrypt secret encrypted
1078 case step1 of
1079 Left s -> do
1080 dput XNetCrypto $ "(NetCrypto)sessionPacketH: (decrypt) " ++ s
1081 return (Left s)
1082 Right pln -> do
1083 case decodePlain pln of
1084 Left s -> do
1085 dput XNetCrypto $ "(NetCrypto)sessionPacketH: (decodePlain) " ++ s
1086 return (Left s)
1087 Right x -> return (Right x)
1088 case lr of
1089 Left s -> do
1090 dput XNetCrypto $ "(NetCrypto)sessionPacketH: " ++ s
1091 return Nothing -- decryption failed, ignore packet
1092 Right cd'@(CryptoData {bufferStart, bufferEnd, bufferData=(unpadCryptoMsg -> cm)}) -> do -- decryption succeeded,
1093 let cd = cd' { bufferData= cm }
1094 -- TODO: Why do I need bufferStart & bufferEnd?
1095 --
1096 -- buffer_start = highest packet number handled + 1
1097 -- , recvbuffers buffer_start
1098 --
1099 -- bufferEnd = sendbuffer buffer_end if lossy, otherwise packet number
1100 -- update ncTheirBaseNonce if necessary
1101 when (diff > 2 * dATA_NUM_THRESHOLD)$
1102 atomically $ do
1103 HaveHandshake y <- readTVar ncTheirBaseNonce
1104 let x = addtoNonce24 y (fromIntegral dATA_NUM_THRESHOLD)
1105 dtrace XNetCrypto ("nonce y(" ++ show y ++ ") + " ++ show (fromIntegral dATA_NUM_THRESHOLD)
1106 ++ " = " ++ show x) (return ())
1107 writeTVar ncTheirBaseNonce (HaveHandshake y)
1108 -- then set session confirmed,
1109 atomically $ writeTVar ncState {-Confirmed-}Established
1110 -- bump ping machine
1111 ncPingMachine0 <- atomically $ readTVar ncPingMachine
1112 case ncPingMachine0 of
1113 -- the ping machine is used to detect inactivity and respond accordingly
1114 Just pingMachine -> pingBump pingMachine
1115 Nothing -> return ()
1116 msgTypes <- atomically $ readTVar ncIncomingTypeArray
1117 let msgTyp = cd ^. messageType
1118 msgTypMapped64 = msgTypes U.! fromEnum8 (msgID cm)
1119 msgTypMapped = fromWord64 $ msgTypMapped64
1120 isLossy (GrpMsg KnownLossy _) = True
1121 isLossy (Msg mid) | lossyness mid == Lossy = True
1122 isLossy _ = False
1123 ack = bufferStart -- Earliest sequence number they've seen from us.
1124 if (msgTypMapped /= Msg Padding && isLossy msgTypMapped) || isLossy msgTyp
1125 then do dput XNetCrypto $ "enqueue ncPacketQueue Lossy (msgTyp=" ++ show msgTyp ++ " msgTypMapped=" ++show msgTypMapped ++ ") " ++ show cm
1126 atomically $ PB.grokInboundPacket ncPacketBuffer
1127 (PacketReceivedLossy bufferEnd cd ack)
1128 runCryptoHook session (bufferData cd)
1129 else do dput XNetCrypto $ "enqueue ncPacketQueue Lossless " ++ show cm
1130 when (msgID cm == PING) $
1131 dput XNetCrypto $ "NetCrypto Recieved PING (session " ++ show ncSessionId ++")"
1132 when (msgID cm == PacketRequest) $ do
1133 dput XNetCrypto $ "PACKETREquest: " ++ showCryptoMsg bufferEnd cm
1134 -- atomically $ do
1135 -- num <- CB.getNextSequenceNum ncStoredRequests
1136 -- CB.enqueue ncStoredRequests num cd
1137 handlePacketRequest session cd
1138 atomically $ PB.grokInboundPacket ncPacketBuffer
1139 (PacketReceived bufferEnd cd ack)
1140 return Nothing
1141 where
1142 last2Bytes :: Nonce24 -> Word16
1143 last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of
1144 Right n -> n -- dtrace XNetCrypto ("byteSwap16 " ++ printf "0x%x" n ++ " = " ++ printf "0x%x" (byteSwap16 n)) $ byteSwap16 n
1145 _ -> error "unreachable-last2Bytes"
1146 dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3
1147
1148runCryptoHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (x -> x))
1149runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce,ncIncomingTypeArray})
1150 cm {-cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm})-} = do
1151 hookmap <- atomically $ readTVar ncHooks
1152 -- run hook
1153 flip fix (cm,hookmap) $ \lookupAgain (cm,hookmap) -> do
1154 msgTypes <- atomically $ readTVar ncIncomingTypeArray
1155 let msgTyp = cm ^. messageType
1156 msgTypMapped64 = msgTypes U.! fromEnum8 (msgID cm)
1157 msgTypMapped = fromWord64 $ msgTypMapped64
1158 if msgTypMapped64 == 0
1159 then return Nothing
1160 else
1161 case Map.lookup msgTypMapped hookmap of
1162 Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result
1163 unrecognize <- atomically $ readTVar (ncUnrecognizedHook session)
1164 mbConsume <- unrecognize msgTypMapped session cm
1165 case mbConsume of
1166 Just f -> do
1167 -- ncUnrecognizedHook0 may have updated the hookmap
1168 hookmap' <- atomically $ readTVar ncHooks
1169 lookupAgain (f cm,hookmap')
1170 Nothing -> return Nothing
1171 Just hooks -> flip fix (hooks,cm,msgTypMapped) $ \loop (hooks,cm,typ) -> do
1172 let _ = cm :: CryptoMessage
1173 case (hooks,cm) of
1174 ([],_) -> return Nothing
1175 (hook:more,cd) -> do
1176 r <- hook session cm :: IO (Maybe (CryptoMessage -> CryptoMessage))
1177 case r of
1178 Just f -> let newcd = f cd
1179 newtyp = newcd ^. messageType
1180 in if newtyp == typ then loop (more,newcd,newtyp)
1181 else lookupAgain (newcd,hookmap)
1182 Nothing -> return Nothing -- message consumed
1183
1184-- | construct a 'MsgTypeArray' for specified types, using their known common positions
1185-- in the MessageId space if they have such a thing.
1186mkMsgTypes :: [MessageType] -> MsgTypeArray
1187mkMsgTypes msgs = let zeros = U.listArray (0,255) (replicate 256 0)
1188 in zeros U.// map (\x -> (toIndex x,toWord64 x)) msgs
1189 where
1190 toIndex (Msg mid) = fromIntegral . fromEnum $ mid
1191 toIndex (GrpMsg KnownLossless nam) = 0x63 -- fromEnum MESSAGE_GROUPCHAT
1192 toIndex (GrpMsg KnownLossy nam) = 0xC7 -- fromEnum LOSSY_GROUPCHAT
1193
1194------------------ Slurped from c-toxcore for reference. -------------------------------
1195pattern PACKET_ID_ONLINE = 24
1196pattern PACKET_ID_OFFLINE = 25
1197pattern PACKET_ID_NICKNAME = 48
1198pattern PACKET_ID_STATUSMESSAGE = 49
1199pattern PACKET_ID_USERSTATUS = 50
1200pattern PACKET_ID_TYPING = 51
1201pattern PACKET_ID_MESSAGE = 64
1202-- pattern PACKET_ID_ACTION = (PACKET_ID_MESSAGE + MESSAGE_ACTION) {- 65 -}
1203pattern PACKET_ID_MSI = 69
1204pattern PACKET_ID_FILE_SENDREQUEST = 80
1205pattern PACKET_ID_FILE_CONTROL = 81
1206pattern PACKET_ID_FILE_DATA = 82
1207pattern PACKET_ID_INVITE_CONFERENCE = 96
1208pattern PACKET_ID_ONLINE_PACKET = 97
1209pattern PACKET_ID_DIRECT_CONFERENCE = 98
1210pattern PACKET_ID_MESSAGE_CONFERENCE = 99
1211pattern PACKET_ID_LOSSY_CONFERENCE = 199
1212pattern PACKET_ID_LOSSLESS_RANGE_START = 160
1213pattern PACKET_ID_LOSSLESS_RANGE_SIZE = 32
1214pattern PACKET_ID_ALIVE = 16
1215pattern PACKET_ID_SHARE_RELAYS = 17
1216pattern PACKET_ID_FRIEND_REQUESTS = 18
1217pattern PACKET_ID_PADDING = 0 -- Denotes padding
1218pattern PACKET_ID_REQUEST = 1 -- Used to request unreceived packets
1219pattern PACKET_ID_KILL = 2 -- Used to killconnection
1220pattern PACKET_ID_LOSSY_RANGE_START = 192
1221pattern PACKET_ID_LOSSY_RANGE_SIZE = 63
1222----------------------------------------------------------------------------------------
1223
1224
1225-- | Handle all Tox messages that this code base is aware of.
1226-- The first parameter is a function which is applied to get the values
1227-- for keys of unknown nature. Could be either 'id' or 'const 0'
1228allMsgTypes :: (Word64 -> Word64) -> MsgTypeArray
1229allMsgTypes fDefault = U.listArray (minBound,maxBound) (0:knownMsgs)
1230
1231knownMsgs :: [Word64]
1232knownMsgs =
1233 concat [ map (fromIntegral . fromEnum) [ PacketRequest .. KillPacket ]
1234 , map (const 0) [ 3 .. 15 ] -- UnspecifiedPacket
1235 , map (fromIntegral . fromEnum) [ PING ]
1236 , map (const 0) [ 17 .. 23 ] -- MessengerLoseless
1237 , map (fromIntegral . fromEnum) [ ONLINE .. OFFLINE ]
1238 , map (const 0) [ 26 .. 47 ] -- MessengerLoseless
1239 , map (fromIntegral . fromEnum) [ NICKNAME .. TYPING ]
1240 , map (const 0) [ 52 .. 63 ] -- MessengerLoseless
1241 , map (fromIntegral . fromEnum) [ MESSAGE .. ACTION ]
1242 , map (const 0) [ 66 .. 68 ] -- MessengerLoseless
1243 , map (fromIntegral . fromEnum) [ MSI ]
1244 , map (const 0) [ 70 .. 79 ] -- MessengerLoseless
1245 , map (fromIntegral . fromEnum) [ FILE_SENDREQUEST .. FILE_DATA ]
1246 , map (const 0) [ 83 .. 95 ] -- MessengerLoseless
1247 , map (fromIntegral . fromEnum) [ INVITE_GROUPCHAT .. MESSAGE_GROUPCHAT ]
1248 , map (const 0) [ 100 .. 191 ] -- MessengerLoseless
1249 , map (const 0) [ 192 .. 198 ] -- MessengerLossy
1250 , map (fromIntegral . fromEnum) [ LOSSY_GROUPCHAT ]
1251 , map (const 0) [ 200 .. 255 ] -- All lossy, exept the last
1252 ]
1253
1254sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1255sendCrypto crypto session updateLocal cm = do
1256 HaveHandshake outq <- atomically $ readTVar (ncOutgoingQueue session)
1257 -- XXX: potential race? if shared secret comes out of sync with cache?
1258 dput XNetCrypto ("sendCrypto: ENTER MESSAGE: " ++ show cm)
1259 getOutGoingParam <- nqToWireIO outq
1260 dput XNetCrypto "sendCrypto: got the io extra stuff"
1261 ncTime <- atomically $ readTVar (ncTimeOut session)
1262 r0 <- timeout (ncTime*1000) . atomically $ do
1263 result <- tryAppendQueueOutgoing getOutGoingParam outq cm
1264 case result of
1265 OGSuccess x -> updateLocal >> return (Right x)
1266 OGFull -> retry -- return (Left "Outgoing packet buffer is full")
1267 OGEncodeFail -> return (Left "Failed to encode outgoing packet")
1268 let r = case r0 of
1269 Nothing -> Left "Outgoing packet buffer is full"
1270 Just x -> x
1271 case ncSockAddr session of
1272 HaveDHTKey saddr -> mapM_ (sendSessionPacket (ncAllSessions session) saddr) r
1273 _ -> return ()
1274 return r
1275
1276sendPing :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
1277sendPing crypto session = do
1278 let cm=OneByte PING
1279 addMsgToLastN False (cm ^. messageType) session (Out cm)
1280 sendCrypto crypto session (return ()) (OneByte PING)
1281
1282sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
1283sendOnline crypto session = do
1284 let cm=OneByte ONLINE
1285 sendOnlineHook crypto session cm
1286
1287sendOnlineHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1288sendOnlineHook crypto session cm = do
1289 addMsgToLastN False (cm ^. messageType) session (Out cm)
1290 result <- sendCrypto crypto session (return ()) (OneByte ONLINE)
1291 -- double this packet
1292 case result of
1293 Right pkt -> do
1294 void . forkIO $ do
1295 tid <- myThreadId
1296 labelThread tid "TEMPORARY.PACKET.DOUBLE.ONLINE"
1297 threadDelay 100000 -- delay 10th of a second
1298 case ncSockAddr session of
1299 HaveDHTKey saddr -> sendSessionPacket (ncAllSessions session) saddr pkt
1300 return (Right pkt)
1301
1302sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
1303sendOffline crypto session = do
1304 let cm=OneByte OFFLINE
1305 sendLossless crypto session (OneByte OFFLINE)
1306
1307
1308sendLossless :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1309sendLossless crypto session cm = do
1310 addMsgToLastN False (cm ^. messageType) session (Out cm)
1311 sendCrypto crypto session (return ()) cm
1312
1313sendLossy :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1314sendLossy crypto session cm = sendCryptoLossy crypto session (return ()) cm
1315
1316sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted))
1317sendKill crypto session = do
1318 let cm=OneByte KillPacket
1319 sendKillHook crypto session cm
1320
1321sendKillHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1322sendKillHook crypto session cm = sendCryptoLossy crypto session (destroySession session) cm
1323
1324sendCryptoLossy :: TransportCrypto -> NetCryptoSession -> (IO ()) -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1325sendCryptoLossy crypto session updateLocal cm = do
1326 mbOutQ <- atomically $ readTVar (ncOutgoingQueue session)
1327 case mbOutQ of
1328 NeedHandshake -> do
1329 let errmsg = "Error sending lossy packet! (sessionid: " ++ show (ncSessionId session) ++ ") Need the Handshake first!"
1330 updateLocal
1331 return (Left errmsg)
1332 HaveHandshake outq -> do
1333 getOutGoingParam <- nqToWireIO outq
1334 mbPkt <- atomically $ do
1335 pktno <- readTVar (nqPacketNo outq)
1336 nextno <- PB.expectingSequenceNumber (nqPacketBuffer outq)
1337 be <- PB.nextToSendSequenceNumber (nqPacketBuffer outq)
1338 nqToWire outq getOutGoingParam -- See 'ncToWire'
1339 nextno -- packet number we expect to recieve
1340 be -- buffer_end (for lossy)
1341 pktno -- packet number (for lossless)
1342 cm
1343 case mbPkt of
1344 Nothing -> do
1345 let errmsg = "Error sending lossy packet! (sessionid: " ++ show (ncSessionId session) ++ ") " ++ show cm
1346 updateLocal
1347 return (Left errmsg)
1348 Just (pkt,seqno) -> do
1349 case (ncSockAddr session) of
1350 NeedDHTKey -> do
1351 let errmsg= "NetCrypto NOT SENDING Lossy packet (sessionid: " ++ show (ncSessionId session) ++ ") since no DHTkey(sockaddr) yet"
1352 updateLocal
1353 return (Left errmsg)
1354 HaveDHTKey saddr -> do
1355 sendSessionPacket (ncAllSessions session) saddr pkt
1356 dput XNetCrypto $ "sent lossy packet (sessionid: " ++ show (ncSessionId session) ++ ") " ++ take 40 (show cm) ++ "..."
1357 updateLocal
1358 return (Right pkt)
1359
1360setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
1361setNick crypto session nick = do
1362 let cm = UpToN NICKNAME nick
1363 sendNickHook crypto session cm
1364
1365sendNickHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1366sendNickHook crypto session cm = do
1367 let Just (_,maxlen) = msgSizeParam NICKNAME
1368 let nick = msgBytes cm
1369 if B.length nick > maxlen
1370 then return (Left $ "nickname must not exceed " ++ show maxlen ++ " bytes.")
1371 else do
1372 let updateLocal = do
1373 let viewVar = ncView session
1374 view <- readTVar viewVar
1375 writeTVar (svNick view) nick
1376 addMsgToLastN False (cm ^. messageType) session (Out cm)
1377 sendCrypto crypto session updateLocal cm
1378
1379setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String (CryptoPacket Encrypted))
1380setTyping crypto session status = do
1381 let cm = TwoByte TYPING (fromEnum8 status)
1382 sendTypingHook crypto session cm
1383
1384sendTypingHook:: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1385sendTypingHook crypto session cm = do
1386 let status = toEnum8 (msgByte cm)
1387 let updateLocal = do
1388 view <- readTVar (ncView session)
1389 writeTVar (svTyping view) status
1390 addMsgToLastN False (cm ^. messageType) session (Out cm)
1391 sendCrypto crypto session updateLocal cm
1392
1393setNoSpam :: TransportCrypto -> NetCryptoSession -> Maybe NoSpam -> IO (Either String ())
1394setNoSpam crypto session mbnospam = do
1395 let viewVar = ncView session
1396 atomically $ do
1397 view <- readTVar viewVar
1398 writeTVar (svNoSpam view) mbnospam
1399 return (Right ())
1400
1401setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String (CryptoPacket Encrypted))
1402setStatus crypto session status = do
1403 let cm = TwoByte USERSTATUS (fromEnum8 status)
1404 sendStatusHook crypto session cm
1405
1406sendStatusHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1407sendStatusHook crypto session cm = do
1408 let status = toEnum8 (msgByte cm)
1409 let updateLocal = do
1410 view <- readTVar (ncView session)
1411 writeTVar (svStatus view) status
1412 addMsgToLastN False (cm ^. messageType) session (Out cm)
1413 sendCrypto crypto session updateLocal cm
1414
1415setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
1416setStatusMsg crypto session msg = do
1417 let cm = UpToN STATUSMESSAGE msg
1418 sendStatusMsgHook crypto session cm
1419
1420sendStatusMsgHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1421sendStatusMsgHook crypto session cm = do
1422 let Just (_,maxlen) = msgSizeParam STATUSMESSAGE
1423 let msg = msgBytes cm
1424 if B.length msg > maxlen
1425 then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.")
1426 else do
1427 let updateLocal = do
1428 view <- readTVar (ncView session)
1429 writeTVar (svStatusMsg view) msg
1430 addMsgToLastN False (cm ^. messageType) session (Out cm)
1431 sendCrypto crypto session updateLocal cm
1432
1433sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted))
1434sendChatMsg crypto session msg = do
1435 let cm = UpToN MESSAGE msg
1436 sendMessageHook crypto session cm
1437
1438sendMessageHook :: TransportCrypto -> NetCryptoSession -> CryptoMessage -> IO (Either String (CryptoPacket Encrypted))
1439sendMessageHook crypto session cm = do
1440 let Just (_,maxlen) = msgSizeParam MESSAGE
1441 let msg = msgBytes cm
1442 if B.length msg > maxlen
1443 then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.")
1444 else do
1445 let updateLocal = do
1446 view <- readTVar (ncView session)
1447 writeTVar (svStatusMsg view) msg
1448 addMsgToLastN False (cm ^. messageType) session (Out cm)
1449 sendCrypto crypto session updateLocal cm
1450
1451-- | handles nothings
1452defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook]
1453defaultCryptoDataHooks
1454 = Map.fromList
1455 [ (Msg USERSTATUS,[defaultUserStatusHook])
1456 , (Msg TYPING,[defaultTypingHook])
1457 , (Msg NICKNAME, [defaultNicknameHook])
1458 , (Msg STATUSMESSAGE, [defaultStatusMsgHook])
1459 , (Msg KillPacket, [defaultKillHook])
1460 ]
1461
1462handleRequestsOutOfOrder :: NetCryptoSession -> IO ()
1463handleRequestsOutOfOrder session = do
1464 cds <- atomically $ CB.cyclicBufferViewList (ncStoredRequests session)
1465 mapM_ (handlePacketRequest session) (map snd cds)
1466
1467handlePacketRequest :: NetCryptoSession -> CryptoData -> IO ()
1468handlePacketRequest session (CryptoData { bufferStart=num
1469 , bufferData=cm@(msgID -> PacketRequest)
1470 }) | let getbytes (OneByte _) = []
1471 getbytes (TwoByte _ b) = [b]
1472 getbytes (UpToN _ bs) = B.unpack bs
1473 , bs <- getbytes cm
1474 , not (null bs)
1475 , HaveDHTKey addr <- ncSockAddr session
1476 = do
1477 mbOutQ <- atomically $ readTVar (ncOutgoingQueue session)
1478 case mbOutQ of
1479 HaveHandshake pktoq -> do
1480 getOutGoingParam <-nqToWireIO pktoq
1481 ps <- atomically $ PB.retrieveForResend (nqPacketBuffer pktoq) $ PB.decompressSequenceNumbers num bs
1482 let resend (n,pkt) = sendSessionPacket (ncAllSessions session) addr pkt
1483 dput XNetCrypto ("Re-Sending Packets: " ++ show (map fst ps))
1484 mapM_ resend ps
1485 _ -> dput XNetCrypto "ERROR: Incoming Packet request, yet no ncOutgoingQueue!"
1486
1487handlePacketRequest session cd = return ()
1488
1489defaultKillHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
1490defaultKillHook session cm@(msgID -> KillPacket) = do
1491 dput XNetCrypto $ "Recieved kill packet (sessionid: " ++ show (ncSessionId session) ++ ") destroying session"
1492 destroySession session
1493 return (Just $ \m -> m)
1494defaultKillHook _ _ = return (Just $ \cm -> cm)
1495
1496defaultUserStatusHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
1497defaultUserStatusHook session cm@(TwoByte {msgID=USERSTATUS, msgByte=statusByte}) = do
1498 let status = toEnum8 statusByte
1499 viewVar = ncView session
1500 atomically $ do
1501 view <- readTVar viewVar
1502 writeTVar (svTheirStatus view) status
1503 hookHelper True (Msg USERSTATUS) session cm
1504
1505defaultTypingHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
1506defaultTypingHook session cm@(TwoByte {msgID=TYPING, msgByte=statusByte}) = do
1507 let status = toEnum8 statusByte
1508 viewVar = ncView session
1509 atomically $ do
1510 view <- readTVar viewVar
1511 writeTVar (svTheirStatus view) status
1512 hookHelper True (Msg TYPING) session cm
1513
1514defaultNicknameHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
1515defaultNicknameHook session cm@(UpToN {msgID=NICKNAME, msgBytes=nick}) = do
1516 let viewVar = ncView session
1517 atomically $ do
1518 view <- readTVar viewVar
1519 writeTVar (svTheirNick view) nick
1520 hookHelper True (Msg NICKNAME) session cm
1521
1522defaultStatusMsgHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
1523defaultStatusMsgHook session cm@(UpToN {msgID=STATUSMESSAGE, msgBytes=msg}) = do
1524 let viewVar = ncView session
1525 atomically $ do
1526 view <- readTVar viewVar
1527 writeTVar (svTheirStatusMsg view) msg
1528 hookHelper True (Msg STATUSMESSAGE) session cm
1529
1530-- | updates ncLastNMsgs, and sends message to type-0 listeners
1531defaultUnRecHook :: MessageType -> NetCryptoHook
1532defaultUnRecHook typ session cm = do
1533 dput XNetCrypto $ "(NetCrypto) defaultUnRecHook: packet (sessionid: " ++ show (ncSessionId session) ++ ") " ++ show cm
1534 hookHelper False typ session cm
1535
1536hookHelper :: Bool -> MessageType -> NetCryptoHook
1537hookHelper _ typ session cm | any ($ typ) [isKillPacket, isOFFLINE] = do
1538 dput XNetCrypto $ "(hookHelper kill/offline) cm=" ++ show cm
1539 atomically $ do
1540 tmchans <- map snd . IntMap.elems <$> readTVar (ncListeners session)
1541 forM_ tmchans $ \chan -> closeTMChan chan
1542 return Nothing
1543
1544hookHelper handledFlg typ session cm = do
1545 dput XNetCrypto $ "(ENTER hookHelper) " ++ show cm
1546 addMsgToLastN handledFlg typ session (In cm)
1547 atomically $ do
1548 idtmchans <- IntMap.assocs <$> readTVar (ncListeners session)
1549 mbChans
1550 <- forM idtmchans $ \(id,(typ,chan)) -> do
1551 bClosed <- isClosedTMChan chan
1552 if bClosed
1553 then do
1554 modifyTVar' (ncListeners session) (IntMap.delete id)
1555 return Nothing
1556 else return (if typ==0 then Just chan else Nothing)
1557 forM_ (catMaybes mbChans) $ \chan -> do
1558 writeTMChan chan cm
1559 return Nothing
1560
1561addMsgToLastN :: Bool -> MessageType -> NetCryptoSession -> InOrOut CryptoMessage -> IO ()
1562addMsgToLastN handledFlg typ session cm = do
1563 let lastNQ = ncLastNMsgs session
1564 atomically $ do
1565 view <- readTVar (ncView session)
1566 snapshot <- viewSnapshot view
1567 num <- CB.getNextSequenceNum lastNQ
1568 CB.enqueue lastNQ num (handledFlg,(snapshot,cm))
1569
1570
1571-- | use to add a single hook to a specific session.
1572addCryptoDataHook1 :: Map.Map MessageType [NetCryptoHook] -> MessageType -> NetCryptoHook -> Map.Map MessageType [NetCryptoHook]
1573addCryptoDataHook1 mp typ hook = case Map.lookup typ mp of
1574 Nothing -> Map.insert typ [hook] mp
1575 Just hooks -> Map.insert typ (hook:hooks) mp
1576
diff --git a/stack.ghc-8.6.yaml b/stack.ghc-8.6.yaml
deleted file mode 100644
index 65555e0a..00000000
--- a/stack.ghc-8.6.yaml
+++ /dev/null
@@ -1,16 +0,0 @@
1resolver: nightly-2018-11-02
2allow-newer: true
3packages:
4- '.'
5- '../sensible-directory'
6- '../bencoding'
7- '../base32-bytestring'
8- '../dput-hslogger'
9flags: {}
10extra-package-dbs: []
11extra-deps:
12- rank2classes-1.1.0.1
13- cryptonite-0.23
14- reference-0.1
15- git: https://github.com/afcady/hs-avahi.git
16 commit: 5ec3bef32d40652b987b256eea8f85e7e8f2e5bb
diff --git a/stack.lts-10.yaml b/stack.lts-10.yaml
deleted file mode 100644
index e594e92f..00000000
--- a/stack.lts-10.yaml
+++ /dev/null
@@ -1,14 +0,0 @@
1resolver: lts-10.10
2packages:
3- '.'
4- '../sensible-directory'
5- '../bencoding'
6- '../base32-bytestring'
7- '../dput-hslogger'
8flags: {}
9extra-package-dbs: []
10extra-deps:
11- cryptonite-0.23
12- reference-0.1
13- git: https://github.com/afcady/hs-avahi.git
14 commit: 5ec3bef32d40652b987b256eea8f85e7e8f2e5bb
diff --git a/stack.lts-11.yaml b/stack.lts-11.yaml
deleted file mode 100644
index ddd94d8c..00000000
--- a/stack.lts-11.yaml
+++ /dev/null
@@ -1,14 +0,0 @@
1resolver: lts-11.14
2packages:
3- '.'
4- '../sensible-directory'
5- '../bencoding'
6- '../base32-bytestring'
7- '../dput-hslogger'
8flags: {}
9extra-package-dbs: []
10extra-deps:
11- cryptonite-0.23
12- reference-0.1
13- git: https://github.com/afcady/hs-avahi.git
14 commit: 5ec3bef32d40652b987b256eea8f85e7e8f2e5bb
diff --git a/stack.lts-12.yaml b/stack.lts-12.yaml
deleted file mode 100644
index c09a1d05..00000000
--- a/stack.lts-12.yaml
+++ /dev/null
@@ -1,14 +0,0 @@
1resolver: lts-12.16
2packages:
3- '.'
4- '../sensible-directory'
5- '../bencoding'
6- '../base32-bytestring'
7- '../dput-hslogger'
8flags: {}
9extra-package-dbs: []
10extra-deps:
11- cryptonite-0.23
12- reference-0.1
13- git: https://github.com/afcady/hs-avahi.git
14 commit: 5ec3bef32d40652b987b256eea8f85e7e8f2e5bb
diff --git a/stack.yaml b/stack.yaml
index 8f2034bc..0f966379 120000..100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1 +1,13 @@
1stack.lts-10.yaml \ No newline at end of file 1resolver: lts-13.26
2packages:
3- '.'
4- '../sensible-directory'
5- '../bencoding'
6- '../base32-bytestring'
7flags: {}
8extra-package-dbs: []
9extra-deps:
10- cryptonite-0.23
11- reference-0.1
12- git: https://github.com/afcady/hs-avahi.git
13 commit: 5ec3bef32d40652b987b256eea8f85e7e8f2e5bb
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 23:24:16 +0000