{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-} module Network.Tox.Crypto.Handlers where import Network.Tox.NodeId import Network.Tox.Crypto.Transport import Network.Tox.DHT.Transport (Cookie(..),CookieData(..), CookieRequest(..), NoSpam(..)) import Network.Tox.DHT.Handlers (Client, cookieRequest, createCookie ) import Crypto.Tox import Control.Concurrent.STM import Control.Concurrent.STM.TMChan import Network.Address import qualified Data.Map.Strict as Map import Crypto.Hash import Control.Applicative import Control.Monad import Data.Time.Clock.POSIX import qualified Data.ByteString as B import System.IO import Data.ByteString (ByteString) import Control.Lens import Data.Function import qualified Data.PacketQueue as PQ ;import Data.PacketQueue (PacketQueue) import qualified Data.CyclicBuffer as CB ;import Data.CyclicBuffer (CyclicBuffer) import Data.Serialize as S import Data.Word import Data.Maybe import qualified Data.Word64Map as W64 import Data.Word64RangeMap import qualified Data.Set as Set import qualified Data.Array.Unboxed as A import SensibleDir import System.FilePath import System.IO.Temp import System.Environment import System.Directory import System.Random -- for ping fuzz import Control.Concurrent import GHC.Conc (labelThread) import PingMachine import qualified Data.IntMap.Strict as IntMap import Control.Concurrent.Supply import Data.InOrOut import DPut import Debug.Trace import Text.Printf import Data.Bool import Connection (Status(..)) import Connection.Tox (ToxProgress(..)) -- * These types are isomorphic to Maybe, but have the advantage of documenting -- when an item is expected to become known. data UponDHTKey a = NeedDHTKey | HaveDHTKey a deriving (Functor,Show,Eq) data UponCookie a = NeedCookie | HaveCookie a deriving (Functor,Show,Eq) data UponHandshake a = NeedHandshake | HaveHandshake a deriving (Functor,Show,Eq) data UponCryptoPacket a = NeedCryptoPacket | HaveCryptoPacket a deriving (Functor,Show,Eq) -- util, todo: move to another module maybeToEither :: AsMaybe f => f b -> Either String b maybeToEither y | Just x <- toMaybe y = Right x maybeToEither _ = Left "maybeToEither" -- | type class encoding of isomorphism to Maybe class AsMaybe f where toMaybe :: f a -> Maybe a -- | The o in from is left out so as not to colide with 'Data.Maybe.fromMaybe' frmMaybe :: Maybe a -> f a instance AsMaybe Maybe where toMaybe x = x frmMaybe x = x instance AsMaybe UponDHTKey where toMaybe NeedDHTKey = Nothing toMaybe (HaveDHTKey x) = Just x frmMaybe Nothing = NeedDHTKey frmMaybe (Just x) = HaveDHTKey x instance AsMaybe UponCookie where toMaybe NeedCookie = Nothing toMaybe (HaveCookie x) = Just x frmMaybe Nothing = NeedCookie frmMaybe (Just x) = HaveCookie x instance AsMaybe UponHandshake where toMaybe NeedHandshake = Nothing toMaybe (HaveHandshake x) = Just x frmMaybe Nothing = NeedHandshake frmMaybe (Just x) = HaveHandshake x instance AsMaybe UponCryptoPacket where toMaybe NeedCryptoPacket = Nothing toMaybe (HaveCryptoPacket x) = Just x frmMaybe Nothing = NeedCryptoPacket frmMaybe (Just x) = HaveCryptoPacket x --data NetCryptoSessionStatus = Unaccepted | Accepted {- InProgress AwaitingSessionPacket -} | Confirmed {- Established -} -- deriving (Eq,Ord,Show,Enum) -- | The idea of IOHook is to replicate the familiar pattern -- where a function returns Nothing to consume a value -- or a function used to modify the value and pass it -- to be processed by another hook. type IOHook addr x = addr -> x -> IO (Maybe (x -> x)) -- | NetCryptoHook's use the Session as their 'addr' and the -- value they consume or modify is CryptoMessage. type NetCryptoHook = IOHook NetCryptoSession CryptoMessage -- | Convert an id byte to it's type (in Word64 format) -- Although the type doesn't enforce it, MsgTypeArray -- should always have 256 entries. type MsgTypeArray = A.UArray Word8 Word64 -- | Information, that may be made visible in multiple sessions, as well -- as displayed in some way to the user via mutiple views. -- data SessionView = SessionView { svNick :: TVar ByteString , svStatus :: TVar UserStatus , svStatusMsg :: TVar ByteString , svTyping :: TVar TypingStatus , svNoSpam :: TVar (Maybe NoSpam) , svTheirNick :: TVar ByteString , svTheirStatus :: TVar UserStatus , svTheirStatusMsg :: TVar ByteString , svTheirTyping :: TVar TypingStatus , svTheirNoSpam :: TVar (Maybe NoSpam) , svGroups :: TVar (Map.Map GroupChatId (Set.Set SockAddr)) -- allthough these directories are not visible to others on the net -- they are included in this type, because it facilitates organizing -- the disk according to your public image. , svCacheDir :: FilePath -- ^ directory path used if the session has -- to use the disk for cache clean up only -- if space is needed , svTmpDir :: FilePath -- ^ Once off storage goes here, should -- clean up quickly , svConfigDir :: FilePath -- ^ profile related storage, etc, never clean up , svDownloadDir :: TVar FilePath -- ^ where to put files the user downloads } -- | A static version of 'SessionView' -- useful for serializing to logs -- or storing in the ncLastNMsgs queue data ViewSnapshot = ViewSnapshot { vNick :: ByteString , vStatus :: UserStatus , vStatusMsg :: ByteString , vTyping :: TypingStatus , vNoSpam :: Maybe NoSpam , vTheirNick :: ByteString , vTheirStatus :: UserStatus , vTheirStatusMsg :: ByteString , vTheirTyping :: TypingStatus , vTheirNoSpam :: Maybe NoSpam , vGroups :: Map.Map GroupChatId (Set.Set SockAddr) } -- | Take snapshot of SessionView -- -- This is useful for storing the context of -- remembered messages. viewSnapshot :: SessionView -> STM ViewSnapshot viewSnapshot v = do nick <- readTVar (svNick v) status <- readTVar (svStatus v) statusMsg <- readTVar (svStatusMsg v) typing <- readTVar (svTyping v) noSpam <- readTVar (svNoSpam v) theirNick <- readTVar (svTheirNick v) theirStatus <- readTVar (svTheirStatus v) theirStatusMsg <- readTVar (svTheirStatusMsg v) theirTyping <- readTVar (svTheirTyping v) theirNoSpam <- readTVar (svTheirNoSpam v) groups <- readTVar (svGroups v) return ViewSnapshot { vNick = nick , vStatus = status , vStatusMsg = statusMsg , vTyping = typing , vNoSpam = noSpam , vTheirNick = theirNick , vTheirStatus = theirStatus , vTheirStatusMsg = theirStatusMsg , vTheirTyping = theirTyping , vTheirNoSpam = theirNoSpam , vGroups = groups } type SessionID = Word64 -- | Application specific listener type (Word64) -- -- This is some kind of information associated with a listening TChan. -- It may be used to indicate what kind of packets it is interested in. -- -- 0 means listen to all messages and is done automatically in 'defaultUnRecHook' -- any other values are left open to application specific convention. -- -- This module does not know what the different values here -- mean, but code that sets hooks may adhere to a convention -- defined elsewhere. -- type ListenerType = Word64 data NetCryptoSession = NCrypto { ncState :: TVar (Status ToxProgress) , ncMyPublicKey :: PublicKey , ncSessionId :: SessionID , ncTheirPublicKey :: PublicKey -- Tox id w/o nospam , ncTheirBaseNonce :: TVar (UponHandshake Nonce24) -- base nonce + packet number , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number , ncHandShake :: TVar (UponHandshake (Handshake Encrypted)) , ncCookie :: TVar (UponCookie Cookie) -- ^ Cookie issued by remote peer , ncTheirDHTKey :: UponDHTKey PublicKey , ncTheirSessionPublic :: TVar (UponHandshake PublicKey) , ncSessionSecret :: SecretKey , ncSockAddr :: UponDHTKey SockAddr -- The remaining fields correspond to implementation specific state -- -- where as the prior fields will be used in any implementation -- , ncHooks :: TVar (Map.Map MessageType [NetCryptoHook]) , ncUnrecognizedHook :: TVar (MessageType -> NetCryptoHook) , ncIncomingTypeArray :: TVar MsgTypeArray -- ^ This array maps 255 Id bytes to MessageType -- It should contain all messages this session understands. -- Use 0 for unsupported. It is used when a message comes -- in, and should ordinarily be the identity map. -- -- Id's 0xC7 and 0x63 should contain range-specifying types only, if -- such things come to be defined, because these MessageId's are -- always escapes. -- -- Currently, the values at these indices are ignored. , ncOutgoingIdMap :: RangeMap TArray Word8 TVar -- ^ used to lookup the outgoing id for a type when sending an outoing message , ncOutgoingIdMapEscapedLossy :: TVar (A.Array Word8 Word8) -- ^ mapping of secondary id, when primary id is 0xC7 -- (These Id's are called 'MessageName' in 'Network.Tox.Crypto.Transport') -- used when sending an outoing message , ncOutgoingIdMapEscapedLossless :: TVar (A.Array Word8 Word8) -- ^ mapping of secondary id, when primary id is 0x63 -- (These Id's are called 'MessageName' in 'Network.Tox.Crypto.Transport') -- used when sending an outoing message , ncAllSessions :: NetCryptoSessions -- ^ needed if one net-crypto session -- needs to possibly start another, as is -- the case in group chats , ncView :: TVar SessionView -- ^ contains your nick, status etc , ncPacketQueue :: PacketQueue CryptoData -- ^ a buffer in which incoming packets may be stored out of order -- but from which they may be extracted in sequence, -- helps ensure lossless packets are processed in order , ncDequeueThread :: Maybe ThreadId -- ^ when the thread which dequeues from ncPacketQueue -- is started, its ThreadId is stored here , ncPingMachine :: Maybe PingMachine -- ^ when the ping thread is started, store it here , ncOutgoingQueue :: UponHandshake (PQ.PacketOutQueue (State,Nonce24,RangeMap TArray Word8 TVar) CryptoMessage (CryptoPacket Encrypted) CryptoData) -- ^ To send a message add it to this queue, by calling 'tryAppendQueueOutgoing' -- but remember to call 'readyOutGoing' first, because the shared secret cache -- presently requires the IO monad. -- This specialized queue handles setting buffer_start and buffer_end and encrypting -- 'readyOutGoing' provides the first parameter to 'tryAppendQueueOutgoing' , ncLastNMsgs :: CyclicBuffer (Bool{-Handled?-},(ViewSnapshot,InOrOut CryptoMessage)) -- ^ cyclic buffer, holds the last N non-handshake crypto messages -- even if there is no attached user interface. , ncListeners :: TVar (IntMap.IntMap (ListenerType,TMChan CryptoMessage)) -- ^ user interfaces may "listen" by inserting themselves into this map -- with a unique id and a new TChan, and then reading from the TChan } data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession) , netCryptoSessionsByKey :: TVar (Map.Map PublicKey [NetCryptoSession]) , transportCrypto :: TransportCrypto , defaultHooks :: Map.Map MessageType [NetCryptoHook] , defaultUnrecognizedHook :: MessageType -> NetCryptoHook , sessionView :: SessionView , msgTypeArray :: MsgTypeArray , inboundQueueCapacity :: Word32 , outboundQueueCapacity :: Word32 , nextSessionId :: TVar SessionID , announceNewSessionHooks :: TVar [IOHook (Maybe NoSpam) NetCryptoSession] , sendHandshake :: SockAddr -> Handshake Encrypted -> IO () , sendSessionPacket :: SockAddr -> CryptoPacket Encrypted -> IO () , listenerIDSupply :: TVar Supply } -- | This is the type of a hook to run when a session is created. type NewSessionHook = IOHook (Maybe NoSpam) NetCryptoSession addNewSessionHook :: NetCryptoSessions -> NewSessionHook -> STM () addNewSessionHook allsessions@(NCSessions { announceNewSessionHooks }) hook = modifyTVar announceNewSessionHooks (hook:) forgetCrypto :: TransportCrypto -> NetCryptoSessions -> NetCryptoSession -> STM () forgetCrypto crypto (NCSessions {netCryptoSessions,netCryptoSessionsByKey}) session = do let HaveDHTKey addr = ncSockAddr session sid = ncSessionId session sPubKey = ncTheirPublicKey session byAddrMap <- readTVar netCryptoSessions {- byKeyMap <- readTVar netCryptoSessionsByKey -} case Map.lookup addr byAddrMap of Nothing -> return () -- already gone Just _ -> do modifyTVar netCryptoSessions (Map.delete addr) modifyTVar netCryptoSessionsByKey (Map.update (\xs -> case filter (\x -> ncSessionId x /= sid) xs of [] -> Nothing ys -> Just ys) sPubKey) newSessionsState :: TransportCrypto -> (MessageType -> NetCryptoHook) -- ^ default hook -> Map.Map MessageType [NetCryptoHook] -- ^ all hooks, can be empty to start -> IO NetCryptoSessions newSessionsState crypto unrechook hooks = do x <- atomically $ newTVar Map.empty x2 <- atomically $ newTVar Map.empty nick <- atomically $ newTVar B.empty status <- atomically $ newTVar Online statusmsg <- atomically $ newTVar B.empty typing <- atomically $ newTVar NotTyping nospam <- atomically $ newTVar Nothing theirnick <- atomically $ newTVar B.empty theirstatus <- atomically $ newTVar Online theirstatusmsg <- atomically $ newTVar B.empty theirtyping <- atomically $ newTVar NotTyping theirnospam <- atomically $ newTVar Nothing grps <- atomically $ newTVar Map.empty pname <- getProgName cachedir <- sensibleCacheDirCreateIfMissing pname tmpdir <- ( pname) <$> (getTemporaryDirectory >>= canonicalizePath) -- getCanonicalTemporaryDirectory configdir <- sensibleVarLib pname homedir <- getHomeDirectory svDownloadDir0 <- atomically $ newTVar (homedir "Downloads") nextSessionId0 <- atomically $ newTVar 0 announceNewSessionHooks0 <- atomically $ newTVar [] lsupply <- newSupply lsupplyVar <- atomically (newTVar lsupply) return NCSessions { netCryptoSessions = x , netCryptoSessionsByKey = x2 , transportCrypto = crypto , defaultHooks = hooks , defaultUnrecognizedHook = unrechook , sessionView = SessionView { svNick = nick , svStatus = status , svStatusMsg = statusmsg , svTyping = typing , svNoSpam = nospam , svTheirNick = theirnick , svTheirStatus = theirstatus , svTheirStatusMsg = theirstatusmsg , svTheirTyping = theirtyping , svTheirNoSpam = theirnospam , svGroups = grps , svCacheDir = cachedir , svTmpDir = tmpdir , svConfigDir = configdir , svDownloadDir = svDownloadDir0 } , msgTypeArray = allMsgTypes id -- todo make this a parameter , inboundQueueCapacity = 200 , outboundQueueCapacity = 400 , nextSessionId = nextSessionId0 , announceNewSessionHooks = announceNewSessionHooks0 , sendHandshake = error "Need to set sendHandshake field of NetCryptoSessions!" , sendSessionPacket = error "Need to set sendSessionPacket field of NetCryptoSessions!" , listenerIDSupply = lsupplyVar } data HandshakeParams = HParam { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own , hpOtherCookie :: Cookie , hpTheirSessionKeyPublic :: Maybe PublicKey , hpMySecretKey :: SecretKey , hpCookieRemotePubkey :: PublicKey , hpCookieRemoteDhtkey :: PublicKey } newHandShakeData :: TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> IO (Maybe HandshakeData) newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr = do freshCookie <- case nodeInfo (key2id hpCookieRemoteDhtkey) addr of Right nodeinfo -> Just <$> createCookie crypto nodeinfo hpCookieRemotePubkey Left er -> return Nothing let hinit = hashInit Cookie n24 encrypted = hpOtherCookie hctx = hashUpdate hinit n24 hctx' = hashUpdate hctx encrypted digest = hashFinalize hctx' -- parameters addr {--> SockAddr -} -- mbcookie <- case hpOtherCookie of -- Nothing -> case (nodeInfo hpCookieRemoteDhtkey addr) of -- Right nodeinfo -> cookieRequest crypto netCryptoDHTClient (toPublic hpMySecretKey) nodeinfo -- Left er -> return Nothing -- Just c -> return (Just c) return $ fmap (\freshCookie' -> HandshakeData { baseNonce = basenonce , sessionKey = toPublic hpMySecretKey , cookieHash = digest , otherCookie = freshCookie' }) freshCookie type XMessage = CryptoMessage -- todo -- THIS Would work if not for the IO shared secret cache... -- increments packet nonce, only call when actually queuing an outgoing packet -- getOutGoingParam crypto session = do -- n24 <- (ncMyPacketNonce session) -- let state = computeSharedSecret (transportSecret crypto) (ncTheirPublicKey session) n24 -- modifyTVar (ncMyPacketNonce session) (+1) -- rangemap <- readTVar (ncOutgoingIdMap session) -- return (state,n24,rangemap) ncToWire :: STM (State,Nonce24,RangeMap TArray Word8 TVar) -> Word32{- packet number we expect to recieve -} -> Word32{- buffer_end -} -> Word32{- packet number -} -> XMessage -> STM (Maybe (CryptoPacket Encrypted,Word32{-next packet no-})) ncToWire getState seqno bufend pktno msg = do let typ = getMessageType msg typ64 = toWord64 typ let lsness msg = case typ of Msg mid -> lossyness mid GrpMsg KnownLossy _ -> Lossy GrpMsg KnownLossless _ -> Lossless (state,n24,msgOutMapVar) <- getState -- msgOutMap <- readTVar msgOutMapVar result1 <- trace ("lookupInRangeMap typ64=" ++ show typ64) $ lookupInRangeMap typ64 msgOutMapVar case result1 of -- msgOutMapLookup typ64 msgOutMap of Nothing -> trace "lookupInRangeMap gave Nothing!" $ return Nothing Just outid -> trace ("encrypting packet with Nonce: " ++ show n24) $ do let setMessageId (OneByte _) mid = OneByte (toEnum8 mid) setMessageId (TwoByte _ x) mid = TwoByte (toEnum8 mid) x setMessageId (UpToN _ x) mid = UpToN (toEnum8 mid) x msg' = setMessageId msg outid in case lsness msg of UnknownLossyness -> return Nothing Lossy -> let cd = CryptoData { bufferStart = seqno , bufferEnd = bufend , bufferData = msg' } plain = encodePlain cd encrypted = encrypt state plain pkt = CryptoPacket { pktNonce = let r = nonce24ToWord16 n24 in trace (printf "converting n24 to word16: 0x%x" r) r , pktData = encrypted } in return (Just (pkt, pktno)) Lossless -> let cd = CryptoData { bufferStart = seqno , bufferEnd = pktno , bufferData = msg' } plain = encodePlain cd encrypted = encrypt state plain pkt = CryptoPacket { pktNonce = nonce24ToWord16 n24, pktData = encrypted } in return (Just (pkt, pktno+1)) -- | called when we recieve a crypto handshake with valid cookie -- TODO set priority on contact addr to 0 if it is older than ForgetPeriod, -- then increment it regardless. (Keep addr in MinMaxPSQ in Roster.Contact) -- -- This function sends a handshake response packet. freshCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> IO () freshCryptoSession sessions addr hp@(HParam { hpTheirBaseNonce = mbtheirBaseNonce , hpOtherCookie = otherCookie , hpTheirSessionKeyPublic = mbtheirSessionKey , hpMySecretKey = key , hpCookieRemotePubkey = remotePublicKey , hpCookieRemoteDhtkey = remoteDhtPublicKey }) = do let crypto = transportCrypto sessions allsessions = netCryptoSessions sessions allsessionsByKey = netCryptoSessionsByKey sessions sessionId <- atomically $ do x <- readTVar (nextSessionId sessions) modifyTVar (nextSessionId sessions) (+1) return x -- ncState0 <- atomically $ newTVar Accepted -- (InProgress AwaitingSessionPacket) ncState0 <- atomically $ newTVar (if isJust mbtheirBaseNonce then InProgress AwaitingSessionPacket else InProgress AwaitingHandshake) ncTheirBaseNonce0 <- atomically $ newTVar (frmMaybe mbtheirBaseNonce) n24 <- atomically $ transportNewNonce crypto state <- lookupSharedSecret crypto key remotePublicKey n24 newBaseNonce <- atomically $ transportNewNonce crypto mbMyhandshakeData <- newHandShakeData crypto newBaseNonce hp addr let encodeHandshake myhandshakeData = let plain = encodePlain myhandshakeData -- state = computeSharedSecret key remoteDhtPublicKey n24 encrypted = encrypt state plain in Handshake { handshakeCookie = otherCookie , handshakeNonce = n24 , handshakeData = encrypted } let myhandshake= encodeHandshake <$> mbMyhandshakeData ncHandShake0 <- atomically $ newTVar (frmMaybe myhandshake) forM myhandshake $ \response_handshake -> do sendHandshake sessions addr response_handshake ncMyPacketNonce0 <- atomically $ newTVar newBaseNonce cookie0 <- atomically $ newTVar (HaveCookie otherCookie) newsession <- generateSecretKey ncHooks0 <- atomically $ newTVar (defaultHooks sessions) ncUnrecognizedHook0 <- atomically $ newTVar (defaultUnrecognizedHook sessions) ncIncomingTypeArray0 <- atomically $ newTVar (msgTypeArray sessions) let idMap = foldl (\mp (x,y) -> W64.insert x y mp) W64.empty (zip [0..255] [0..255]) (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap) <- atomically $ do idmap <- emptySTMRangeMap insertArrayAt idmap 0 (A.listArray (0,255) [0 .. 255]) -- the 2 escape ranges are adjacent, so put them in one array: insertArrayAt idmap 512 (A.listArray (512,1023) ( replicate 256 0xC7 -- lossy escaped ++ replicate 256 0x63 -- lossless escapped )) -- lossless as separate range could have been done: -- > insertArrayAt idmap 768 (A.listArray (768,1023) (replicate 256 0x63)) lossyEsc <- newTVar $ A.listArray (0,255) [0 .. 255] losslessEsc <- newTVar $ A.listArray (0,255) [0 .. 255] return (idmap,lossyEsc,losslessEsc) ncView0 <- atomically $ newTVar (sessionView sessions) pktq <- atomically $ PQ.new (inboundQueueCapacity sessions) 0 bufstart <- atomically $ newTVar 0 mbpktoq <- case mbtheirSessionKey of Nothing -> return NeedHandshake Just theirSessionKey -> createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 lastNQ <- atomically (CB.new 10 0 :: STM (CyclicBuffer (Bool,(ViewSnapshot,InOrOut CryptoMessage)))) listeners <- atomically $ newTVar IntMap.empty msgNum <- atomically $ newTVar 0 dropNum <- atomically $ newTVar 0 theirbasenonce <- atomically $ readTVar ncTheirBaseNonce0 dput XNetCrypto $ "freshCryptoSession: Session ncTheirBaseNonce=" ++ show theirbasenonce ncTheirSessionPublic0 <- atomically $ newTVar (frmMaybe mbtheirSessionKey) let netCryptoSession0 = NCrypto { ncState = ncState0 , ncMyPublicKey = toPublic key , ncSessionId = sessionId , ncTheirPublicKey = remotePublicKey , ncTheirBaseNonce = ncTheirBaseNonce0 , ncMyPacketNonce = ncMyPacketNonce0 , ncHandShake = ncHandShake0 , ncCookie = cookie0 , ncTheirDHTKey = HaveDHTKey remoteDhtPublicKey , ncTheirSessionPublic = ncTheirSessionPublic0 , ncSessionSecret = newsession , ncSockAddr = HaveDHTKey addr , ncHooks = ncHooks0 , ncUnrecognizedHook = ncUnrecognizedHook0 , ncAllSessions = sessions , ncIncomingTypeArray = ncIncomingTypeArray0 , ncOutgoingIdMap = ncOutgoingIdMap0 , ncOutgoingIdMapEscapedLossy = lossyEscapeIdMap , ncOutgoingIdMapEscapedLossless = losslessEscapeIdMap , ncView = ncView0 , ncPacketQueue = pktq , ncDequeueThread = Nothing -- error "you want the NetCrypto-Dequeue thread id, but is it started?" , ncPingMachine = Nothing -- error "you want the NetCrypto-PingMachine, but is it started?" , ncOutgoingQueue = mbpktoq , ncLastNMsgs = lastNQ , ncListeners = listeners } case mbpktoq of NeedHandshake -> return () HaveHandshake pktoq -> runUponHandshake netCryptoSession0 addr pktoq type NetCryptoOutQueue = PQ.PacketOutQueue (State,Nonce24,RangeMap TArray Word8 TVar) CryptoMessage (CryptoPacket Encrypted) CryptoData createNetCryptoOutQueue :: NetCryptoSessions -> SecretKey -> PublicKey -> PacketQueue CryptoData -> TVar Nonce24 -> RangeMap TArray Word8 TVar -> IO (UponHandshake NetCryptoOutQueue) createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 = do let crypto = transportCrypto sessions let toWireIO = do f <- lookupNonceFunction crypto newsession theirSessionKey atomically $ do n24 <- readTVar ncMyPacketNonce0 let n24plus1 = incrementNonce24 n24 trace ("ncMyPacketNonce+1=" ++ show n24plus1) $ writeTVar ncMyPacketNonce0 n24plus1 return (return (f n24, n24, ncOutgoingIdMap0)) pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0 return (HaveHandshake pktoq) runUponHandshake :: NetCryptoSession -> SockAddr -> NetCryptoOutQueue -> IO () runUponHandshake netCryptoSession0 addr pktoq = do let sessions = ncAllSessions netCryptoSession0 pktq = ncPacketQueue netCryptoSession0 remotePublicKey = ncTheirPublicKey netCryptoSession0 crypto = transportCrypto sessions allsessions = netCryptoSessions sessions allsessionsByKey = netCryptoSessionsByKey sessions -- launch dequeue thread -- (In terms of data dependency, this thread could be launched prior to handshake) threadid <- forkIO $ do tid <- myThreadId labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey)) fix $ \loop -> do cd <- atomically $ PQ.dequeue pktq _ <- runCryptoHook (netCryptoSession0 {ncDequeueThread=Just tid}) (bufferData cd) loop -- launch dequeueOutgoing thread threadidOutgoing <- forkIO $ do tid <- myThreadId labelThread tid ("NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey)) fix $ \loop -> do (_,pkt) <- atomically $ PQ.dequeueOutgoing pktoq dput XNetCrypto "NetCryptoDequeueOutgoing thread... Sending encrypted Packet" sendSessionPacket sessions addr pkt loop -- launch ping thread fuzz <- randomRIO (0,2000) pingMachine <- forkPingMachine ("NetCrypto." ++ show (key2id remotePublicKey)) (15000 + fuzz) 2000 -- update session with thread ids let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid, ncPingMachine=Just pingMachine} -- add this session to the lookup maps atomically $ do modifyTVar allsessions (Map.insert addr netCryptoSession) byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey case byKeyResult of Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession]) Just xs -> modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs)) -- run announceNewSessionHooks hooks <- atomically $ readTVar (announceNewSessionHooks sessions) flip fix (hooks,netCryptoSession) $ \loop (hooks,session) -> case hooks of [] -> return () (h:hs) -> do r <- h Nothing session case r of Just f -> loop (hs, f session) Nothing -> return () -- | Called when we get a handshake, but there's already a session entry. updateCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> NetCryptoSession -> Handshake Encrypted -> IO () updateCryptoSession sessions addr hp session handshake = do ncState0 <- atomically $ readTVar (ncState session) ncTheirBaseNonce0 <- atomically $ readTVar (ncTheirBaseNonce session) if (ncState0 >= {-Accepted-}InProgress AwaitingSessionPacket) -- If the nonce in the handshake and the dht key are both the same as -- the ones we have saved, assume we already handled this and this is a -- duplicate handshake packet, otherwise disregard everything, and -- refresh all state. -- then do dput XNetCrypto "updateCryptoSession already accepted.." dput XNetCrypto (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0 ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp) ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp)) dput XNetCrypto (" ncTheirDHTKey=" ++ show (ncTheirDHTKey session) ++ bool "{/=}" "{==}" (ncTheirDHTKey session == HaveDHTKey (hpCookieRemoteDhtkey hp)) ++ "hpCookieRemoteDhtkey=" ++ show (hpCookieRemoteDhtkey hp)) if ( -- Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp -- XXX: Do we really want to compare base nonce here? -- || ncTheirDHTKey session /= HaveDHTKey (hpCookieRemoteDhtkey hp) ) then freshCryptoSession sessions addr hp else do atomically $ do writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp)) writeTVar (ncTheirSessionPublic session) (frmMaybe (hpTheirSessionKeyPublic hp)) writeTVar (ncHandShake session) (HaveHandshake handshake) case ncOutgoingQueue session of NeedHandshake -> do case hpTheirSessionKeyPublic hp of Just sessionpubkey -> do pktoq <- createNetCryptoOutQueue sessions (ncSessionSecret session) sessionpubkey (ncPacketQueue session) (ncMyPacketNonce session) (ncOutgoingIdMap session) case pktoq of NeedHandshake -> dput XNetCrypto "Unexpectedly missing ncOutgoingQueue" HaveHandshake pktoq -> runUponHandshake session addr pktoq HaveHandshake pktoq -> runUponHandshake session addr pktoq else do dput XNetCrypto "updateCryptoSession else clause" dput XNetCrypto (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0 ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp) ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp)) if ( ncTheirBaseNonce0 /= frmMaybe (hpTheirBaseNonce hp)) then freshCryptoSession sessions addr hp -- basenonce mismatch, trigger refresh else atomically $ writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket) anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1) anyRight e [] f = return $ Left e anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right) handshakeH :: NetCryptoSessions -> SockAddr -> Handshake Encrypted -> IO (Maybe a) handshakeH sessions addr hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do dput XNetCrypto ("RECIEVED HANDSHAKE from " ++ show addr) -- Handle Handshake Message let crypto = transportCrypto sessions :: TransportCrypto allsessions = netCryptoSessions sessions :: TVar (Map.Map SockAddr NetCryptoSession) seckeys <- map fst <$> atomically (userKeys crypto) dput XNetCrypto "trying the following keys:" forM_ seckeys $ \k -> dput XNetCrypto $ " " ++ show (key2id . toPublic $ k) symkey <- atomically $ transportSymmetric crypto now <- getPOSIXTime dput XNetCrypto ("Decrypt cookie with n24=" ++ show n24 ++ "\n symkey= " ++ show symkey) lr <- fmap join . sequence $ do -- Either Monad CookieData cookieTime remotePubkey remoteDhtkey <- decodePlain =<< decryptSymmetric symkey n24 ecookie Right $ do -- IO Monad decrypted <- anyRight "missing key" seckeys $ \key -> do dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey = " ++ show (key2id $ remotePubkey) dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 = " ++ show nonce24 secret <- lookupSharedSecret crypto key remotePubkey nonce24 let step1 = decrypt secret encrypted case step1 of Left s -> do dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s return (Left s) Right pln -> do case decodePlain pln of Left s -> do dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s return (Left s) Right x -> return (Right (key,x)) return $ do -- Either Monad (key,HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted -- check cookie time < 15 seconds ago guard (now - fromIntegral cookieTime < 15) -- cookie hash is valid? sha512 of ecookie let hinit = hashInit hctx = hashUpdate hinit n24 hctx' = hashUpdate hctx ecookie digest = hashFinalize hctx' guard (cookieHash == digest) -- known friend? -- todo TODO, see Roster.hs, -- talk to not yet existent Network-Manager to ascertain current permissions return HParam { hpTheirBaseNonce = Just baseNonce , hpOtherCookie = otherCookie , hpTheirSessionKeyPublic = Just sessionKey , hpMySecretKey = key , hpCookieRemotePubkey = remotePubkey , hpCookieRemoteDhtkey = remoteDhtkey } case lr of Left s -> dput XNetCrypto ("(NetCrypto)handshakeH: " ++ s) Right hp@(HParam { hpTheirBaseNonce = Just theirBaseNonce , hpOtherCookie = otherCookie , hpTheirSessionKeyPublic = theirSessionKey , hpMySecretKey = key , hpCookieRemotePubkey = remotePublicKey , hpCookieRemoteDhtkey = remoteDhtPublicKey }) -> do dput XNetCrypto ("(NetCrypto)handshakeH: hpTheirBaseNonce = " ++ show theirBaseNonce) sessionsmap <- atomically $ readTVar allsessions -- Do a lookup, so we can handle the update case differently case Map.lookup addr sessionsmap of Nothing -> do dput XNetCrypto "sockaddr not in session map, so freshCryptoSession" freshCryptoSession sessions addr hp -- create new session Just session -> do dput XNetCrypto "sockaddr ALREADY in session map, so updateCryptoSession" updateCryptoSession sessions addr hp session hshake -- update existing session return Nothing sessionPacketH :: NetCryptoSessions -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (x -> x)) sessionPacketH sessions addr (CryptoPacket nonce16 encrypted) = do dput XNetCrypto ("RECIEVED CRYPTOPACKET from " ++ show addr) let crypto = transportCrypto sessions allsessions = netCryptoSessions sessions sessionsmap <- atomically $ readTVar allsessions -- Handle Encrypted Message case Map.lookup addr sessionsmap of Nothing -> do dput XNetCrypto "Dropping packet.. no session" return Nothing -- drop packet, we have no session Just session@(NCrypto { ncIncomingTypeArray, ncState, ncPacketQueue, ncHooks, ncSessionSecret, ncTheirSessionPublic, ncTheirBaseNonce, ncPingMachine}) -> do mbTheirBaseNonce <- atomically $ readTVar ncTheirBaseNonce case mbTheirBaseNonce of NeedHandshake -> dput XNetCrypto "CryptoPacket recieved, but we still dont have their base nonce?" >> return Nothing HaveHandshake theirBaseNonce -> do -- Try to decrypt message let diff :: Word16 diff = nonce16 - (last2Bytes theirBaseNonce) -- truncating to Word16 tempNonce = addtoNonce24 theirBaseNonce (fromIntegral diff) -- expanding to Word mbpublickey <- atomically (readTVar ncTheirSessionPublic) lr <- fmap join $ sequence $ do -- Either Monad -- pubkey <- maybeToEither mbpublickey Right $ do -- IO Monad dput XNetCrypto $ "(NetCrypto)sessionPacketH: pubkey = " ++ show (key2id $ pubkey) dput XNetCrypto $ "(NetCrypto)sessionPacketH: theirBaseNonce = " ++ show theirBaseNonce dput XNetCrypto $ "(NetCrypto)sessionPacketH: tempNonce = " ++ show tempNonce ++ " nonce16=" ++ printf "0x%x" nonce16 ++ " last2bytes =" ++ printf "0x%x" (last2Bytes theirBaseNonce) secret <- lookupSharedSecret crypto ncSessionSecret pubkey tempNonce let step1 = decrypt secret encrypted case step1 of Left s -> do dput XNetCrypto $ "(NetCrypto)sessionPacketH: (decrypt) " ++ s return (Left s) Right pln -> do case decodePlain pln of Left s -> do dput XNetCrypto $ "(NetCrypto)sessionPacketH: (decodePlain) " ++ s return (Left s) Right x -> return (Right x) case lr of Left s -> do dput XNetCrypto $ "(NetCrypto)sessionPacketH: " ++ s return Nothing -- decryption failed, ignore packet Right cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm}) -> do -- decryption succeeded, -- TODO: Why do I need bufferStart & bufferEnd? -- -- buffer_start = highest packet number handled + 1 -- , recvbuffers buffer_start -- -- bufferEnd = sendbuffer buffer_end if lossy, otherwise packet number -- update ncTheirBaseNonce if necessary when (diff > 2 * dATA_NUM_THRESHOLD)$ atomically $ do HaveHandshake y <- readTVar ncTheirBaseNonce let x = addtoNonce24 y (fromIntegral dATA_NUM_THRESHOLD) trace ("nonce y(" ++ show y ++ ") + " ++ show (fromIntegral dATA_NUM_THRESHOLD) ++ " = " ++ show x) (return ()) writeTVar ncTheirBaseNonce (HaveHandshake y) -- then set session confirmed, atomically $ writeTVar ncState {-Confirmed-}Established -- bump ping machine case ncPingMachine of Just pingMachine -> pingBump pingMachine Nothing -> return () msgTypes <- atomically $ readTVar ncIncomingTypeArray let msgTyp = cd ^. messageType msgTypMapped64 = msgTypes A.! fromEnum8 (msgID cm) msgTypMapped = fromWord64 $ msgTypMapped64 isLossy (GrpMsg KnownLossy _) = True isLossy (Msg mid) | lossyness mid == Lossy = True isLossy _ = False if isLossy msgTypMapped then do dput XNetCrypto "enqueue ncPacketQueue Lossy" atomically $ PQ.observeOutOfBand ncPacketQueue bufferEnd runCryptoHook session (bufferData cd) else do dput XNetCrypto "enqueue ncPacketQueue Lossless" atomically $ PQ.enqueue ncPacketQueue bufferEnd cd return Nothing where last2Bytes :: Nonce24 -> Word16 last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of Right n -> n -- trace ("byteSwap16 " ++ printf "0x%x" n ++ " = " ++ printf "0x%x" (byteSwap16 n)) $ byteSwap16 n _ -> error "unreachable-last2Bytes" dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3 runCryptoHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (x -> x)) runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce,ncIncomingTypeArray}) cm {-cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm})-} = do hookmap <- atomically $ readTVar ncHooks -- run hook flip fix (cm,hookmap) $ \lookupAgain (cm,hookmap) -> do msgTypes <- atomically $ readTVar ncIncomingTypeArray let msgTyp = cm ^. messageType msgTypMapped64 = msgTypes A.! fromEnum8 (msgID cm) msgTypMapped = fromWord64 $ msgTypMapped64 if msgTypMapped64 == 0 then return Nothing else case Map.lookup msgTypMapped hookmap of Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result unrecognize <- atomically $ readTVar (ncUnrecognizedHook session) mbConsume <- unrecognize msgTypMapped session cm case mbConsume of Just f -> do -- ncUnrecognizedHook0 may have updated the hookmap hookmap' <- atomically $ readTVar ncHooks lookupAgain (f cm,hookmap') Nothing -> return Nothing Just hooks -> flip fix (hooks,cm,msgTypMapped) $ \loop (hooks,cm,typ) -> do let _ = cm :: CryptoMessage case (hooks,cm) of ([],_) -> return Nothing (hook:more,cd) -> do r <- hook session cm :: IO (Maybe (CryptoMessage -> CryptoMessage)) case r of Just f -> let newcd = f cd newtyp = newcd ^. messageType in if newtyp == typ then loop (more,newcd,newtyp) else lookupAgain (newcd,hookmap) Nothing -> return Nothing -- message consumed -- | construct a 'MsgTypeArray' for specified types, using their known common positions -- in the MessageId space if they have such a thing. mkMsgTypes :: [MessageType] -> MsgTypeArray mkMsgTypes msgs = let zeros = A.listArray (0,255) (replicate 256 0) in zeros A.// map (\x -> (toIndex x,toWord64 x)) msgs where toIndex (Msg mid) = fromIntegral . fromEnum $ mid toIndex (GrpMsg KnownLossless nam) = 0x63 -- fromEnum MESSAGE_GROUPCHAT toIndex (GrpMsg KnownLossy nam) = 0xC7 -- fromEnum LOSSY_GROUPCHAT -- | Handle all Tox messages that this code base is aware of. -- The first parameter is a function which is applied to get the values -- for keys of unknown nature. Could be either 'id' or 'const 0' allMsgTypes :: (Word64 -> Word64) -> MsgTypeArray allMsgTypes fDefault = A.listArray (minBound,maxBound) (0:knownMsgs) where knownMsgs :: [Word64] knownMsgs = concat [ map (fromIntegral . fromEnum) [ PacketRequest .. KillPacket ] , map (const 0) [ 3 .. 15 ] -- UnspecifiedPacket , map (const 0) [ 16 .. 23 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ ONLINE .. OFFLINE ] , map (const 0) [ 26 .. 47 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ NICKNAME .. TYPING ] , map (const 0) [ 52 .. 63 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ MESSAGE .. ACTION ] , map (const 0) [ 66 .. 68 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ MSI ] , map (const 0) [ 70 .. 79 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ FILE_SENDREQUEST .. FILE_DATA ] , map (const 0) [ 83 .. 95 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ INVITE_GROUPCHAT .. MESSAGE_GROUPCHAT ] , map (const 0) [ 100 .. 191 ] -- MessengerLoseless , map (const 0) [ 192 .. 198 ] -- MessengerLossy , map (fromIntegral . fromEnum) [ LOSSY_GROUPCHAT ] , map (const 0) [ 200 .. 255 ] -- All lossy, exept the last ] sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String ()) sendCrypto crypto session updateLocal cm = do let HaveHandshake outq = ncOutgoingQueue session -- XXX: potential race? if shared secret comes out of sync with cache? dput XNetCrypto "sendCrypto: enter " getOutGoingParam <- PQ.readyOutGoing outq dput XNetCrypto "sendCrypto: got the io extra stuff" atomically $ do result <- PQ.tryAppendQueueOutgoing getOutGoingParam outq cm case result of PQ.OGSuccess -> updateLocal >> return (Right()) PQ.OGFull -> return (Left "Outgoing packet buffer is full") PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet") sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) sendOnline crypto session = sendCrypto crypto session (return ()) (OneByte ONLINE) sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) sendOffline crypto session = sendCrypto crypto session (return ()) (OneByte OFFLINE) sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) sendKill crypto session = do let cm=OneByte KillPacket addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session (return ()) cm setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) setNick crypto session nick = do let Just (_,maxlen) = msgSizeParam NICKNAME if B.length nick > maxlen then return (Left $ "nickname must not exceed " ++ show maxlen ++ " bytes.") else do let updateLocal = do let viewVar = ncView session view <- readTVar viewVar writeTVar (svNick view) nick let cm = UpToN NICKNAME nick addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session updateLocal cm setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String ()) setTyping crypto session status = do let updateLocal = do view <- readTVar (ncView session) writeTVar (svTyping view) status let cm = TwoByte TYPING (fromEnum8 status) addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session updateLocal cm setNoSpam :: TransportCrypto -> NetCryptoSession -> Maybe NoSpam -> IO (Either String ()) setNoSpam crypto session mbnospam = do let viewVar = ncView session atomically $ do view <- readTVar viewVar writeTVar (svNoSpam view) mbnospam return (Right ()) setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String ()) setStatus crypto session status = do let updateLocal = do view <- readTVar (ncView session) writeTVar (svStatus view) status let cm = TwoByte USERSTATUS (fromEnum8 status) addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session updateLocal cm setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) setStatusMsg crypto session msg = do let Just (_,maxlen) = msgSizeParam STATUSMESSAGE if B.length msg > maxlen then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.") else do let updateLocal = do view <- readTVar (ncView session) writeTVar (svStatusMsg view) msg let cm = UpToN STATUSMESSAGE msg addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session updateLocal cm sendChatMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) sendChatMsg crypto session msg = do let Just (_,maxlen) = msgSizeParam MESSAGE if B.length msg > maxlen then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.") else do let updateLocal = do view <- readTVar (ncView session) writeTVar (svStatusMsg view) msg let cm = UpToN MESSAGE msg addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session updateLocal cm -- | handles nothings defaultCryptoDataHooks :: Map.Map MessageType [NetCryptoHook] defaultCryptoDataHooks = Map.fromList [ (Msg USERSTATUS,[defaultUserStatusHook]) , (Msg TYPING,[defaultTypingHook]) , (Msg NICKNAME, [defaultNicknameHook]) , (Msg STATUSMESSAGE, [defaultStatusMsgHook]) ] defaultUserStatusHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage)) defaultUserStatusHook session cm@(TwoByte {msgID=USERSTATUS, msgByte=statusByte}) = do let status = toEnum8 statusByte viewVar = ncView session atomically $ do view <- readTVar viewVar writeTVar (svTheirStatus view) status hookHelper True (Msg USERSTATUS) session cm defaultTypingHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage)) defaultTypingHook session cm@(TwoByte {msgID=TYPING, msgByte=statusByte}) = do let status = toEnum8 statusByte viewVar = ncView session atomically $ do view <- readTVar viewVar writeTVar (svTheirStatus view) status hookHelper True (Msg TYPING) session cm defaultNicknameHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage)) defaultNicknameHook session cm@(UpToN {msgID=NICKNAME, msgBytes=nick}) = do let viewVar = ncView session atomically $ do view <- readTVar viewVar writeTVar (svTheirNick view) nick hookHelper True (Msg NICKNAME) session cm defaultStatusMsgHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage)) defaultStatusMsgHook session cm@(UpToN {msgID=STATUSMESSAGE, msgBytes=msg}) = do let viewVar = ncView session atomically $ do view <- readTVar viewVar writeTVar (svTheirStatusMsg view) msg hookHelper True (Msg STATUSMESSAGE) session cm -- | updates ncLastNMsgs, and sends message to type-0 listeners defaultUnRecHook :: MessageType -> NetCryptoHook defaultUnRecHook = hookHelper False hookHelper :: Bool -> MessageType -> NetCryptoHook hookHelper _ typ session cm | any ($ typ) [isKillPacket, isOFFLINE] = atomically $ do tmchans <- map snd . IntMap.elems <$> readTVar (ncListeners session) forM_ tmchans $ \chan -> closeTMChan chan return Nothing hookHelper handledFlg typ session cm = do addMsgToLastN handledFlg typ session (In cm) atomically $ do idtmchans <- IntMap.assocs <$> readTVar (ncListeners session) mbChans <- forM idtmchans $ \(id,(typ,chan)) -> do bClosed <- isClosedTMChan chan if bClosed then do modifyTVar' (ncListeners session) (IntMap.delete id) return Nothing else return (if typ==0 then Just chan else Nothing) forM_ (catMaybes mbChans) $ \chan -> do writeTMChan chan cm return Nothing addMsgToLastN :: Bool -> MessageType -> NetCryptoSession -> InOrOut CryptoMessage -> IO () addMsgToLastN handledFlg typ session cm = do let lastNQ = ncLastNMsgs session atomically $ do view <- readTVar (ncView session) snapshot <- viewSnapshot view num <- CB.getNextSequenceNum lastNQ CB.enqueue lastNQ num (handledFlg,(snapshot,cm)) -- | use to add a single hook to a specific session. addCryptoDataHook1 :: Map.Map MessageType [NetCryptoHook] -> MessageType -> NetCryptoHook -> Map.Map MessageType [NetCryptoHook] addCryptoDataHook1 mp typ hook = case Map.lookup typ mp of Nothing -> Map.insert typ [hook] mp Just hooks -> Map.insert typ (hook:hooks) mp