{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} module Network.Tox.Crypto.Handlers where import Network.QueryResponse import Network.Tox.NodeId import Network.Tox.Crypto.Transport import Network.Tox.DHT.Transport (Cookie(..),CookieData(..), CookieRequest(..), NoSpam(..)) import Network.Tox.DHT.Handlers (Client, cookieRequest, createCookie ) import Crypto.Tox import Control.Concurrent.STM import Control.Concurrent.STM.TMChan import Network.Address import qualified Data.Map.Strict as Map import Crypto.Hash import Control.Applicative import Control.Monad import Data.Time.Clock.POSIX import qualified Data.ByteString as B import System.IO import Data.ByteString (ByteString) import Control.Lens import Data.Function import qualified Data.PacketQueue as PQ ;import Data.PacketQueue (PacketQueue) import qualified Data.CyclicBuffer as CB ;import Data.CyclicBuffer (CyclicBuffer) import Data.Serialize as S import Data.Word import Data.Maybe import qualified Data.Word64Map as W64 import Data.Word64RangeMap import qualified Data.Set as Set import qualified Data.Array.Unboxed as A import SensibleDir import System.FilePath import System.IO.Temp import System.Environment import System.Directory import System.Random -- for ping fuzz import Control.Concurrent import GHC.Conc (labelThread) import PingMachine import qualified Data.IntMap.Strict as IntMap import Control.Concurrent.Supply import Data.InOrOut -- util, todo: move to another module maybeToEither :: Maybe b -> Either String b maybeToEither (Just x) = Right x maybeToEither Nothing = Left "maybeToEither" data NetCryptoSessionStatus = Unaccepted | Accepted | Confirmed deriving (Eq,Ord,Show,Enum) type IOHook addr x = addr -> x -> IO (Maybe (x -> x)) type NetCryptoHook = IOHook NetCryptoSession CryptoMessage type MsgTypeArray = A.UArray Word8 Word64 -- type MsgOutMap = RangeMap STArray Word8 STRef -- type MsgOutMap = W64.Word64Map Word8 -- type MsgOutMap = A.UArray Word64 Word8 -- if above is too slow, switch to this, but use reasonable bounds -- msgOutMapLookup :: Word64 -> MsgOutMap -> STM (Maybe Word8) -- msgOutMapLookup k mp = return (W64.lookup k mp) -- | 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 NetCryptoSessionStatus , ncMyPublicKey :: PublicKey , ncSessionId :: SessionID , ncTheirPublicKey :: PublicKey -- Tox id w/o nospam , ncTheirBaseNonce :: TVar Nonce24 -- base nonce + packet number , ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number , ncHandShake :: TVar (Maybe (Handshake Encrypted)) , ncCookie :: TVar (Maybe Cookie) -- ^ Cookie issued by remote peer , ncTheirDHTKey :: PublicKey , ncTheirSessionPublic :: Maybe PublicKey , ncSessionSecret :: SecretKey , ncSockAddr :: SockAddr , ncHooks :: TVar (Map.Map MessageType [NetCryptoHook]) , ncUnrecognizedHook :: TVar (MessageType -> NetCryptoHook) , ncIncomingTypeArray :: TVar MsgTypeArray -- ^ supported messages, 0 for unsupported, -- otherwise the messageType, some message types -- may not be in ncHooks yet, but they should appear -- here if ncUnrecognizedHook will add them to ncHooks -- on an as-need basis. , ncOutgoingIdMap :: RangeMap TArray Word8 TVar , ncAllSessions :: NetCryptoSessions -- ^ may be needed if one net-crypto session -- needs to possibly start another, as is -- the case in group chats , ncView :: TVar SessionView , ncPacketQueue :: PacketQueue CryptoData , ncBufferStart :: TVar Word32 , ncDequeueThread :: Maybe ThreadId , ncPingMachine :: Maybe PingMachine , ncOutgoingQueue :: PQ.PacketOutQueue (State,Nonce24,RangeMap TArray Word8 TVar) CryptoMessage (CryptoPacket Encrypted) CryptoData , ncLastNMsgs :: PacketQueue (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 , ncMsgNumVar :: TVar Word32 -- ^ The number of non-handshake crypto messages written to ncLastNMsgs total , ncDropCntVar :: TVar Word32 -- ^ The number of crypto messages that were overwritten in the ncLastNMsgs -- before anybody got to see them. } 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] , sessionTransport :: Transport String SockAddr NetCrypto , listenerIDSupply :: TVar Supply } 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 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 , sessionTransport = error "Need to set sessionTransport field of NetCryptoSessions!" , listenerIDSupply = lsupplyVar } data HandshakeParams = HParam { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own , hpOtherCookie :: Cookie , hpTheirSessionKeyPublic :: PublicKey , hpMySecretKey :: SecretKey , hpCookieRemotePubkey :: PublicKey , hpCookieRemoteDhtkey :: PublicKey } newHandShakeData :: TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> IO (Maybe HandshakeData) newHandShakeData crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr = do freshCookie <- case nodeInfo (key2id hpCookieRemoteDhtkey) addr of Right nodeinfo -> Just <$> createCookie crypto nodeinfo hpCookieRemotePubkey Left er -> return Nothing let hinit = hashInit Cookie n24 encrypted = hpOtherCookie hctx = hashUpdate hinit n24 hctx' = hashUpdate hctx encrypted digest = hashFinalize hctx' -- parameters addr {--> SockAddr -} -- mbcookie <- case hpOtherCookie of -- Nothing -> case (nodeInfo hpCookieRemoteDhtkey addr) of -- Right nodeinfo -> cookieRequest crypto netCryptoDHTClient (toPublic hpMySecretKey) nodeinfo -- Left er -> return Nothing -- Just c -> return (Just c) return $ fmap (\freshCookie' -> HandshakeData { baseNonce = basenonce , sessionKey = toPublic hpMySecretKey , cookieHash = digest , otherCookie = freshCookie' }) freshCookie type XMessage = CryptoMessage -- todo -- THIS Would work if not for the IO shared secret cache... -- increments packet nonce, only call when actually queuing an outgoing packet -- getOutGoingParam crypto session = do -- n24 <- (ncMyPacketNonce session) -- let state = computeSharedSecret (transportSecret crypto) (ncTheirPublicKey session) n24 -- modifyTVar (ncMyPacketNonce session) (+1) -- rangemap <- readTVar (ncOutgoingIdMap session) -- return (state,n24,rangemap) ncToWire :: STM (State,Nonce24,RangeMap TArray Word8 TVar) -> Word32{- packet number we expect to recieve -} -> Word32{- buffer_end -} -> Word32{- packet number -} -> XMessage -> STM (Maybe (CryptoPacket Encrypted,Word32{-next packet no-})) ncToWire getState seqno bufend pktno msg = do let typ = getMessageType msg typ64 = toWord64 typ let lsness msg = case typ of Msg mid -> lossyness mid GrpMsg KnownLossy _ -> Lossy GrpMsg KnownLossless _ -> Lossless (state,n24,msgOutMapVar) <- getState -- msgOutMap <- readTVar msgOutMapVar result1 <- lookupInRangeMap typ64 msgOutMapVar case result1 of -- msgOutMapLookup typ64 msgOutMap of Just outid -> 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 = nonce24ToWord16 n24, 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) freshCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> IO () freshCryptoSession sessions addr hp@(HParam { hpTheirBaseNonce = Just theirBaseNonce , hpOtherCookie = otherCookie , hpTheirSessionKeyPublic = theirSessionKey , hpMySecretKey = key , hpCookieRemotePubkey = remotePublicKey , hpCookieRemoteDhtkey = remoteDhtPublicKey }) = do let crypto = transportCrypto sessions allsessions = netCryptoSessions sessions allsessionsByKey = netCryptoSessionsByKey sessions sessionId <- atomically $ do x <- readTVar (nextSessionId sessions) modifyTVar (nextSessionId sessions) (+1) return x ncState0 <- atomically $ newTVar Accepted ncTheirBaseNonce0 <- atomically $ newTVar theirBaseNonce n24 <- atomically $ transportNewNonce crypto state <- lookupSharedSecret crypto key remoteDhtPublicKey n24 newBaseNonce <- atomically $ transportNewNonce crypto mbMyhandshakeData <- newHandShakeData crypto newBaseNonce hp addr let encodeHandshake myhandshakeData = let plain = encodePlain myhandshakeData -- state = computeSharedSecret key remoteDhtPublicKey n24 encrypted = encrypt state plain in Handshake { handshakeCookie = otherCookie , handshakeNonce = n24 , handshakeData = encrypted } let myhandshake= encodeHandshake <$> mbMyhandshakeData ncMyPacketNonce0 <- atomically $ newTVar newBaseNonce ncHandShake0 <- atomically $ newTVar myhandshake cookie0 <- atomically $ newTVar (Just otherCookie) newsession <- generateSecretKey ncHooks0 <- atomically $ newTVar (defaultHooks sessions) ncUnrecognizedHook0 <- atomically $ newTVar (defaultUnrecognizedHook sessions) ncIncomingTypeArray0 <- atomically $ newTVar (msgTypeArray sessions) let idMap = foldl (\mp (x,y) -> W64.insert x y mp) W64.empty (zip [0..255] [0..255]) ncOutgoingIdMap0 <- atomically $ emptySTMRangeMap -- atomically $ newTVar idMap ncView0 <- atomically $ newTVar (sessionView sessions) pktq <- atomically $ PQ.new (inboundQueueCapacity sessions) 0 bufstart <- atomically $ newTVar 0 let toWireIO = do f <- lookupNonceFunction crypto newsession theirSessionKey atomically $ do n24 <- readTVar ncMyPacketNonce0 let n24plus1 = incrementNonce24 n24 writeTVar ncMyPacketNonce0 n24plus1 return (return (f n24, n24, ncOutgoingIdMap0)) pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0 msgQ <- atomically (PQ.newOverwrite 10 0 :: STM (PacketQueue (Bool,(ViewSnapshot,InOrOut CryptoMessage)))) listeners <- atomically $ newTVar IntMap.empty msgNum <- atomically $ newTVar 0 dropNum <- atomically $ newTVar 0 let netCryptoSession0 = NCrypto { ncState = ncState0 , ncMyPublicKey = toPublic key , ncSessionId = sessionId , ncTheirPublicKey = remotePublicKey , ncTheirBaseNonce = ncTheirBaseNonce0 , ncMyPacketNonce = ncMyPacketNonce0 , ncHandShake = ncHandShake0 , ncCookie = cookie0 , ncTheirDHTKey = remoteDhtPublicKey , ncTheirSessionPublic = Just theirSessionKey , ncSessionSecret = newsession , ncSockAddr = addr , ncHooks = ncHooks0 , ncUnrecognizedHook = ncUnrecognizedHook0 , ncAllSessions = sessions , ncIncomingTypeArray = ncIncomingTypeArray0 , ncOutgoingIdMap = ncOutgoingIdMap0 , ncView = ncView0 , ncPacketQueue = pktq , ncBufferStart = bufstart , 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 = pktoq , ncLastNMsgs = msgQ , ncListeners = listeners , ncMsgNumVar = msgNum , ncDropCntVar = dropNum } -- launch dequeue thread threadid <- forkIO $ do tid <- myThreadId labelThread tid ("NetCryptoDequeue." ++ show (key2id remotePublicKey)) fix $ \loop -> do cd <- atomically $ PQ.dequeue pktq _ <- runCryptoHook (netCryptoSession0 {ncDequeueThread=Just tid}) (bufferData cd) loop -- launch dequeueOutgoing thread threadidOutgoing <- forkIO $ do tid <- myThreadId labelThread tid ("NetCryptoDequeueOutgoing." ++ show (key2id remotePublicKey)) fix $ \loop -> do (_,pkt) <- atomically $ PQ.dequeueOutgoing pktoq sendMessage (sessionTransport sessions) addr (NetCrypto pkt) loop -- launch ping thread fuzz <- randomRIO (0,2000) pingMachine <- forkPingMachine ("NetCrypto." ++ show (key2id remotePublicKey)) (15000 + fuzz) 2000 -- update session with thread ids let netCryptoSession = netCryptoSession0 {ncDequeueThread=Just threadid, ncPingMachine=Just pingMachine} -- add this session to the lookup maps atomically $ do modifyTVar allsessions (Map.insert addr netCryptoSession) byKeyResult <- readTVar allsessionsByKey >>= return . Map.lookup remotePublicKey case byKeyResult of Nothing -> modifyTVar allsessionsByKey (Map.insert remotePublicKey [netCryptoSession]) Just xs -> modifyTVar allsessionsByKey (Map.insert remotePublicKey (netCryptoSession:xs)) -- run announceNewSessionHooks hooks <- atomically $ readTVar (announceNewSessionHooks sessions) flip fix (hooks,netCryptoSession) $ \loop (hooks,session) -> case hooks of [] -> return () (h:hs) -> do r <- h Nothing session case r of Just f -> loop (hs, f session) Nothing -> return () -- | Called when we get a handshake, but there's already a session entry. updateCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> NetCryptoSession -> IO () updateCryptoSession sessions addr hp session = do ncState0 <- atomically $ readTVar (ncState session) ncTheirBaseNonce0 <- atomically $ readTVar (ncTheirBaseNonce session) if (ncState0 >= Accepted) -- 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 when ( Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp -- XXX: Do we really want to compare base nonce here? || ncTheirDHTKey session /= hpCookieRemoteDhtkey hp ) $ freshCryptoSession sessions addr hp else if ( Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp) then freshCryptoSession sessions addr hp -- basenonce mismatch, trigger refresh else atomically $ writeTVar (ncState session) Accepted cryptoNetHandler :: NetCryptoSessions -> SockAddr -> NetCrypto -> IO (Maybe (NetCrypto -> NetCrypto)) cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) nonce24 encrypted)) = do hPutStrLn stderr ("RECIEVED HANDSHAKE from " ++ show addr) -- Handle Handshake Message let crypto = transportCrypto sessions allsessions = netCryptoSessions sessions anyRight [] f = return $ Left "missing key" anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right) seckeys <- map fst <$> atomically (readTVar (userKeys crypto)) symkey <- atomically $ transportSymmetric crypto now <- getPOSIXTime lr <- fmap join . sequence $ do -- Either Monad -- TODO: XXX: FIXME: -- The following call to decryptSymmetric is failing every time, -- including when uTox tries to connect -- Possibly my cookies are backwards? (CookieData cookieTime remotePubkey remoteDhtkey) <- (decodePlain =<< decryptSymmetric symkey n24 ecookie) Right $ do -- IO Monad decrypted <- anyRight seckeys $ \key -> do secret <- lookupSharedSecret crypto key remotePubkey nonce24 return $ (key,) <$> (decodePlain =<< decrypt secret encrypted) return $ do -- Either Monad (key,HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted -- check cookie time < 15 seconds ago guard (now - fromIntegral cookieTime < 15) -- cookie hash is valid? sha512 of ecookie let hinit = hashInit hctx = hashUpdate hinit n24 hctx' = hashUpdate hctx ecookie digest = hashFinalize hctx' guard (cookieHash == digest) -- known friend? -- todo TODO, see Roster.hs, -- talk to not yet existent Network-Manager to ascertain current permissions return HParam { hpTheirBaseNonce = Just baseNonce , hpOtherCookie = otherCookie , hpTheirSessionKeyPublic = sessionKey , hpMySecretKey = key , hpCookieRemotePubkey = remotePubkey , hpCookieRemoteDhtkey = remoteDhtkey } case lr of Left s -> hPutStrLn stderr ("cryptoNetHandler: " ++ s) Right hp@(HParam { hpTheirBaseNonce = Just theirBaseNonce , hpOtherCookie = otherCookie , hpTheirSessionKeyPublic = theirSessionKey , hpMySecretKey = key , hpCookieRemotePubkey = remotePublicKey , hpCookieRemoteDhtkey = remoteDhtPublicKey }) -> do sessionsmap <- atomically $ readTVar allsessions -- Do a lookup, so we can handle the update case differently case Map.lookup addr sessionsmap of Nothing -> freshCryptoSession sessions addr hp -- create new session Just session -> updateCryptoSession sessions addr hp session -- update existing session return Nothing cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do let crypto = transportCrypto sessions allsessions = netCryptoSessions sessions sessionsmap <- atomically $ readTVar allsessions -- Handle Encrypted Message case Map.lookup addr sessionsmap of Nothing -> return Nothing -- drop packet, we have no session Just session@(NCrypto { ncIncomingTypeArray, ncState, ncPacketQueue, ncHooks, ncSessionSecret, ncTheirSessionPublic, ncTheirBaseNonce, ncPingMachine}) -> do theirBaseNonce <- atomically $ readTVar ncTheirBaseNonce -- Try to decrypt message let diff :: Word16 diff = nonce16 - fromIntegral (last2Bytes theirBaseNonce) -- truncating to Word16 tempNonce = addtoNonce24 theirBaseNonce (fromIntegral diff) -- expanding to Word lr <- fmap join $ sequence $ do -- Either Monad -- pubkey <- maybeToEither ncTheirSessionPublic Right $ do -- IO Monad secret <- lookupSharedSecret crypto ncSessionSecret pubkey tempNonce return $ decodePlain =<< decrypt secret encrypted case lr of Left _ -> 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 y <- readTVar ncTheirBaseNonce let x = addtoNonce24 y (fromIntegral dATA_NUM_THRESHOLD) writeTVar ncTheirBaseNonce y -- then set session confirmed, atomically $ writeTVar ncState Confirmed -- 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 atomically $ PQ.observeOutOfBand ncPacketQueue bufferEnd runCryptoHook session (bufferData cd) else do atomically $ PQ.enqueue ncPacketQueue bufferEnd cd return Nothing where last2Bytes :: Nonce24 -> Word last2Bytes (Nonce24 bs) = case S.decode (B.drop 22 bs) of Right n -> n _ -> error "unreachable-last2Bytes" dATA_NUM_THRESHOLD = 21845 -- = 65535 / 3 runCryptoHook :: NetCryptoSession -> CryptoMessage -> IO (Maybe (x -> x)) runCryptoHook session@(NCrypto {ncState, ncHooks,ncSessionSecret,ncTheirSessionPublic,ncTheirBaseNonce,ncIncomingTypeArray}) cm {-cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm})-} = do hookmap <- atomically $ readTVar ncHooks -- run hook flip fix (cm,hookmap) $ \lookupAgain (cm,hookmap) -> do msgTypes <- atomically $ readTVar ncIncomingTypeArray let msgTyp = cm ^. messageType msgTypMapped64 = msgTypes A.! fromEnum8 (msgID cm) msgTypMapped = fromWord64 $ msgTypMapped64 if msgTypMapped64 == 0 then return Nothing else case Map.lookup msgTypMapped hookmap of Nothing -> do -- no recognizing hook, run ncUnrecognizedHook0, loopAgain on result unrecognize <- atomically $ readTVar (ncUnrecognizedHook session) mbConsume <- unrecognize msgTypMapped session cm case mbConsume of Just f -> do -- ncUnrecognizedHook0 may have updated the hookmap hookmap' <- atomically $ readTVar ncHooks lookupAgain (f cm,hookmap') Nothing -> return Nothing Just hooks -> flip fix (hooks,cm,msgTypMapped) $ \loop (hooks,cm,typ) -> do let _ = cm :: CryptoMessage case (hooks,cm) of ([],_) -> return Nothing (hook:more,cd) -> do r <- hook session cm :: IO (Maybe (CryptoMessage -> CryptoMessage)) case r of Just f -> let newcd = f cd newtyp = newcd ^. messageType in if newtyp == typ then loop (more,newcd,newtyp) else lookupAgain (newcd,hookmap) Nothing -> return Nothing -- message consumed -- | construct a 'MsgTypeArray' for specified types, using their known common positions -- in the MessageId space if they have such a thing. mkMsgTypes :: [MessageType] -> MsgTypeArray mkMsgTypes msgs = let zeros = A.listArray (0,255) (replicate 256 0) in zeros A.// map (\x -> (toIndex x,toWord64 x)) msgs where toIndex (Msg mid) = fromIntegral . fromEnum $ mid toIndex (GrpMsg KnownLossless nam) = 0x63 -- fromEnum MESSAGE_GROUPCHAT toIndex (GrpMsg KnownLossy nam) = 0xC7 -- fromEnum LOSSY_GROUPCHAT -- | Handle all Tox messages that this code base is aware of. -- The first parameter is a function which is applied to get the values -- for keys of unknown nature. Could be either 'id' or 'const 0' allMsgTypes :: (Word64 -> Word64) -> MsgTypeArray allMsgTypes fDefault = A.listArray (minBound,maxBound) (0:knownMsgs) where knownMsgs :: [Word64] knownMsgs = concat [ map (fromIntegral . fromEnum) [ PacketRequest .. KillPacket ] , map (const 0) [ 3 .. 15 ] -- UnspecifiedPacket , map (const 0) [ 16 .. 23 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ ONLINE .. OFFLINE ] , map (const 0) [ 26 .. 47 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ NICKNAME .. TYPING ] , map (const 0) [ 52 .. 63 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ MESSAGE .. ACTION ] , map (const 0) [ 66 .. 68 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ MSI ] , map (const 0) [ 70 .. 79 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ FILE_SENDREQUEST .. FILE_DATA ] , map (const 0) [ 83 .. 95 ] -- MessengerLoseless , map (fromIntegral . fromEnum) [ INVITE_GROUPCHAT .. MESSAGE_GROUPCHAT ] , map (const 0) [ 100 .. 191 ] -- MessengerLoseless , map (const 0) [ 192 .. 198 ] -- MessengerLossy , map (fromIntegral . fromEnum) [ LOSSY_GROUPCHAT ] , map (const 0) [ 200 .. 255 ] -- All lossy, exept the last ] sendCrypto :: TransportCrypto -> NetCryptoSession -> (STM ()) -> CryptoMessage -> IO (Either String ()) sendCrypto crypto session updateLocal cm = do let outq = ncOutgoingQueue session -- XXX: potential race? if shared secret comes out of sync with cache? getOutGoingParam <- PQ.readyOutGoing outq atomically $ do result <- PQ.tryAppendQueueOutgoing getOutGoingParam outq cm case result of PQ.OGSuccess -> updateLocal >> return (Right()) PQ.OGFull -> return (Left "Outgoing packet buffer is full") PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet") sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) sendOnline crypto session = sendCrypto crypto session (return ()) (OneByte ONLINE) sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) sendOffline crypto session = sendCrypto crypto session (return ()) (OneByte OFFLINE) sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) sendKill crypto session = do let cm=OneByte KillPacket addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session (return ()) cm setNick :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) setNick crypto session nick = do let Just (_,maxlen) = msgSizeParam NICKNAME if B.length nick > maxlen then return (Left $ "nickname must not exceed " ++ show maxlen ++ " bytes.") else do let updateLocal = do let viewVar = ncView session view <- readTVar viewVar writeTVar (svNick view) nick let cm = UpToN NICKNAME nick addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session updateLocal cm setTyping :: TransportCrypto -> NetCryptoSession -> TypingStatus -> IO (Either String ()) setTyping crypto session status = do let updateLocal = do view <- readTVar (ncView session) writeTVar (svTyping view) status let cm = TwoByte TYPING (fromEnum8 status) addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session updateLocal cm setNoSpam :: TransportCrypto -> NetCryptoSession -> Maybe NoSpam -> IO (Either String ()) setNoSpam crypto session mbnospam = do let viewVar = ncView session atomically $ do view <- readTVar viewVar writeTVar (svNoSpam view) mbnospam return (Right ()) setStatus :: TransportCrypto -> NetCryptoSession -> UserStatus -> IO (Either String ()) setStatus crypto session status = do let updateLocal = do view <- readTVar (ncView session) writeTVar (svStatus view) status let cm = TwoByte USERSTATUS (fromEnum8 status) addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session updateLocal cm setStatusMsg :: TransportCrypto -> NetCryptoSession -> ByteString -> IO (Either String ()) setStatusMsg crypto session msg = do let Just (_,maxlen) = msgSizeParam STATUSMESSAGE if B.length msg > maxlen then return (Left $ "status message must not exceed " ++ show maxlen ++ " bytes.") else do let updateLocal = do view <- readTVar (ncView session) writeTVar (svStatusMsg view) msg let cm = UpToN STATUSMESSAGE msg addMsgToLastN False (cm ^. messageType) session (Out cm) sendCrypto crypto session updateLocal cm -- | 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 msgNumVar = ncMsgNumVar session dropCntVar = ncDropCntVar session atomically $ do num <- readTVar msgNumVar view <- readTVar (ncView session) snapshot <- viewSnapshot view (wraps,offset) <- PQ.enqueue lastNQ num (handledFlg,(snapshot,cm)) capacity <- PQ.getCapacity lastNQ let dropped = wraps * capacity + offset modifyTVar' msgNumVar (+1) writeTVar dropCntVar dropped -- | 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