{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE CPP #-} 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, createCookieSTM ) import Crypto.Tox import Control.Arrow 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 #ifdef THREAD_DEBUG import Control.Concurrent.Lifted.Instrument #else import Control.Concurrent import GHC.Conc (labelThread) #endif 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 Encrypted)) -- ^ 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 :: TVar (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 Encrypted , hpTheirSessionKeyPublic :: Maybe PublicKey , hpMySecretKey :: SecretKey , hpCookieRemotePubkey :: PublicKey , hpCookieRemoteDhtkey :: PublicKey } newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> PublicKey -> STM (Maybe HandshakeData) newHandShakeData timestamp crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr mySessionPublic = do freshCookie <- case nodeInfo (key2id hpCookieRemoteDhtkey) addr of Right nodeinfo -> Just <$> createCookieSTM timestamp 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' return $ fmap (\freshCookie' -> HandshakeData { baseNonce = basenonce , sessionKey = mySessionPublic , 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 -> SecretKey -> POSIXTime -> HandshakeParams -> STM (Maybe (Handshake Encrypted),IO ()) freshCryptoSession sessions addr newsession timestamp 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 dmsg msg = trace msg (return ()) sessionId <- do x <- readTVar (nextSessionId sessions) modifyTVar (nextSessionId sessions) (+1) return x -- ncState0 <- newTVar Accepted -- (InProgress AwaitingSessionPacket) ncState0 <- newTVar (if isJust mbtheirBaseNonce then InProgress AwaitingSessionPacket else InProgress AwaitingHandshake) ncTheirBaseNonce0 <- newTVar (frmMaybe mbtheirBaseNonce) n24 <- transportNewNonce crypto state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto key remotePublicKey newBaseNonce <- transportNewNonce crypto mbMyhandshakeData <- newHandShakeData timestamp crypto newBaseNonce hp addr (toPublic newsession) 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 <- newTVar (frmMaybe myhandshake) ncMyPacketNonce0 <- newTVar newBaseNonce cookie0 <- newTVar (HaveCookie otherCookie) ncHooks0 <- newTVar (defaultHooks sessions) ncUnrecognizedHook0 <- newTVar (defaultUnrecognizedHook sessions) ncIncomingTypeArray0 <- newTVar (msgTypeArray sessions) let idMap = foldl (\mp (x,y) -> W64.insert x y mp) W64.empty (zip [0..255] [0..255]) (ncOutgoingIdMap0,lossyEscapeIdMap,losslessEscapeIdMap) <- 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 <- newTVar (sessionView sessions) pktq <- PQ.new (inboundQueueCapacity sessions) 0 bufstart <- newTVar 0 mbpktoq <- case mbtheirSessionKey of Nothing -> return NeedHandshake Just theirSessionKey -> createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce0 ncOutgoingIdMap0 mbpktoqVar <- newTVar mbpktoq lastNQ <- CB.new 10 0 :: STM (CyclicBuffer (Bool,(ViewSnapshot,InOrOut CryptoMessage))) listeners <- newTVar IntMap.empty msgNum <- newTVar 0 dropNum <- newTVar 0 theirbasenonce <- readTVar ncTheirBaseNonce0 dmsg $ "freshCryptoSession: Session ncTheirBaseNonce=" ++ show theirbasenonce dmsg $ "freshCryptoSession: My Session Public =" ++ show (key2id $ toPublic newsession) ncTheirSessionPublic0 <- 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 = mbpktoqVar , ncLastNMsgs = lastNQ , ncListeners = listeners } -- addSessionToMap sessions addr netCryptoSession0 addSessionToMapIfNotThere sessions addr netCryptoSession0 maybeLaunchMissles <- case mbpktoq of NeedHandshake -> return (return ()) HaveHandshake pktoq -> return (runUponHandshake netCryptoSession0 addr pktoq) return (myhandshake,maybeLaunchMissles) 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 -> STM (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 ++ "\n toWireIO: theirSessionKey = " ++ show (key2id theirSessionKey) ++ "\n toWireIO: my public session key = " ++ show (key2id (toPublic newsession)) ) $ writeTVar ncMyPacketNonce0 n24plus1 return (return (f n24, n24, ncOutgoingIdMap0)) pktoq <- PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0 return (HaveHandshake pktoq) -- | add new session to the lookup maps addSessionToMap :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM () addSessionToMap sessions addrRaw netCryptoSession = do let addr = either id id $ either4or6 addrRaw let dmsg msg = trace msg (return ()) dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession) let remotePublicKey = ncTheirPublicKey netCryptoSession allsessions = netCryptoSessions sessions allsessionsByKey= netCryptoSessionsByKey sessions byAddrResult <- readTVar allsessions >>= return . Map.lookup addr mp <- readTVar allsessionsByKey modifyTVar allsessions (Map.insert addr netCryptoSession) modifyTVar allsessionsByKey (Map.insertWith (++) remotePublicKey [netCryptoSession]) -- | add this session to the lookup maps, overwrite if its already in them addSessionToMapIfNotThere :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM () addSessionToMapIfNotThere sessions addrRaw netCryptoSession = do let addr = either id id $ either4or6 addrRaw let dmsg msg = trace msg (return ()) dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession) let remotePublicKey = ncTheirPublicKey netCryptoSession allsessions = netCryptoSessions sessions allsessionsByKey= netCryptoSessionsByKey sessions byAddrResult <- readTVar allsessions >>= return . Map.lookup addr mp <- readTVar allsessions case byAddrResult of Just (NCrypto { ncSessionId = staleId }) -> do dmsg $ "addSessionToMapIfNotThere: addr(" ++ show addr ++") already in map(" ++ show (map (second ncSessionId) (Map.assocs mp)) ++ ")" dmsg $ "addSessionToMapIfNotThere: considering it stale(staleId=" ++ show staleId ++") and removing it from the by-key map, so remove it from by-key map." dmsg $ "addSessionToMapIfNotThere: leave it in the by-addr map, and overwrite it shortly." -- manually remove the stale session from the by-key map modifyTVar allsessionsByKey (Map.map (filter ((/=staleId) . ncSessionId))) Nothing -> -- nothing to remove dmsg $ "addSessionToMapIfNotThere: addr(" ++ show addr ++") not yet in map(" ++ show (map (second ncSessionId) (Map.assocs mp)) ++ ")" dmsg $ "addSessionToMapIfNotThere: Inserting addr(" ++ show addr ++") into map(" ++ show (map (second ncSessionId) (Map.assocs mp)) ++ ")" -- write session to by-addr map regardless of whether one is in there, -- it should overwrite on match modifyTVar allsessions (Map.insert addr netCryptoSession) -- Now insert new session into by-key map byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey case byKeyResult of Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession]) Just xs -> do -- in case we're using the same long term key on different IPs ... modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs)) runUponHandshake :: NetCryptoSession -> SockAddr -> NetCryptoOutQueue -> IO () runUponHandshake netCryptoSession0 addr pktoq = do dput XNetCrypto "(((((((runUponHandshake))))))) Launching threads" 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 dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoDequeue." ++ show (key2id remotePublicKey) -- 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 dput XNetCrypto $ "runUponHandshake: " ++ show threadidOutgoing ++ " = NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey) -- 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 $ addSessionToMapIfNotThere sessions addr netCryptoSession -- run announceNewSessionHooks dput XNetCrypto $ "runUponHandshake: Announcing new session" 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. -- -- 1) duplicate packet ... ignore -- 2) handshake for new session (old session is lost?) -- 3) we initiated, this a response updateCryptoSession :: NetCryptoSessions -> SockAddr -> SecretKey -> POSIXTime -> HandshakeParams -> NetCryptoSession -> Handshake Encrypted -> STM (Maybe (Handshake Encrypted), IO ()) updateCryptoSession sessions addr newsession timestamp hp session handshake = do let dmsg msg = trace msg (return ()) ncState0 <- readTVar (ncState session) ncTheirBaseNonce0 <- 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 dmsg "updateCryptoSession already accepted.." dmsg (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0 ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp) ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp)) dmsg (" ncTheirDHTKey=" ++ show (ncTheirDHTKey session) ++ bool "{/=}" "{==}" (ncTheirDHTKey session == HaveDHTKey (hpCookieRemoteDhtkey hp)) ++ "hpCookieRemoteDhtkey=" ++ show (hpCookieRemoteDhtkey hp)) if ( toMaybe ncTheirBaseNonce0 /= hpTheirBaseNonce hp || ncTheirDHTKey session /= HaveDHTKey (hpCookieRemoteDhtkey hp) ) then freshCryptoSession sessions addr newsession timestamp hp else return (Nothing,return ()) else do dmsg "updateCryptoSession else clause" dmsg (" ncTheirBaseNonce0=" ++ show ncTheirBaseNonce0 ++ bool "(/=)" "(==)" (toMaybe ncTheirBaseNonce0 == hpTheirBaseNonce hp) ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp)) if ( ncTheirBaseNonce0 /= frmMaybe (hpTheirBaseNonce hp)) then do case ncTheirBaseNonce0 of NeedHandshake | Just theirSessionPublic <- hpTheirSessionKeyPublic hp -> do writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp)) writeTVar (ncTheirBaseNonce session) (frmMaybe (hpTheirBaseNonce hp)) writeTVar (ncTheirSessionPublic session) (frmMaybe (hpTheirSessionKeyPublic hp)) writeTVar (ncHandShake session) (HaveHandshake handshake) writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket) mbpktoq <- createNetCryptoOutQueue sessions newsession theirSessionPublic (ncPacketQueue session) (ncMyPacketNonce session) (ncOutgoingIdMap session) writeTVar (ncOutgoingQueue session) mbpktoq return (Nothing,maybe (dput XNetCrypto "ERROR: something went wrong creating the ncOutgoingQueue") (runUponHandshake session addr) (toMaybe mbpktoq)) HaveHandshake _ -> do dmsg "basenonce mismatch, trigger refresh" freshCryptoSession sessions addr newsession timestamp hp -- basenonce mismatch, trigger refresh _ -> do dmsg "updateCryptoSession -- unexpected condition! have hpTheirSessionKeyPublic but missing hpTheirBaseNonce?" return (Nothing,return ()) else do writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket) return (Nothing,return ()) 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) decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (SecretKey,Handshake Identity)) decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto <*> transportSymmetric crypto let seckeys = map fst ukeys dput XNetCrypto "decryptHandshake: trying the following keys:" now <- getPOSIXTime forM_ seckeys $ \k -> dput XNetCrypto $ " " ++ show (key2id . toPublic $ k) fmap join . sequence $ do -- Either Monad cd@(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,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15) let hinit = hashInit hctx = hashUpdate hinit n24 hctx' = hashUpdate hctx ecookie digest = hashFinalize hctx' left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest) return ( key , hshake { handshakeCookie = Cookie n24 (pure cd) , handshakeData = pure hsdata } ) toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams toHandshakeParams (key,hs) = let hd = runIdentity $ handshakeData hs Cookie _ cd0 = handshakeCookie hs CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0 in HParam { hpTheirBaseNonce = Just $ baseNonce hd , hpOtherCookie = otherCookie hd , hpTheirSessionKeyPublic = Just $ sessionKey hd , hpMySecretKey = key , hpCookieRemotePubkey = remotePublicKey , hpCookieRemoteDhtkey = remoteDhtPublicKey } handshakeH :: NetCryptoSessions -> SockAddr -> Handshake Encrypted -> IO (Maybe a) handshakeH sessions addrRaw hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do let addr = either id id $ either4or6 addrRaw 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 toHandshakeParams <$> decryptHandshake crypto hshake 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) -- IO action to get a new session key in case we need it in transaction to come newsession <- generateSecretKey -- Do a lookup, so we can handle the update case differently let dmsg msg = trace msg (return ()) timestamp <- getPOSIXTime (myhandshake,launchThreads) <- atomically $ do sessionsmap <- readTVar allsessions case Map.lookup addr sessionsmap of Nothing -> do dmsg $ "sockaddr(" ++ show addr ++ ") not in session map(" ++ show (map (second ncSessionId) (Map.assocs sessionsmap)) ++ "), so freshCryptoSession" freshCryptoSession sessions addr newsession timestamp hp -- create new session Just session -> do dmsg "sockaddr ALREADY in session map, so updateCryptoSession" updateCryptoSession sessions addr (ncSessionSecret session) timestamp hp session hshake -- update existing session launchThreads forM myhandshake $ \response_handshake -> do sendHandshake sessions addr response_handshake return () return Nothing sessionPacketH :: NetCryptoSessions -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (x -> x)) sessionPacketH sessions addrRaw (CryptoPacket nonce16 encrypted) = do let addr = either id id $ either4or6 addrRaw 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) dput XNetCrypto $ "(NetCrypto)sessionPacketH: mySession public=" ++ show (key2id $ toPublic ncSessionSecret) dput XNetCrypto $ "(NetCrypto)sessionPacketH: theirSession public=" ++ show (key2id $ pubkey) 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 HaveHandshake outq <- atomically $ readTVar (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 = do let cm=OneByte ONLINE addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session (return ()) (OneByte ONLINE) sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) sendOffline crypto session = do let cm=OneByte OFFLINE addMsgToLastN False (cm ^. messageType) session (Out cm) 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