{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} module Network.Tox.Crypto.Handlers where import Network.Tox.NodeId import Network.Tox.Crypto.Transport import Network.Tox.DHT.Transport (Cookie(..), NoSpam(..)) 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 Control.Monad import Data.Time.Clock.POSIX import qualified Data.ByteString as B 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.Environment import System.Directory #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 Text.Printf import Data.Bool import Connection (Status(..), Policy(..)) import Network.Tox.Handshake -- | This type indicates the progress of a tox encrypted friend link -- connection. Two scenarios are illustrated below. The parenthesis show the -- current 'G.Status' 'ToxProgress' of the session. -- -- -- Perfect handshake scenario: -- -- Peer 1 Peer 2 -- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie) -- Cookie request -> -- <- Cookie response -- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie) -- Handshake packet -> -- * accepts connection -- (InProgress AwaitingSessionPacket) -- <- Handshake packet -- *accepts connection -- (InProgress AwaitingSessionPacket) -- Encrypted packet -> <- Encrypted packet -- *confirms connection *confirms connection -- (Established) (Established) -- -- Connection successful. -- -- Encrypted packets -> <- Encrypted packets -- -- -- -- -- More realistic handshake scenario: -- Peer 1 Peer 2 -- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie) -- Cookie request -> *packet lost* -- Cookie request -> -- <- Cookie response -- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie) -- -- *Peer 2 randomly starts new connection to peer 1 -- (InProgress AcquiringCookie) -- <- Cookie request -- Cookie response -> -- (InProgress AwaitingHandshake) -- -- Handshake packet -> <- Handshake packet -- *accepts connection * accepts connection -- (InProgress AwaitingSessionPacket) (InProgress AwaitingSessionPacket) -- -- Encrypted packet -> <- Encrypted packet -- *confirms connection *confirms connection -- (Established) (Established) -- -- Connection successful. -- -- Encrypted packets -> <- Encrypted packets data ToxProgress = AwaitingDHTKey -- ^ Waiting to receive their DHT key. | AcquiringIPAddress -- ^ Searching DHT to obtain their node's IP & port. | AcquiringCookie -- ^ Attempting to obtain a cookie. | AwaitingHandshake -- ^ Waiting to receive a handshake. | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed". deriving (Eq,Ord,Enum,Show) type LookupPolicyFunction = Key -> STM Policy data Key = Key NodeId{-me-} NodeId{-them-} deriving (Eq,Ord) instance Show Key where show = show . showKey_ showKey_ :: Key -> String showKey_ (Key me them) = show me ++ ":" ++ show them -- * 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) , ncIdleEventHooks :: TVar [(Int,NetCryptoSession -> IO ())] , 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 , ncStoredRequests :: CyclicBuffer CryptoData -- ^ Store the last 5 packet requests, try handling in any order -- if the connection seems like it is locked (TODO) , ncRequestInterval :: TVar Int -- ^ How long (in miliseconds) to wait between packet requests , ncAliveInterval :: TVar Int -- ^ How long before the next ALIVE packet ("PING") -- is to be sent regardless of activity , ncTimeOut :: TVar Int -- ^ How many miliseconds of inactivity before this session is abandoned , ncIdleEvent :: TVar Int -- ^ How many miliseconds of inactivity before emergency measures are taken -- Emergency measures = (rehandle the packet requests stored in ncStoredRequests) , ncRequestThread :: TVar (Maybe ThreadId) -- ^ thread which sends packet requests , ncDequeueThread :: TVar (Maybe ThreadId) -- ^ when the thread which dequeues from ncPacketQueue -- is started, its ThreadId is stored here , ncDequeueOutGoingThread :: TVar (Maybe ThreadId) -- ^ the thread which actually sends lossless packets , ncPingMachine :: TVar (Maybe PingMachine) -- ^ thread which triggers ping events , ncPingThread :: TVar (Maybe ThreadId) -- ^ thread which actually queues outgoing pings , ncIdleEventThread :: TVar (Maybe ThreadId) , 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 } instance Eq NetCryptoSession where x == y = ncSessionId x == ncSessionId y data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession) , netCryptoSessionsByKey :: TVar (Map.Map PublicKey [NetCryptoSession]) , netCryptoPolicyByKey :: LookupPolicyFunction , transportCrypto :: TransportCrypto , defaultHooks :: Map.Map MessageType [NetCryptoHook] , defaultUnrecognizedHook :: MessageType -> NetCryptoHook , defaultIdleEventHooks :: [(Int,NetCryptoSession -> IO ())] , 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 , netCryptoPolicyByKey = \_ -> return OpenToConnect , transportCrypto = crypto , defaultHooks = hooks , defaultUnrecognizedHook = unrechook , defaultIdleEventHooks = [(0,handleRequestsOutOfOrder)] , 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 } 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 <- dtrace XNetCrypto ("lookupInRangeMap typ64=" ++ show typ64 ++ " " ++ show typ ++ show msg) $ lookupInRangeMap typ64 msgOutMapVar case result1 of -- msgOutMapLookup typ64 msgOutMap of Nothing -> dtrace XNetCrypto "lookupInRangeMap gave Nothing!" $ return Nothing Just outid -> dtrace XNetCrypto ("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 dtrace XNetCrypto (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 = dtrace XNetCrypto 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) newBaseNonce <- transportNewNonce crypto mbMyhandshakeData <- case nodeInfo (key2id $ hpCookieRemoteDhtkey hp) addr of Right nodeinfo -> Just <$> newHandShakeData timestamp crypto newBaseNonce hp nodeinfo (toPublic newsession) Left er -> return Nothing -- Unable to send handshake to non-internet socket! myhandshake <- mapM (encodeHandshake timestamp crypto key remotePublicKey otherCookie) mbMyhandshakeData ncHandShake0 <- newTVar (frmMaybe myhandshake) ncMyPacketNonce0 <- newTVar newBaseNonce cookie0 <- newTVar (HaveCookie otherCookie) ncHooks0 <- newTVar (defaultHooks sessions) ncUnrecognizedHook0 <- newTVar (defaultUnrecognizedHook sessions) ncIdleEventHooks0 <- newTVar (defaultIdleEventHooks 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))) ncStoredRequests0 <- CB.new 5 0 :: STM (CyclicBuffer CryptoData) 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) ncRequestThread0 <- newTVar Nothing ncDequeueThread0 <- newTVar Nothing ncDequeueOutGoingThread0 <- newTVar Nothing ncPingMachine0 <- newTVar Nothing ncPingThread0 <- newTVar Nothing ncIdleEventThread0 <- newTVar Nothing ncRequestInterval0 <- newTVar 7000 -- (TODO: shrink this) long interval while debugging slows trace flood ncAliveInterval0 <- newTVar 8000 -- 8 seconds -- ping Machine parameters fuzz <- return 0 -- randomRIO (0,2000) -- Fuzz to prevent simultaneous ping/pong exchanges. -- Disabled because tox has no pong event. ncTimeOut0 <- newTVar 32000 -- 32 seconds ncIdleEvent0 <- newTVar (5000 + fuzz) -- 5 seconds 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 , ncIdleEventHooks = ncIdleEventHooks0 , ncAllSessions = sessions , ncIncomingTypeArray = ncIncomingTypeArray0 , ncOutgoingIdMap = ncOutgoingIdMap0 , ncOutgoingIdMapEscapedLossy = lossyEscapeIdMap , ncOutgoingIdMapEscapedLossless = losslessEscapeIdMap , ncView = ncView0 , ncPacketQueue = pktq , ncStoredRequests = ncStoredRequests0 , ncRequestInterval = ncRequestInterval0 , ncAliveInterval = ncAliveInterval0 , ncTimeOut = ncTimeOut0 , ncIdleEvent = ncIdleEvent0 , ncRequestThread = ncRequestThread0 , ncDequeueThread = ncDequeueThread0 , ncDequeueOutGoingThread = ncDequeueOutGoingThread0 , ncPingMachine = ncPingMachine0 , ncPingThread = ncPingThread0 , ncIdleEventThread = ncIdleEventThread0 , 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 dtrace XNetCrypto ("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 = tput XNetCrypto msg 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 = tput XNetCrypto msg 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 sidStr = printf "(%x)" (ncSessionId netCryptoSession0) -- launch dequeue thread -- (In terms of data dependency, this thread could be launched prior to handshake) threadid <- forkIO $ do tid <- myThreadId atomically $ writeTVar (ncDequeueThread netCryptoSession0) (Just tid) labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey) ++ sidStr) fix $ \loop -> do cd <- atomically $ PQ.dequeue pktq if msgID (bufferData cd) == PacketRequest then do dput XNetCrypto $ "Dequeued::PacketRequest seqno=" ++ show (bufferStart cd) ++ " " ++ show (bufferData cd) handlePacketRequest netCryptoSession0 cd else do dput XNetCrypto $ "Dequeued::" ++ show (bufferData cd) ++ " now running hook..." void $ runCryptoHook netCryptoSession0 (bufferData cd) loop dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoDequeue." ++ show (key2id remotePublicKey) ++ sidStr -- launch request thread -- (In terms of data dependency, this thread could be launched prior to handshake) reqthreadId <- forkIO $ do tid <- myThreadId atomically $ writeTVar (ncRequestThread netCryptoSession0) (Just tid) labelThread tid ("NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr) fix $ \loop -> do atomically (readTVar (ncRequestInterval netCryptoSession0)) >>= threadDelay . (* 1000) nums <- atomically $ PQ.getMissing pktq dput XNetCrypto $ "(Request Thread) Missing Packets detected:" ++ show nums getOutGoingParam <- PQ.readyOutGoing pktoq atomically $ do seqno <- PQ.getLastDequeuedPlus1 pktq ogresult <- PQ.tryAppendQueueOutgoing getOutGoingParam pktoq (createRequestPacket seqno nums) case ogresult of PQ.OGSuccess _ -> return () _ -> retry loop dput XNetCrypto $ "runUponHandshake: " ++ show threadid ++ " = NetCryptoRequest." ++ show (key2id remotePublicKey) ++ sidStr -- launch dequeueOutgoing thread threadidOutgoing <- forkIO $ do tid <- myThreadId atomically $ writeTVar (ncDequeueOutGoingThread netCryptoSession0) (Just tid) labelThread tid ("NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey) ++ sidStr) 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) ++ sidStr -- launch ping Machine thread pingMachine <- forkPingMachineDynamic ("NetCrypto." ++ show (key2id remotePublicKey) ++ sidStr) (ncIdleEvent netCryptoSession0) (ncTimeOut netCryptoSession0) atomically $ writeTVar (ncPingMachine netCryptoSession0) (Just pingMachine) -- launch ping thread pingThreadId <- forkIO $ do tid <- myThreadId atomically $ writeTVar (ncPingThread netCryptoSession0) (Just tid) labelThread tid ("NetCryptoPingSender." ++ show (key2id remotePublicKey) ++ sidStr) fix $ \loop -> do atomically (readTVar (ncAliveInterval netCryptoSession0)) >>= threadDelay . (* 1000) dput XNetCrypto $ "pingThread (session: " ++ show (ncSessionId netCryptoSession0) ++ ") Sending Alive(PING) Packet" lr <- sendPing crypto netCryptoSession0 case lr of Left s -> dput XNetCrypto $ "(pingThread session: " ++ show (ncSessionId netCryptoSession0) ++ ") " ++ s Right _ -> return () loop -- launch IdleEvent thread idleThreadId <- forkIO $ do tid <- myThreadId atomically $ writeTVar (ncIdleEventThread netCryptoSession0) (Just tid) labelThread tid ("NetCryptoIdleEvent." ++ show (key2id remotePublicKey) ++ sidStr) event <- atomically $ pingWait pingMachine case event of PingIdle -> do hooks <- atomically (readTVar (ncIdleEventHooks netCryptoSession0)) mapM_ (($ netCryptoSession0) . snd) hooks PingTimeOut -> destroySession netCryptoSession0 -- update session with thread ids let netCryptoSession = netCryptoSession0 -- 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) sendOnline crypto netCryptoSession -- Run new session hooks 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 () destroySession :: NetCryptoSession -> IO () destroySession session = do let allsessions = ncAllSessions session sid = ncSessionId session stopThread :: TVar (Maybe ThreadId) -> IO () stopThread x = atomically (readTVar x) >>= maybe (return ()) killThread stopMachine :: TVar (Maybe PingMachine) -> IO () stopMachine x = atomically (readTVar x) >>= maybe (return ()) pingCancel atomically $ do modifyTVar (netCryptoSessionsByKey allsessions) $ Map.map (filter ((/=sid) . ncSessionId)) modifyTVar (netCryptoSessions allsessions) $ Map.filterWithKey (\k v -> ncSessionId v /= sid) stopMachine (ncPingMachine session) stopThread (ncPingThread session) stopThread (ncDequeueThread session) stopThread (ncDequeueOutGoingThread session) stopThread (ncRequestThread session) stopThread (ncIdleEventThread session) -- | 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 = tput XNetCrypto msg 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 do (r,action) <- freshCryptoSession sessions addr newsession timestamp hp return (r,destroySession session >> action) 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" (r,action) <- freshCryptoSession sessions addr newsession timestamp hp -- basenonce mismatch, trigger refresh return (r, destroySession session >> action) _ -> do dmsg "updateCryptoSession -- unexpected condition! have hpTheirSessionKeyPublic but missing hpTheirBaseNonce?" return (Nothing,return ()) else do writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket) return (Nothing,return ()) 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 = dtrace XNetCrypto 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" let k = Key (key2id . toPublic $ key) (key2id remotePublicKey) policy <- netCryptoPolicyByKey sessions k case policy of x | x `elem` [OpenToConnect,TryingToConnect] -> freshCryptoSession sessions addr newsession timestamp hp -- create new session x -> do dmsg $ "Ignoring Handshake from " ++ show (key2id remotePublicKey) ++ " due to policy: " ++ show x return (Nothing,return ()) 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, ncSessionId, ncStoredRequests}) -> do -- Unrecognized packets, try them thrice so as to give -- handshakes some time to come in -- TODO: Remove this loop, as it is probably unnecessary. -- If it is necessary, use a queue instead. flip fix (0::Int) $ \loop i -> do mbTheirBaseNonce <- atomically $ readTVar ncTheirBaseNonce case mbTheirBaseNonce of NeedHandshake -> do dput XNetCrypto "CryptoPacket recieved, but we still dont have their base nonce?" if (i < 3) then do dput XNetCrypto $ "Trying again (maybe handshake is on its way) ... i == " ++ show i loop (i+1) else do dput XNetCrypto "Tried 3 times.. giving up on this packet" 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=(unpadCryptoMsg -> cm)}) -> do -- decryption succeeded, let cd = cd' { bufferData= cm } -- 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) dtrace XNetCrypto ("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 ncPingMachine0 <- atomically $ readTVar ncPingMachine case ncPingMachine0 of -- the ping machine is used to detect inactivity and respond accordingly 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 " ++ show cm atomically $ PQ.observeOutOfBand ncPacketQueue bufferEnd runCryptoHook session (bufferData cd) else do dput XNetCrypto $ "enqueue ncPacketQueue Lossless " ++ show cm when (msgID cm == PING) $ dput XNetCrypto $ "NetCrypto Recieved PING (session " ++ show ncSessionId ++")" when (msgID cm == PacketRequest) . atomically $ do num <- CB.getNextSequenceNum ncStoredRequests CB.enqueue ncStoredRequests num cd 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 -- dtrace XNetCrypto ("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 ------------------ Slurped from c-toxcore for reference. ------------------------------- pattern PACKET_ID_ONLINE = 24 pattern PACKET_ID_OFFLINE = 25 pattern PACKET_ID_NICKNAME = 48 pattern PACKET_ID_STATUSMESSAGE = 49 pattern PACKET_ID_USERSTATUS = 50 pattern PACKET_ID_TYPING = 51 pattern PACKET_ID_MESSAGE = 64 -- pattern PACKET_ID_ACTION = (PACKET_ID_MESSAGE + MESSAGE_ACTION) {- 65 -} pattern PACKET_ID_MSI = 69 pattern PACKET_ID_FILE_SENDREQUEST = 80 pattern PACKET_ID_FILE_CONTROL = 81 pattern PACKET_ID_FILE_DATA = 82 pattern PACKET_ID_INVITE_CONFERENCE = 96 pattern PACKET_ID_ONLINE_PACKET = 97 pattern PACKET_ID_DIRECT_CONFERENCE = 98 pattern PACKET_ID_MESSAGE_CONFERENCE = 99 pattern PACKET_ID_LOSSY_CONFERENCE = 199 pattern PACKET_ID_LOSSLESS_RANGE_START = 160 pattern PACKET_ID_LOSSLESS_RANGE_SIZE = 32 pattern PACKET_ID_ALIVE = 16 pattern PACKET_ID_SHARE_RELAYS = 17 pattern PACKET_ID_FRIEND_REQUESTS = 18 pattern PACKET_ID_PADDING = 0 -- Denotes padding pattern PACKET_ID_REQUEST = 1 -- Used to request unreceived packets pattern PACKET_ID_KILL = 2 -- Used to killconnection pattern PACKET_ID_LOSSY_RANGE_START = 192 pattern PACKET_ID_LOSSY_RANGE_SIZE = 63 ---------------------------------------------------------------------------------------- -- | 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 (CryptoPacket Encrypted)) 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 x -> updateLocal >> return (Right x) PQ.OGFull -> return (Left "Outgoing packet buffer is full") PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet") sendPing :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted)) sendPing crypto session = do let cm=OneByte PING addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session (return ()) (OneByte PING) sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted)) sendOnline crypto session = do let cm=OneByte ONLINE addMsgToLastN False (cm ^. messageType) session (Out cm) result <- sendCrypto crypto session (return ()) (OneByte ONLINE) -- double this packet case result of Right pkt -> do void . forkIO $ do tid <- myThreadId labelThread tid "TEMPORARY.PACKET.DOUBLE.ONLINE" threadDelay 100000 -- delay 10th of a second case ncSockAddr session of HaveDHTKey saddr -> sendSessionPacket (ncAllSessions session) saddr pkt return (Right pkt) sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String (CryptoPacket Encrypted)) 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 (CryptoPacket Encrypted)) sendKill crypto session = do let cm=OneByte KillPacket mbOutQ <- atomically $ readTVar (ncOutgoingQueue session) case mbOutQ of NeedHandshake -> do let errmsg="NetCrypto NOT SENDING Kill packet (sessionid: " ++ show (ncSessionId session) ++ ") since no handshake yet" dput XNetCrypto errmsg dput XNetCrypto $ "Destroying session anyway" destroySession session return (Left errmsg) HaveHandshake outq -> do dput XNetCrypto $ "NetCrypto sending Kill packet (sessionid: " ++ show (ncSessionId session) ++ ")" getOutGoingParam <- PQ.readyOutGoing outq mbPkt <- atomically $ PQ.peekPacket getOutGoingParam outq cm case mbPkt of Nothing -> do let errmsg = "Error sending kill packet! (sessionid: " ++ show (ncSessionId session) ++ ")" dput XNetCrypto errmsg dput XNetCrypto $ "Destroying session anyway" Right <$> destroySession session return (Left errmsg) Just (pkt,seqno) -> do case (ncSockAddr session) of NeedDHTKey -> do let errmsg= "NetCrypto NOT SENDING Kill packet (sessionid: " ++ show (ncSessionId session) ++ ") since no DHTkey(sockaddr) yet" dput XNetCrypto errmsg dput XNetCrypto $ "Destroying session anyway" Right <$> destroySession session return (Left errmsg) HaveDHTKey saddr -> do sendSessionPacket (ncAllSessions session) saddr pkt dput XNetCrypto $ "sent kill packet (sessionid: " ++ show (ncSessionId session) ++ ")... now destroying session..." destroySession session return (Right pkt) setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String (CryptoPacket Encrypted)) 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 (CryptoPacket Encrypted)) 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 (CryptoPacket Encrypted)) 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 (CryptoPacket Encrypted)) 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 (CryptoPacket Encrypted)) 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]) , (Msg KillPacket, [defaultKillHook]) ] handleRequestsOutOfOrder :: NetCryptoSession -> IO () handleRequestsOutOfOrder session = do cds <- atomically $ CB.cyclicBufferViewList (ncStoredRequests session) mapM_ (handlePacketRequest session) (map snd cds) handlePacketRequest :: NetCryptoSession -> CryptoData -> IO () handlePacketRequest session (CryptoData { bufferStart=num , bufferData=cm@(msgID -> PacketRequest) }) | let getbytes (OneByte _) = [] getbytes (TwoByte _ b) = [b] getbytes (UpToN _ bs) = B.unpack bs , bs <- getbytes cm , not (null bs) , HaveDHTKey addr <- ncSockAddr session = do mbOutQ <- atomically $ readTVar (ncOutgoingQueue session) case mbOutQ of HaveHandshake pktoq -> do getOutGoingParam <-PQ.readyOutGoing pktoq ps <- atomically $ PQ.getRequested getOutGoingParam pktoq num bs let resend (Just (n,pkt)) = sendSessionPacket (ncAllSessions session) addr pkt resend _ = return () mapM_ resend ps _ -> return () handlePacketRequest session cd = return () defaultKillHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage)) defaultKillHook session cm@(msgID -> KillPacket) = do dput XNetCrypto $ "Recieved kill packet (sessionid: " ++ show (ncSessionId session) ++ ") destroying session" destroySession session return (Just $ \m -> m) defaultKillHook _ _ = return (Just $ \cm -> cm) 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 typ session cm = do dput XNetCrypto $ "(NetCrypto) defaultUnRecHook: packet (sessionid: " ++ show (ncSessionId session) ++ ") " ++ show cm hookHelper False typ session cm hookHelper :: Bool -> MessageType -> NetCryptoHook hookHelper _ typ session cm | any ($ typ) [isKillPacket, isOFFLINE] = do dput XNetCrypto $ "(hookHelper kill/offline) cm=" ++ show cm atomically $ do tmchans <- map snd . IntMap.elems <$> readTVar (ncListeners session) forM_ tmchans $ \chan -> closeTMChan chan return Nothing hookHelper handledFlg typ session cm = do dput XNetCrypto $ "(ENTER hookHelper) " ++ show cm 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