From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: Factor out some new libraries word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search --- src/Network/Tox/AggregateSession.hs | 374 ------------- src/Network/Tox/Avahi.hs | 65 --- src/Network/Tox/ContactInfo.hs | 172 ------ src/Network/Tox/Crypto/Transport.hs | 1029 ----------------------------------- src/Network/Tox/DHT/Handlers.hs | 573 ------------------- src/Network/Tox/DHT/Transport.hs | 460 ---------------- src/Network/Tox/Handshake.hs | 125 ----- src/Network/Tox/NodeId.hs | 731 ------------------------- src/Network/Tox/Onion/Handlers.hs | 369 ------------- src/Network/Tox/Onion/Transport.hs | 119 ---- src/Network/Tox/Relay.hs | 235 -------- src/Network/Tox/Session.hs | 243 --------- src/Network/Tox/TCP.hs | 313 ----------- src/Network/Tox/Transport.hs | 86 --- 14 files changed, 4894 deletions(-) delete mode 100644 src/Network/Tox/AggregateSession.hs delete mode 100644 src/Network/Tox/Avahi.hs delete mode 100644 src/Network/Tox/ContactInfo.hs delete mode 100644 src/Network/Tox/Crypto/Transport.hs delete mode 100644 src/Network/Tox/DHT/Handlers.hs delete mode 100644 src/Network/Tox/DHT/Transport.hs delete mode 100644 src/Network/Tox/Handshake.hs delete mode 100644 src/Network/Tox/NodeId.hs delete mode 100644 src/Network/Tox/Onion/Handlers.hs delete mode 100644 src/Network/Tox/Onion/Transport.hs delete mode 100644 src/Network/Tox/Relay.hs delete mode 100644 src/Network/Tox/Session.hs delete mode 100644 src/Network/Tox/TCP.hs delete mode 100644 src/Network/Tox/Transport.hs (limited to 'src/Network/Tox') diff --git a/src/Network/Tox/AggregateSession.hs b/src/Network/Tox/AggregateSession.hs deleted file mode 100644 index 8c728660..00000000 --- a/src/Network/Tox/AggregateSession.hs +++ /dev/null @@ -1,374 +0,0 @@ --- | This module aggregates all sessions to the same remote Tox contact into a --- single online/offline presence. This allows multiple lossless links to the --- same identity at different addresses, or even to the same address. -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -module Network.Tox.AggregateSession - ( AggregateSession - , newAggregateSession - , aggregateStatus - , checkCompatible - , compatibleKeys - , AddResult(..) - , addSession - , DelResult(..) - , delSession - , closeAll - , awaitAny - , dispatchMessage - ) where - - -import Control.Concurrent.STM -import Control.Concurrent.STM.TMChan -import Control.Monad -import Data.Dependent.Sum -import Data.Function -import qualified Data.IntMap.Strict as IntMap - ;import Data.IntMap.Strict (IntMap) -import Data.List -import Data.Time.Clock.POSIX -import System.IO.Error - -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -import GHC.Conc (labelThread) -#endif - -import Connection (Status (..)) -import Crypto.Tox (PublicKey, toPublic) -import Data.Tox.Msg -import Data.Wrapper.PSQInt as PSQ -import DPut -import DebugTag -import Network.QueryResponse -import Network.Tox.Crypto.Transport -import Network.Tox.DHT.Transport (key2id) -import Network.Tox.NodeId (ToxProgress (..)) -import Network.Tox.Session - --- | For each component session, we track the current status. -data SingleCon = SingleCon - { singleSession :: Session -- ^ A component session. - , singleStatus :: TVar (Status ToxProgress) -- ^ Either 'AwaitingSessionPacket' or 'Established'. - } - --- | A collection of sessions between the same local and remote identities. -data AggregateSession = AggregateSession - { -- | The set of component sessions indexed by their ID. - contactSession :: TVar (IntMap SingleCon) - -- | Each inbound packets is written to this channel with the session ID - -- from which it came originally. - , contactChannel :: TMChan (Int,CryptoMessage) - -- | The set of 'Established' sessions IDs. - , contactEstablished :: TVar (IntMap ()) - -- | Callback for state-change notifications. - , notifyState :: AggregateSession -> Session -> Status ToxProgress -> STM () - } - - --- | Create a new empty aggregate session. The argument is a callback to --- receive notifications when the new session changes status. There are three --- possible status values: --- --- [ Dormant ] - No pending or established sessions. --- --- [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are --- fully established. --- --- [ Established ] - At least one session is fully established and we can --- send and receive packets via this aggregate. --- --- The 'Session' object is provided to the callback so that it can determine the --- current remote and local identities for this AggregateSession. It may not even --- be Established, so do not use it to send or receive packets. -newAggregateSession :: (AggregateSession -> Session -> Status ToxProgress -> STM ()) - -> STM AggregateSession -newAggregateSession notify = do - vimap <- newTVar IntMap.empty - chan <- newTMChan - vemap <- newTVar IntMap.empty - return AggregateSession - { contactSession = vimap - , contactChannel = chan - , contactEstablished = vemap - , notifyState = notify - } - --- | Information returned from 'addSession'. Note that a value other than --- 'RejectedSession' does not mean there is any 'Established' session in the --- Aggregate. Sessions are in 'AwaitingSessionPacket' state until a single --- packet is received from the remote end. -data AddResult = FirstSession -- ^ Initial connection with this contact. - | AddedSession -- ^ Added another connection to active session. - | RejectedSession -- ^ Failed to add session (wrong contact / closed session). - --- | The 'keepAlive' thread juggles three scheduled tasks. -data KeepAliveEvents = DoTimeout -- ^ A session timed-out, close it. - | DoAlive -- ^ Send a the keep-alive becon for a session. - | DoRequestMissing -- ^ Detect and request lost packets. - deriving Enum - --- | This call loops until the provided sesison is closed or times out. It --- monitors the provided (non-empty) priority queue for scheduled tasks (see --- 'KeepAliveEvents') to perform for the connection. -keepAlive :: Session -> TVar (PSQ POSIXTime) -> IO () -keepAlive s q = do - myThreadId >>= flip labelThread - (intercalate "." ["beacon" - , take 8 $ show $ key2id $ sTheirUserKey s - , show $ sSessionID s]) - - let -- outPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e - unexpected e = dput XUnexpected $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e - - doAlive = do - -- outPrint $ "Beacon" - sendMessage (sTransport s) () (Pkt ALIVE ==> ()) - - doRequestMissing = do - (ns,nmin) <- sMissingInbound s - -- outPrint $ "PacketRequest " ++ show (nmin,ns) - sendMessage (sTransport s) () (Pkt PacketRequest ==> MissingPackets ns) - `catchIOError` \e -> do - unexpected $ "PacketRequest " ++ take 200 (show (nmin,length ns,ns)) - unexpected $ "PacketRequest: " ++ show e - -- Quit thread by scheduling a timeout event. - now <- getPOSIXTime - atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) now - - re tm again e io = do - io - atomically $ modifyTVar' q $ PSQ.insert (fromEnum e) tm - again - - doEvent again now e = case e of - DoTimeout -> do dput XNetCrypto $ "TIMEOUT: " ++ show (sSessionID s) - sClose s - DoAlive -> re (now + 10) again e doAlive - DoRequestMissing -> re (now + 5) again e doRequestMissing -- tox-core does this at 1 second intervals - - fix $ \again -> do - - now <- getPOSIXTime - join $ atomically $ do - PSQ.findMin <$> readTVar q >>= \case - Nothing -> error "keepAlive: unexpected empty PSQ." - Just ( k :-> tm ) -> - return $ if now < tm then threadDelay (toMicroseconds $ tm - now) >> again - else doEvent again now (toEnum k) - - --- | This function forks two threads: the 'keepAlive' beacon-sending thread and --- a thread to read all packets from the provided 'Session' and forward them to --- 'contactChannel' for a containing 'AggregateSession' -forkSession :: AggregateSession -> Session -> (Status ToxProgress -> STM ()) -> IO ThreadId -forkSession c s setStatus = forkIO $ do - myThreadId >>= flip labelThread - (intercalate "." ["s" - , take 8 $ show $ key2id $ sTheirUserKey s - , show $ sSessionID s]) - - q <- atomically $ newTVar $ fromList - [ fromEnum DoAlive :-> 0 - , fromEnum DoRequestMissing :-> 0 - ] - - let sendPacket :: CryptoMessage -> STM () - sendPacket msg = writeTMChan (contactChannel c) (sSessionID s, msg) - - inPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " --> " ++ e - - bump = do - -- inPrint $ "BUMP: " ++ show (sSessionID s) - now <- getPOSIXTime - atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) (now + 15) - - onPacket body loop Nothing = return () - onPacket body loop (Just (Left e)) = inPrint e >> loop - onPacket body loop (Just (Right x)) = body loop x - - awaitPacket body = fix $ awaitMessage (sTransport s) . onPacket body - - atomically $ setStatus $ InProgress AwaitingSessionPacket - awaitPacket $ \_ (online,()) -> do - when (msgID online /= M ONLINE) $ do - inPrint $ "Unexpected initial packet: " ++ show (msgID online) - atomically $ do setStatus Established - sendPacket online - bump - beacon <- forkIO $ keepAlive s q - awaitPacket $ \awaitNext (x,()) -> do - bump - case msgID x of - M ALIVE -> return () - M KillPacket -> sClose s - _ -> atomically $ sendPacket x - awaitNext - atomically $ setStatus Dormant - killThread beacon - --- | Add a new session (in 'AwaitingSessionPacket' state) to the --- 'AggregateSession'. If the supplied session is not compatible because it is --- between the wrong ToxIDs or because the AggregateSession is closed, --- 'RejectedSession' will be returned. Otherwise, the operation is successful. --- --- The status-change callback may be triggered by this call as the aggregate --- may transition from 'Dormant' (empty) to 'AwaitingSessionPacket' (at least --- one active session). -addSession :: AggregateSession -> Session -> IO AddResult -addSession c s = do - (result,mcon,replaced) <- atomically $ do - let them = sTheirUserKey s - me = toPublic $ sOurKey s - compat <- checkCompatible me them c - let result = case compat of - Nothing -> FirstSession - Just True -> AddedSession - Just False -> RejectedSession - case result of - RejectedSession -> return (result,Nothing,Nothing) - _ -> do - statvar <- newTVar Dormant - imap <- readTVar (contactSession c) - let con = SingleCon s statvar - s0 = IntMap.lookup (sSessionID s) imap - imap' = IntMap.insert (sSessionID s) con imap - writeTVar (contactSession c) imap' - return (result,Just con,s0) - - mapM_ (sClose . singleSession) replaced - forM_ mcon $ \con -> - forkSession c s $ \progress -> do - writeTVar (singleStatus con) progress - emap <- readTVar (contactEstablished c) - emap' <- case progress of - Established -> do - when (IntMap.null emap) $ notifyState c c s Established - return $ IntMap.insert (sSessionID s) () emap - _ -> do - let emap' = IntMap.delete (sSessionID s) emap - when (IntMap.null emap' && not (IntMap.null emap)) $ do - imap <- readTVar (contactSession c) - notifyState c c s - $ if IntMap.null imap then Dormant - else InProgress AwaitingSessionPacket - return emap' - writeTVar (contactEstablished c) emap' - return result - --- | Information returned from 'delSession'. -data DelResult = NoSession -- ^ Contact is completely disconnected. - | DeletedSession -- ^ Connection removed but session remains active. - --- | Close and remove the componenent session corresponding to the provided --- Session ID. --- --- The status-change callback may be triggered as the aggregate may may --- transition to 'Dormant' (empty) or 'AwaitingSessionPacket' (if the last --- 'Established' session is closed). -delSession :: AggregateSession -> Int -> IO DelResult -delSession c sid = do - (con, r) <- atomically $ do - imap <- readTVar (contactSession c) - emap <- readTVar (contactEstablished c) - let emap' = IntMap.delete sid emap - imap' = IntMap.delete sid imap - case IntMap.toList emap of - (sid0,_):_ | IntMap.null emap' - , let s = singleSession $ imap IntMap.! sid0 - -> notifyState c c s - $ if IntMap.null imap' then Dormant - else InProgress AwaitingSessionPacket - _ -> return () - writeTVar (contactSession c) imap' - writeTVar (contactEstablished c) emap' - return ( IntMap.lookup sid imap, IntMap.null imap') - mapM_ (sClose . singleSession) con - return $ if r then NoSession - else DeletedSession - --- | Send a packet to one or all of the component sessions in the aggregate. -dispatchMessage :: AggregateSession -> Maybe Int -- ^ 'Nothing' to broadcast, otherwise SessionID. - -> CryptoMessage -> IO () -dispatchMessage c msid msg = join $ atomically $ do - imap <- readTVar (contactSession c) - let go = case msid of Nothing -> forM_ imap - Just sid -> forM_ (IntMap.lookup sid imap) - return $ go $ \con -> sendMessage (sTransport $ singleSession con) () msg - --- | Retry until: --- --- * a packet arrives (with component session ID) arrives. --- --- * the 'AggregateSession' is closed with 'closeAll'. -awaitAny :: AggregateSession -> STM (Maybe (Int,CryptoMessage)) -awaitAny c = readTMChan (contactChannel c) - --- | Close all connections associated with the aggregate. No new sessions will --- be accepted after this, and the notify callback will be informed that we've --- transitioned to 'Dormant'. -closeAll :: AggregateSession -> IO () -closeAll c = join $ atomically $ do - imap <- readTVar (contactSession c) - closeTMChan (contactChannel c) - return $ forM_ (IntMap.keys imap) $ \sid -> delSession c sid - --- | Query the current status of the aggregate, there are three possible --- values: --- --- [ Dormant ] - No pending or established sessions. --- --- [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are --- fully established. --- --- [ Established ] - At least one session is fully established and we can --- send and receive packets via this aggregate. --- -aggregateStatus :: AggregateSession -> STM (Status ToxProgress) -aggregateStatus c = do - isclosed <- isClosedTMChan (contactChannel c) - imap <- readTVar (contactSession c) - emap <- readTVar (contactEstablished c) - return $ case () of - _ | isclosed -> Dormant - | not (IntMap.null emap) -> Established - | not (IntMap.null imap) -> InProgress AwaitingSessionPacket - | otherwise -> Dormant - --- | Query whether the supplied ToxID keys are compatible with this aggregate. --- --- [ Nothing ] Any keys would be compatible because there is not yet any --- sessions in progress. --- --- [ Just True ] The supplied keys match the session in progress. --- --- [ Just False ] The supplied keys are incompatible. -checkCompatible :: PublicKey -- ^ Local Tox key (for which we know the secret). - -> PublicKey -- ^ Remote Tox key. - -> AggregateSession -> STM (Maybe Bool) -checkCompatible me them c = do - isclosed <- isClosedTMChan (contactChannel c) - imap <- readTVar (contactSession c) - return $ case IntMap.elems imap of - _ | isclosed -> Just False -- All keys are incompatible (closed). - con:_ -> Just $ sTheirUserKey (singleSession con) == them - && toPublic (sOurKey $ singleSession con) == me - [] -> Nothing - --- | Returns the local and remote keys that are compatible with this aggregate. --- If 'Nothing' Is returned, then either no key is compatible ('closeAll' was --- called) or all keys are compatible because no sessions have been associated. -compatibleKeys :: AggregateSession -> STM (Maybe (PublicKey,PublicKey)) -compatibleKeys c = do - isclosed <- isClosedTMChan (contactChannel c) - imap <- readTVar (contactSession c) - return $ case IntMap.elems imap of - _ | isclosed -> Nothing -- none. - con:_ -> Just ( toPublic (sOurKey $ singleSession con) - , sTheirUserKey (singleSession con)) - [] -> Nothing -- any. diff --git a/src/Network/Tox/Avahi.hs b/src/Network/Tox/Avahi.hs deleted file mode 100644 index 635ba656..00000000 --- a/src/Network/Tox/Avahi.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -module Network.Tox.Avahi - ( module Network.Tox.Avahi - , NodeInfo(..) - , NodeId - ) where - -import Control.Applicative -import Data.Foldable -import Network.Address -import Network.Avahi -import Network.BSD (getHostName) -import Network.Tox.NodeId -import Text.Read - -toxServiceName :: String -toxServiceName = "_tox_dht._udp" - -toxServiceDomain :: String -toxServiceDomain = "local" - -(<.>) :: String -> String -> String -a <.> b = a ++ "." ++ b - -toxService :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> Service -toxService hostname (fromIntegral -> port) dhtkey toxid = - Service { - serviceProtocol = PROTO_UNSPEC, - serviceName = "Tox DHT @ " ++ hostname, - serviceType = toxServiceName, - serviceDomain = toxServiceDomain, - serviceHost = if null hostname then "" else hostname <.> toxServiceDomain, - serviceAddress = Nothing, - servicePort = port, - serviceText = maybe (show dhtkey) (show . ((,) dhtkey)) toxid - } - -announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> IO () -announceToxServiceWithHostname = (boobs.boobs) announce toxService - where boobs = ((.).(.)) - -announceToxService :: PortNumber -> NodeId -> (Maybe NodeId) -> IO () -announceToxService a b c = do - h <- getHostName - announceToxServiceWithHostname h a b c - -queryToxService :: (NodeInfo -> Maybe NodeId -> IO ()) -> IO () -queryToxService cb = - browse $ - BrowseQuery - { lookupProtocol = PROTO_UNSPEC - , lookupServiceName = toxServiceName - , lookupDomain = toxServiceDomain - , lookupCallback = runCallback - } - where - runCallback Service {..} = do - let both :: Maybe (NodeId, NodeId) - both = readMaybe serviceText - nid = (fst <$> both) <|> readMaybe serviceText - addr = readMaybe =<< serviceAddress - p = fromIntegral servicePort - forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p) (snd <$> both) diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs deleted file mode 100644 index e7cb48c1..00000000 --- a/src/Network/Tox/ContactInfo.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE LambdaCase #-} -module Network.Tox.ContactInfo where - -import Connection - -import Data.Time.Clock.POSIX -import Control.Concurrent.STM -import Control.Monad -import Crypto.PubKey.Curve25519 -import qualified Data.HashMap.Strict as HashMap - ;import Data.HashMap.Strict (HashMap) -import Data.Maybe -import Network.Tox.DHT.Transport as DHT -import Network.Tox.NodeId (id2key) -import Network.Tox.Onion.Transport as Onion -import DPut -import DebugTag - -newtype ContactInfo extra = ContactInfo - -- | Map our toxid public key to an Account record. - { accounts :: TVar (HashMap NodeId{-my userkey-} (Account extra)) - } - -data Account extra = Account - { userSecret :: SecretKey -- local secret key - , contacts :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info - , accountExtra :: TVar extra - , eventChan :: TChan ContactEvent - } - -data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData } - | PolicyChange { contact :: PublicKey, policyChange :: Policy } - | AddrChange { contact :: PublicKey, addrChange :: NodeInfo } - | SessionEstablished { contact :: PublicKey } - | SessionTerminated { contact :: PublicKey } - -data Contact = Contact - { contactKeyPacket :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey)) - , contactLastSeenAddr :: TVar (Maybe (POSIXTime,NodeInfo)) - , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest)) - , contactPolicy :: TVar (Maybe Connection.Policy) - } - -newContactInfo :: IO (ContactInfo extra) -newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty - -myKeyPairs :: ContactInfo extra -> STM [(SecretKey,PublicKey)] -myKeyPairs (ContactInfo accounts) = do - acnts <- readTVar accounts - forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do - return (userSecret,id2key nid) - -updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO () -updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do - dput XMisc "updateContactInfo!!!" - now <- getPOSIXTime - atomically $ do - as <- readTVar (accounts roster) - maybe (return ()) - (updateAccount now remoteUserKey omsg) - $ HashMap.lookup (key2id localUserKey) as - -initContact :: STM Contact -initContact = Contact <$> newTVar Nothing - <*> newTVar Nothing - <*> newTVar Nothing - <*> newTVar Nothing - -getContact :: PublicKey -> Account extra -> STM (Maybe Contact) -getContact remoteUserKey acc = do - let rkey = key2id remoteUserKey - cmap <- readTVar (contacts acc) - return $ HashMap.lookup rkey cmap - -updateAccount' :: PublicKey -> Account extra -> (Contact -> STM ()) -> STM () -updateAccount' remoteUserKey acc updater = do - let rkey = key2id remoteUserKey - cmap <- readTVar (contacts acc) - contact <- case HashMap.lookup rkey cmap of - Just contact -> return contact - Nothing -> do contact <- initContact - writeTVar (contacts acc) $ HashMap.insert rkey contact cmap - return contact - updater contact - -updateAccount :: POSIXTime -> PublicKey -> Onion.OnionData -> Account extra -> STM () -updateAccount now remoteUserKey omsg acc = do - updateAccount' remoteUserKey acc $ onionUpdate now omsg - writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg - -onionUpdate :: POSIXTime -> OnionData -> Contact -> STM () -onionUpdate now (Onion.OnionDHTPublicKey dhtpk) contact - = writeTVar (contactKeyPacket contact) $ Just (now,dhtpk) -onionUpdate now (Onion.OnionFriendRequest fr) contact - = writeTVar (contactFriendRequest contact) $ Just (now,fr) - -policyUpdate :: Policy -> Contact -> STM () -policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy - -addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM () -addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr) - -setContactPolicy :: PublicKey -> Policy -> Account extra -> STM () -setContactPolicy remoteUserKey policy acc = do - updateAccount' remoteUserKey acc $ policyUpdate policy - writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy - -setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM () -setContactAddr now remoteUserKey addr acc = do - contact <- getContact remoteUserKey acc - let update = updateAccount' remoteUserKey acc $ addrUpdate now addr - let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr - join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case - Just (_, a) | addr == a -> update -- updates time only - Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old - Nothing -> update >> notify -- or if we don't have any - _ -> return () -- otherwise just wait - -setEstablished :: PublicKey -> Account extra -> STM () -setEstablished remoteUserKey acc = - writeTChan (eventChan acc) $ SessionEstablished remoteUserKey - -setTerminated :: PublicKey -> Account extra -> STM () -setTerminated remoteUserKey acc = - writeTChan (eventChan acc) $ SessionTerminated remoteUserKey - - -addContactInfo :: ContactInfo extra -> SecretKey -> extra -> STM () -addContactInfo (ContactInfo as) sk extra = do - a <- newAccount sk extra - modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a - -delContactInfo :: ContactInfo extra -> PublicKey -> STM () -delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk) - -newAccount :: SecretKey -> extra -> STM (Account extra) -newAccount sk extra = Account sk <$> newTVar HashMap.empty - <*> newTVar extra - <*> newBroadcastTChan - -dnsPresentation :: ContactInfo extra -> STM String -dnsPresentation (ContactInfo accsvar) = do - accs <- readTVar accsvar - ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do - cs <- readTVar cvar - rs <- forM (HashMap.toList cs) $ \(nid,c) -> do - mkpkt <- readTVar (contactKeyPacket c) - return $ fmap (\(_,d) -> (nid,d)) mkpkt - return $ - "; local key = " ++ show (key2id $ toPublic sec) ++ "\n" - ++ concatMap dnsPresentation1 (catMaybes rs) - return $ concat ms - -dnsPresentation1 :: (NodeId,DHTPublicKey) -> String -dnsPresentation1 (nid,dk) = unlines - [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ] - ] - -type LocalKey = NodeId -type RemoteKey = NodeId - -friendRequests :: ContactInfo extra -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)]) -friendRequests (ContactInfo roster) = do - accs <- readTVar roster - forM accs $ \Account { userSecret = sec, contacts = cvar } -> do - cs <- readTVar cvar - rs <- forM (HashMap.toList cs) $ \(nid,c) -> do - mfr <- readTVar (contactFriendRequest c) - return $ fmap (\(_,x) -> (nid,x)) mfr - return $ catMaybes rs - diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs deleted file mode 100644 index a18b550d..00000000 --- a/src/Network/Tox/Crypto/Transport.hs +++ /dev/null @@ -1,1029 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -module Network.Tox.Crypto.Transport - ( showCryptoMsg - , parseCrypto - , encodeCrypto - , unpadCryptoMsg - , decodeRawCryptoMsg - , parseHandshakes - , encodeHandshakes - , CryptoData(..) - , CryptoMessage(..) - , MessageName(..) - , CryptoPacket(..) - , HandshakeData(..) - , Handshake(..) - , PeerInfo(..) - , UserStatus(..) - , TypingStatus(..) - , GroupChatId(..) - , MessageType(..) - , isKillPacket, isOFFLINE - , KnownLossyness(..) - , AsWord16(..) - , AsWord64(..) - -- feild name classes - , HasGroupChatID(..) - , HasGroupNumber(..) - , HasPeerNumber(..) - , HasMessageNumber(..) - , HasMessageName(..) - , HasMessageData(..) - , HasName(..) - , HasTitle(..) - , HasMessage(..) - , HasMessageType(..) - -- lenses -#ifdef USE_lens - , groupNumber, groupNumberToJoin, peerNumber, messageNumber - , messageName, messageData, name, title, message, messageType -#endif - -- constructor - -- utils - , sizedN - , sizedAtLeastN - , isIndirectGrpChat - , fromEnum8 - , fromEnum16 - , toEnum8 - , getCryptoMessage - , putCryptoMessage - ) where - -import Crypto.Tox -import Data.Tox.Msg -import Network.Tox.DHT.Transport (Cookie) -import Network.Tox.NodeId -import DPut -import DebugTag -import Data.PacketBuffer as PB - -import Network.Socket -import Data.ByteArray -import Data.Dependent.Sum - -import Control.Monad -import Data.ByteString as B -import Data.Function -import Data.Maybe -import Data.Monoid -import Data.Word -import Data.Bits -import Crypto.Hash -import Data.Functor.Contravariant -import Data.Functor.Identity -import Data.Text as T -import Data.Text.Encoding as T -import Data.Serialize as S -import Control.Arrow -import GHC.TypeNats - -showCryptoMsg :: Word32 -> CryptoMessage -> [Char] -showCryptoMsg _ msg = show msg - -parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) -parseCrypto (bbs,saddr) = case B.uncons bbs of - Just (0x1b,bs) -> case runGet get bs of - Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet. - Left _ -> Right (bs,saddr) -- Failed parse, strip first byte and pass it on. - _ -> Right (bbs,saddr) -- Type-code mismatch, pass it on. - -encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr) -encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr) - -parseHandshakes :: ByteString -> SockAddr -> Either String (Handshake Encrypted, SockAddr) -parseHandshakes (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseHandshakes: "++) $ (,saddr) <$> runGet get pkt -parseHandshakes bs _ = Left $ "parseHandshakes_: " ++ show (B.unpack $ B.take 1 bs) - -encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr) -encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr) - -{- -createRequestPacket :: Word32 -> [Word32] -> CryptoMessage -createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns) - in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r - where - ys = Prelude.map (subtract (seqno - 1)) xs - reduceToSums [] = [] - reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs) - makeZeroes :: Word32 -> [Word32] - -- makeZeroes 0 = [] - makeZeroes x - = let (d,m)= x `divMod` 255 - zeros= Prelude.replicate (fromIntegral d) 0 - in zeros ++ [m] - ns :: [Word8] - ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes) --} - -data Handshake (f :: * -> *) = Handshake - { -- The cookie is a cookie obtained by - -- sending a cookie request packet to the peer and getting a cookie - -- response packet with a cookie in it. It may also be obtained in the - -- handshake packet by a peer receiving a handshake packet (Other - -- Cookie). - handshakeCookie :: Cookie f - -- The nonce is a nonce used to encrypt the encrypted part of the handshake - -- packet. - , handshakeNonce :: Nonce24 - -- The encrypted part of the handshake packet is encrypted with the long - -- term user-keys of both peers. - , handshakeData :: f HandshakeData - } - -instance Serialize (Handshake Encrypted) where - get = Handshake <$> get <*> get <*> get - put (Handshake cookie n24 dta) = put cookie >> put n24 >> put dta - -data HandshakeData = HandshakeData - { baseNonce :: Nonce24 - -- ^ 24 bytes base nonce, recipient uses this to encrypt packets sent to the one who sent this handshake - -- adding one each time, so it can double as something like an approximate packet number - , sessionKey :: PublicKey - -- ^ session public key of the peer (32 bytes) - -- The recipient of the handshake encrypts using this public key when sending CryptoPackets - , cookieHash :: Digest SHA512 - -- ^ sha512 hash of the entire Cookie sitting outside the encrypted part - -- This prevents a replay attack where a new cookie is inserted into - -- an old valid handshake packet - , otherCookie :: Cookie Encrypted - -- ^ Other Cookie (used by the recipient to respond to the handshake packet) - } - deriving (Eq,Ord,Show) - -instance Sized HandshakeData where - size = contramap baseNonce size - <> contramap (key2id . sessionKey) size - <> ConstSize 64 -- contramap cookieHash size -- missing instance Sized (Digest SHA512) - <> contramap otherCookie size - -instance Serialize HandshakeData where - get = HandshakeData <$> get - <*> getPublicKey - <*> (fromJust . digestFromByteString <$> getBytes 64) - <*> get - put (HandshakeData n k h c) = do - put n - putPublicKey k - putByteString (convert h) - put c - -data CryptoPacket (f :: * -> *) = CryptoPacket - { -- | The last 2 bytes of the nonce used to encrypt 'pktData' - pktNonce :: Word16 - -- The payload is encrypted with the session key and 'baseNonce' set by - -- the receiver in their handshake + packet number (starting at 0, big - -- endian math). - , pktData :: f CryptoData - } - -deriving instance Show (CryptoPacket Encrypted) - -instance Sized CryptoData where - size = contramap bufferStart size - <> contramap bufferEnd size - <> contramap bufferData size - -instance Serialize (CryptoPacket Encrypted) where - get = CryptoPacket <$> get <*> get - put (CryptoPacket n16 dta) = put n16 >> put dta - -data CryptoData = CryptoData - { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)] - bufferStart :: Word32 - -- | [ uint32_t packet number if lossless - -- , sendbuffer buffer_end if lossy , (big endian)] - , bufferEnd :: Word32 - -- | [data] (TODO See Note [Padding]) - , bufferData :: CryptoMessage - } deriving (Eq,Show) - -{- -Note [Padding] - -TODO: The 'bufferData' field of 'CryptoData' should probably be something like -/Padded CryptoMessage/ because c-toxcore strips leading zeros on incoming and -pads leading zeros on outgoing packets. - -After studying c-toxcore (at commit c49a6e7f5bc245a51a3c85cc2c8b7f881c412998), -I've determined the following behavior. - -Incoming: All leading zero bytes are stripped until possibly the whole packet -is consumed (in which case it is discarded). This happens at -toxcore/net_crypto.c:1366:handle_data_packet_core(). - -Outgoing: The number of zeros added is: - - padding_length len = (1373 - len) `mod` 8 where - -where /len/ is the size of the non-padded CryptoMessage. This happens at -toxcore/net_crypto.c:936:send_data_packet_helper() - -The number 1373 is written in C as MAX_CRYPTO_DATA_SIZE which is defined in -terms of the max /NetCrypto/ packet size (1400) minus the minimum possible size -of an id-byte (1) and a /CryptoPacket Encrypted/ ( 2 + 4 + 4 + 16 ). - -One effect of this is that short messages will be padded to at least 5 bytes. --} - -instance Serialize CryptoData where - get = do - ack <- get - seqno <- get - cm <- getCryptoMessage ack - return $ CryptoData ack seqno cm - put (CryptoData ack seqno dta) = do - put ack - put seqno - putCryptoMessage ack dta - -data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum) -instance Serialize TypingStatus where - get = do - x <- get :: Get Word8 - return (toEnum8 x) - put x = put (fromEnum8 x :: Word8) - -unpadCryptoMsg :: CryptoMessage -> CryptoMessage -unpadCryptoMsg msg@(Pkt Padding :=> Identity (Padded bs)) = - let unpadded = B.dropWhile (== msgbyte Padding) bs - in either (const msg) id $ runGet (getCryptoMessage 0) unpadded -unpadCryptoMsg msg = msg - -decodeRawCryptoMsg :: CryptoData -> CryptoMessage -decodeRawCryptoMsg (CryptoData ack seqno cm) = unpadCryptoMsg cm - -instance Sized CryptoMessage where - size = VarSize $ \case - Pkt t :=> Identity x -> case sizeFor t of - ConstSize sz -> 1 + sz - VarSize f -> 1 + f x - -sizeFor :: Sized x => p x -> Size x -sizeFor _ = size - - -getCryptoMessage :: Word32 -> Get CryptoMessage -getCryptoMessage seqno = fix $ \stripPadding -> do - t <- getWord8 - case msgTag t of - Just (M Padding) -> stripPadding - Just (M msg) -> do x <- getPacket seqno - return $ Pkt msg ==> x - Nothing -> return $ Pkt MESSAGE ==> "Unhandled packet: " <> T.pack (show t) -- $ Pkt Padding ==> Padded mempty - -putCryptoMessage :: Word32 -> CryptoMessage -> Put -putCryptoMessage seqno (Pkt t :=> Identity x) = do - putWord8 (msgbyte t) - putPacket seqno x - - -#ifdef USE_lens -erCompat :: String -> a -erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type" -#endif - - -newtype GroupChatId = GrpId ByteString -- 33 bytes - deriving (Show,Eq) - -class HasGroupChatID x where - getGroupChatID :: x -> GroupChatId - setGroupChatID :: x -> GroupChatId -> x - -sizedN :: Int -> ByteString -> ByteString -sizedN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) - else B.take n bs - -sizedAtLeastN :: Int -> ByteString -> ByteString -sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) - else bs - -{- -instance HasGroupChatID CryptoMessage where - -- Get - getGroupChatID (Pkt INVITE_CONFERENCE :=> Identity payload) - = let (xs,ys) = B.splitAt 1 payload' - payload' = sizedN 38 payload - in case B.unpack xs of - [isResponse] | 0 <- isResponse -> GrpId (B.take 33 $ B.drop 2 ys) -- skip group number - [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers - _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message" - - getGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload)) - getGroupChatID _ = error "getGroupChatID on non-groupchat message." - - -- Set - setGroupChatID msg@(Pkt INVITE_CONFERENCE :=> Identity payload) (GrpId newid) - = let (xs,ys) = B.splitAt 1 payload' - payload' = sizedN 38 payload - in case B.unpack xs of - [isResponse] | 0 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 2 ys), sizedN 33 newid]) -- keep group number - [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers - _ -> msg -- unexpected condition, leave unchanged - - setGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) (GrpId newid) = Pkt ONLINE_PACKET ==> (B.concat [B.take 2 payload, sizedN 33 newid]) - setGroupChatID _ _= error "setGroupChatID on non-groupchat message." --} - -#ifdef USE_lens -groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x) -groupChatID = lens getGroupChatID setGroupChatID -#endif - -type GroupNumber = Word16 -type PeerNumber = Word16 -type MessageNumber = Word32 - -class HasGroupNumber x where - getGroupNumber :: x -> GroupNumber - setGroupNumber :: x -> GroupNumber -> x - -{- -instance HasGroupNumber CryptoMessage where - getGroupNumber (Pkt INVITE_CONFERENCE :=> Identity (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1 - = let twobytes = B.take 2 xs - Right n = S.decode twobytes - in n - getGroupNumber (UpToN (fromEnum -> x) (sizedN 2 -> twobytes)) | x >= 0x61 && x <= 0x63 - = let Right n = S.decode twobytes in n - getGroupNumber (UpToN (fromEnum -> 0xC7) (sizedN 2 -> twobytes)) - = let Right n = S.decode twobytes in n - - getGroupNumber _ = error "getGroupNumber on CryptoMessage without group number field." - - setGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) groupnum - = UpToN INVITE_GROUPCHAT (B.cons isResp (B.append (S.encode groupnum) (B.drop 2 xs))) - setGroupNumber (UpToN xE@(fromEnum -> x) (sizedAtLeastN 2 -> B.splitAt 2 -> (twobytes,xs))) groupnum - | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs) - | x == 0xC7 = UpToN xE (B.append (S.encode groupnum) xs) - setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field." --} - -#ifdef USE_lens -groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x) -groupNumber = lens getGroupNumber setGroupNumber -#endif - -class HasGroupNumberToJoin x where - getGroupNumberToJoin :: x -> GroupNumber - setGroupNumberToJoin :: x -> GroupNumber -> x - -{- -instance HasGroupNumberToJoin CryptoMessage where - getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join - = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local) - Right n = S.decode twobytes - in n - getGroupNumberToJoin _ = error "getGroupNumberToJoin on CryptoMessage without group number (to join) field." - setGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) groupnum - = let (a,b) = B.splitAt 2 xs - (twoBytes,c) = B.splitAt 2 b - twoBytes' = S.encode groupnum - in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c])) - setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field." --} - -#ifdef USE_lens -groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x) -groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin -#endif - -class HasPeerNumber x where - getPeerNumber :: x -> PeerNumber - setPeerNumber :: x -> PeerNumber -> x - -{- -instance HasPeerNumber CryptoMessage where - getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) - = let Right n = S.decode twobytes in n - getPeerNumber (UpToN (fromEnum -> 0xC7) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) - = let Right n = S.decode twobytes in n - getPeerNumber _ = error "getPeerNumber on CryptoMessage without peer number field." - - setPeerNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum - = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) - setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum - = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) - setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field." --} - -#ifdef USE_lens -peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x) -peerNumber = lens getPeerNumber setPeerNumber -#endif - -class HasMessageNumber x where - getMessageNumber :: x -> MessageNumber - setMessageNumber :: x -> MessageNumber -> x - -{- -instance HasMessageNumber CryptoMessage where - getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) - = let Right n = S.decode fourbytes in n - getMessageNumber (UpToN (fromEnum -> 0xC7) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) - = let Right n = S.decode fourbytes in n - getMessageNumber _ = error "getMessageNumber on CryptoMessage without message number field." - - setMessageNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum - = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) - setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum - = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) - setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field." --} - -#ifdef USE_lens -messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x) -messageNumber = lens getMessageNumber setMessageNumber -#endif - -class HasMessageName x where - getMessageName :: x -> MessageName - setMessageName :: x -> MessageName -> x - -{- -instance HasMessageName CryptoMessage where - getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) - = let [n] = B.unpack onebyte - in toEnum . fromIntegral $ n - getMessageName (UpToN (fromEnum -> 0xC7) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) - = let [n] = B.unpack onebyte - in toEnum . fromIntegral $ n - getMessageName _ = error "getMessageName on CryptoMessage without message name field." - - setMessageName (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename - = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) - setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename - = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) - setMessageName _ _ = error "setMessageName on CryptoMessage without message name field." --} - -#ifdef USE_lens -messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x) -messageName = lens getMessageName setMessageName -#endif - -data KnownLossyness = KnownLossy | KnownLossless - deriving (Eq,Ord,Show,Enum) - -data MessageType = Msg Word8 - | GrpMsg KnownLossyness MessageName - deriving (Eq,Show) - -class AsWord16 a where - toWord16 :: a -> Word16 - fromWord16 :: Word16 -> a - -class AsWord64 a where - toWord64 :: a -> Word64 - fromWord64 :: Word64 -> a - - -fromEnum16 :: Enum a => a -> Word16 -fromEnum16 = fromIntegral . fromEnum - -fromEnum64 :: Enum a => a -> Word64 -fromEnum64 = fromIntegral . fromEnum - - --- MessageType, for our client keep it inside 16 bits --- but we should extend it to 32 or even 64 on the wire. --- Bits: 000000glxxxxxxxx, x = message id or extension specific, l = if extended, lossy/lossless, g = if extended, nongroup/group --- (at least one bit set in high byte means extended, if none but the g flag and possibly l flag, assume default grp extension) -instance AsWord16 MessageType where - toWord16 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8) - toWord16 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum16 lsy) + fromIntegral (fromEnum8 msgName) - fromWord16 x | x < 256 = Msg (toEnum $ fromIntegral x) - fromWord16 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x) - fromWord16 x = error "Not clear how to convert Word16 to MessageType" - -instance AsWord64 MessageType where - toWord64 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8) - toWord64 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum64 lsy) + fromIntegral (fromEnum8 msgName) - fromWord64 x | x < 256 = Msg (toEnum $ fromIntegral x) - fromWord64 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x) - fromWord64 x = error "Not clear how to convert Word64 to MessageType" - -#ifdef USE_lens -word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x) -word16 = lens toWord16 (\_ x -> fromWord16 x) -#endif - -instance Ord MessageType where - compare (Msg x) (Msg y) = compare x y - compare (GrpMsg lx x) (GrpMsg ly y) = let r1 = compare lx ly - in if r1==EQ then compare x y else r1 - compare (Msg _) (GrpMsg _ _) = LT - compare (GrpMsg _ _) (Msg _) = GT - -class HasMessageType x where - getMessageType :: x -> MessageType - setMessageType :: x -> MessageType -> x - -{- -instance HasMessageType CryptoMessage where - getMessageType (OneByte mid) = Msg mid - getMessageType (TwoByte mid _) = Msg mid - getMessageType m@(UpToN MESSAGE_GROUPCHAT _) = GrpMsg KnownLossless (getMessageName m) - getMessageType m@(UpToN LOSSY_GROUPCHAT _) = GrpMsg KnownLossy (getMessageName m) - getMessageType (UpToN mid _) = Msg mid - - setMessageType (OneByte _ ) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty ) mname - setMessageType (TwoByte _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname - setMessageType (OneByte _ ) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT B.empty ) mname - setMessageType (TwoByte _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT (B.singleton x)) mname - setMessageType (UpToN _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname - setMessageType (UpToN _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT x) mname - setMessageType m (Msg mid) | Just (True,1) <- msgSizeParam mid = OneByte mid - setMessageType (OneByte mid0 ) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid 0 - setMessageType (TwoByte mid0 x) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid x - setMessageType (UpToN mid0 x) (Msg mid) | Just (True,n) <- msgSizeParam mid = UpToN mid (sizedN n x) - setMessageType (OneByte mid0) (Msg mid) = UpToN mid B.empty - setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x) - setMessageType (UpToN mid0 x) (Msg mid) = UpToN mid x --} - -{- -instance HasMessageType CryptoData where - getMessageType (CryptoData { bufferData }) = getMessageType bufferData - setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ } --} - -#ifdef USE_lens --- | This lens should always succeed on CryptoMessage -messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x) -messageType = lens getMessageType setMessageType -#endif - -type MessageData = B.ByteString - -class HasMessageData x where - getMessageData :: x -> MessageData - setMessageData :: x -> MessageData -> x - -{- -instance HasMessageData CryptoMessage where - getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata - getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata - getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x09,peerinfos)))) = peerinfos - -- getMessageData on 0x62:0a is equivalent to getTitle but without decoding the utf8 - getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,title)))) = title - getMessageData _ = error "getMessageData on CryptoMessage without message data field." - - setMessageData (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- MESSAGE_GROUPCHAT - = UpToN xE (B.concat [bs,messagedata]) - setMessageData (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- LOSSY_GROUPCHAT - = UpToN xE (B.concat [bs,messagedata]) - setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets - = UpToN xE (B.concat [bs,peerinfosOrTitle]) - setMessageData _ _ = error "setMessageData on CryptoMessage without message data field." --} - -#ifdef USE_lens -messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x) -messageData = lens getMessageData setMessageData -#endif - -class HasTitle x where - getTitle :: x -> Text - setTitle :: x -> Text -> x - -{- -instance HasTitle CryptoMessage where - getTitle (UpToN xE bs) - | DIRECT_GROUPCHAT {-0x62-} <- xE, - (_,0x0a,mdata) <- splitByteAt 2 bs = decodeUtf8 mdata - | isIndirectGrpChat xE, - let (_,nmb,mdata) = splitByteAt 8 bs - nm = toEnum (fromIntegral nmb), - GroupchatTitleChange <- nm = decodeUtf8 mdata - getTitle _ = error "getTitle on CryptoMessage without title field." - - setTitle (UpToN xE bs) msgdta - | DIRECT_GROUPCHAT {-0x62-} <- xE - = let (pre,_,_) = splitByteAt 2 bs - nm = 0x0a - in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) - | isIndirectGrpChat xE - = let (pre,_,_) = splitByteAt 8 bs - nm = fromIntegral $ fromEnum GroupchatTitleChange - in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) - setTitle _ _ = error "setTitle on CryptoMessage without title field." --} - -#ifdef USE_lens -title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) -title = lens getTitle setTitle -#endif - -class HasMessage x where - getMessage :: x -> Text - setMessage :: x -> Text -> x - -splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString) -splitByteAt n bs = (fixed,w8,bs') - where - (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs - -{- -instance HasMessage CryptoMessage where - getMessage (UpToN xE bs) - | MESSAGE <- xE = T.decodeUtf8 bs - | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs - getMessage _ = error "getMessage on CryptoMessage without message field." - - setMessage (UpToN xE bs) message - | MESSAGE <- xE - = UpToN xE $ T.encodeUtf8 message - | isIndirectGrpChat xE - = let (pre8,nm0,xs) = splitByteAt 8 bs - nm = if nm0 == 0 then 0x40 else nm0 - prefix x = pre8 <> B.cons nm x - in UpToN xE $ prefix $ T.encodeUtf8 message - setMessage _ _ = error "setMessage on CryptoMessage without message field." --} - -#ifdef USE_lens -message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x) -message = lens getMessage setMessage -#endif - -class HasName x where - getName :: x -> Text - setName :: x -> Text -> x - - -{- -instance HasName CryptoMessage where - -- Only MESSAGE_GROUPCHAT:NameChange has Name field - getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata - getName _ = error "getName on CryptoMessage without name field." - - -- If its not NameChange, this setter will set it to NameChange - setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name - | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)]) - setName _ _ = error "setName on CryptoMessage without name field." --} - -#ifdef USE_lens -name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) -name = lens getTitle setTitle -#endif - -data PeerInfo - = PeerInfo - { piPeerNum :: PeerNumber - , piUserKey :: PublicKey - , piDHTKey :: PublicKey - , piName :: ByteString -- byte-prefix for length - } deriving (Eq,Show) - -instance HasPeerNumber PeerInfo where - getPeerNumber = piPeerNum - setPeerNumber x n = x { piPeerNum = n } - -instance Serialize PeerInfo where - get = do - w16 <- get - ukey <- getPublicKey - dkey <- getPublicKey - w8 <- get :: Get Word8 - PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8) - - put (PeerInfo w16 ukey dkey bs) = do - put w16 - putPublicKey ukey - putPublicKey dkey - let sz :: Word8 - sz = case B.length bs of - n | n <= 255 -> fromIntegral n - | otherwise -> 255 - put sz - putByteString $ B.take (fromIntegral sz) bs - - -{- --- | --- default constructor, handy for formations such as: --- --- > userStatus .~ Busy $ msg USERSTATUS --- -msg :: MessageID -> CryptoMessage -msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid - | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 - | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty - | otherwise = UpToN mid B.empty --} - -{- -leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage -leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) -peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) --} - -{- --- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as --- the maximum allowed size for the message Payload (message minus id) --- Or Nothing if unknown/unimplemented. -msgSizeParam :: MessageID -> Maybe (Bool,Int) -msgSizeParam ONLINE = Just (True ,0) -msgSizeParam OFFLINE = Just (True ,0) -msgSizeParam USERSTATUS = Just (True ,1) -msgSizeParam TYPING = Just (True ,1) -msgSizeParam NICKNAME = Just (False,128) -msgSizeParam STATUSMESSAGE = Just (False,1007) -msgSizeParam MESSAGE = Just (False,1372) -msgSizeParam ACTION = Just (False,1372) -msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373 -msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301 -msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4 -msgSizeParam INVITE_GROUPCHAT = Just (False,38) -msgSizeParam ONLINE_PACKET = Just (True ,35) -msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets -msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable -msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable -msgSizeParam _ = Nothing --} - -isIndirectGrpChat :: Msg n t -> Bool -isIndirectGrpChat MESSAGE_CONFERENCE = True -isIndirectGrpChat LOSSY_CONFERENCE = True -isIndirectGrpChat _ = False - -isKillPacket :: SomeMsg -> Bool -isKillPacket (M KillPacket) = True -isKillPacket _ = False - -isOFFLINE :: SomeMsg -> Bool -isOFFLINE (M OFFLINE) = True -isOFFLINE _ = False - - -data MessageName = Ping -- 0x00 - | MessageName0x01 - | MessageName0x02 - | MessageName0x03 - | MessageName0x04 - | MessageName0x05 - | MessageName0x06 - | MessageName0x07 - | MessageName0x08 - | MessageName0x09 - | MessageName0x0a - | MessageName0x0b - | MessageName0x0c - | MessageName0x0d - | MessageName0x0e - | MessageName0x0f - | NewPeer -- 0x10 - | KillPeer -- 0x11 - | MessageName0x12 - | MessageName0x13 - | MessageName0x14 - | MessageName0x15 - | MessageName0x16 - | MessageName0x17 - | MessageName0x18 - | MessageName0x19 - | MessageName0x1a - | MessageName0x1b - | MessageName0x1c - | MessageName0x1d - | MessageName0x1e - | MessageName0x1f - | MessageName0x20 - | MessageName0x21 - | MessageName0x22 - | MessageName0x23 - | MessageName0x24 - | MessageName0x25 - | MessageName0x26 - | MessageName0x27 - | MessageName0x28 - | MessageName0x29 - | MessageName0x2a - | MessageName0x2b - | MessageName0x2c - | MessageName0x2d - | MessageName0x2e - | MessageName0x2f - | NameChange -- 0x30 - | GroupchatTitleChange -- 0x31 - | MessageName0x32 - | MessageName0x33 - | MessageName0x34 - | MessageName0x35 - | MessageName0x36 - | MessageName0x37 - | MessageName0x38 - | MessageName0x39 - | MessageName0x3a - | MessageName0x3b - | MessageName0x3c - | MessageName0x3d - | MessageName0x3e - | MessageName0x3f - | ChatMessage -- 0x40 - | Action -- 0x41 - | MessageName0x42 - | MessageName0x43 - | MessageName0x44 - | MessageName0x45 - | MessageName0x46 - | MessageName0x47 - | MessageName0x48 - | MessageName0x49 - | MessageName0x4a - | MessageName0x4b - | MessageName0x4c - | MessageName0x4d - | MessageName0x4e - | MessageName0x4f - | MessageName0x50 - | MessageName0x51 - | MessageName0x52 - | MessageName0x53 - | MessageName0x54 - | MessageName0x55 - | MessageName0x56 - | MessageName0x57 - | MessageName0x58 - | MessageName0x59 - | MessageName0x5a - | MessageName0x5b - | MessageName0x5c - | MessageName0x5d - | MessageName0x5e - | MessageName0x5f - | MessageName0x60 - | MessageName0x61 - | MessageName0x62 - | MessageName0x63 - | MessageName0x64 - | MessageName0x65 - | MessageName0x66 - | MessageName0x67 - | MessageName0x68 - | MessageName0x69 - | MessageName0x6a - | MessageName0x6b - | MessageName0x6c - | MessageName0x6d - | MessageName0x6e - | MessageName0x6f - | MessageName0x70 - | MessageName0x71 - | MessageName0x72 - | MessageName0x73 - | MessageName0x74 - | MessageName0x75 - | MessageName0x76 - | MessageName0x77 - | MessageName0x78 - | MessageName0x79 - | MessageName0x7a - | MessageName0x7b - | MessageName0x7c - | MessageName0x7d - | MessageName0x7e - | MessageName0x7f - | MessageName0x80 - | MessageName0x81 - | MessageName0x82 - | MessageName0x83 - | MessageName0x84 - | MessageName0x85 - | MessageName0x86 - | MessageName0x87 - | MessageName0x88 - | MessageName0x89 - | MessageName0x8a - | MessageName0x8b - | MessageName0x8c - | MessageName0x8d - | MessageName0x8e - | MessageName0x8f - | MessageName0x90 - | MessageName0x91 - | MessageName0x92 - | MessageName0x93 - | MessageName0x94 - | MessageName0x95 - | MessageName0x96 - | MessageName0x97 - | MessageName0x98 - | MessageName0x99 - | MessageName0x9a - | MessageName0x9b - | MessageName0x9c - | MessageName0x9d - | MessageName0x9e - | MessageName0x9f - | MessageName0xa0 - | MessageName0xa1 - | MessageName0xa2 - | MessageName0xa3 - | MessageName0xa4 - | MessageName0xa5 - | MessageName0xa6 - | MessageName0xa7 - | MessageName0xa8 - | MessageName0xa9 - | MessageName0xaa - | MessageName0xab - | MessageName0xac - | MessageName0xad - | MessageName0xae - | MessageName0xaf - | MessageName0xb0 - | MessageName0xb1 - | MessageName0xb2 - | MessageName0xb3 - | MessageName0xb4 - | MessageName0xb5 - | MessageName0xb6 - | MessageName0xb7 - | MessageName0xb8 - | MessageName0xb9 - | MessageName0xba - | MessageName0xbb - | MessageName0xbc - | MessageName0xbd - | MessageName0xbe - | MessageName0xbf - | MessageName0xc0 - | MessageName0xc1 - | MessageName0xc2 - | MessageName0xc3 - | MessageName0xc4 - | MessageName0xc5 - | MessageName0xc6 - | MessageName0xc7 - | MessageName0xc8 - | MessageName0xc9 - | MessageName0xca - | MessageName0xcb - | MessageName0xcc - | MessageName0xcd - | MessageName0xce - | MessageName0xcf - | MessageName0xd0 - | MessageName0xd1 - | MessageName0xd2 - | MessageName0xd3 - | MessageName0xd4 - | MessageName0xd5 - | MessageName0xd6 - | MessageName0xd7 - | MessageName0xd8 - | MessageName0xd9 - | MessageName0xda - | MessageName0xdb - | MessageName0xdc - | MessageName0xdd - | MessageName0xde - | MessageName0xdf - | MessageName0xe0 - | MessageName0xe1 - | MessageName0xe2 - | MessageName0xe3 - | MessageName0xe4 - | MessageName0xe5 - | MessageName0xe6 - | MessageName0xe7 - | MessageName0xe8 - | MessageName0xe9 - | MessageName0xea - | MessageName0xeb - | MessageName0xec - | MessageName0xed - | MessageName0xee - | MessageName0xef - | MessageName0xf0 - | MessageName0xf1 - | MessageName0xf2 - | MessageName0xf3 - | MessageName0xf4 - | MessageName0xf5 - | MessageName0xf6 - | MessageName0xf7 - | MessageName0xf8 - | MessageName0xf9 - | MessageName0xfa - | MessageName0xfb - | MessageName0xfc - | MessageName0xfd - | MessageName0xfe - | MessageName0xff - deriving (Show,Eq,Ord,Enum,Bounded) - diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs deleted file mode 100644 index 1eec93b9..00000000 --- a/src/Network/Tox/DHT/Handlers.hs +++ /dev/null @@ -1,573 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TupleSections #-} -module Network.Tox.DHT.Handlers where - -import Debug.Trace -import Network.Tox.DHT.Transport as DHTTransport -import Network.QueryResponse as QR hiding (Client) -import qualified Network.QueryResponse as QR (Client) -import Crypto.Tox -import Network.Kademlia.Search -import qualified Data.Wrapper.PSQInt as Int -import Network.Kademlia -import Network.Kademlia.Bootstrap -import Network.Address (WantIP (..), ipFamily, fromSockAddr, sockAddrPort) -import qualified Network.Kademlia.Routing as R -import Control.TriadCommittee -import System.Global6 -import DPut -import DebugTag - -import qualified Data.ByteArray as BA -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Base16 as Base16 -import Control.Arrow -import Control.Monad -import Control.Concurrent.Lifted.Instrument -import Control.Concurrent.STM -import Data.Hashable -import Data.Ord -import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import Network.Socket -import qualified Data.HashMap.Strict as HashMap - ;import Data.HashMap.Strict (HashMap) -#if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) -#else -import Data.IP -#endif -import Data.Maybe -import Data.Serialize (Serialize) -import Data.Word - -data TransactionId = TransactionId - { transactionKey :: Nonce8 -- ^ Used to lookup pending query. - , cryptoNonce :: Nonce24 -- ^ Used during the encryption layer. - } - deriving (Eq,Ord,Show) - -newtype PacketKind = PacketKind Word8 - deriving (Eq, Ord, Serialize) - -pattern OnionRequest0Type = PacketKind 128 -- 0x80 Onion Request 0 -pattern OnionRequest1Type = PacketKind 129 -- 0x81 Onion Request 1 -pattern OnionRequest2Type = PacketKind 130 -- 0x82 Onion Request 2 -pattern AnnounceType = PacketKind 131 -- 0x83 Announce Request -pattern AnnounceResponseType = PacketKind 132 -- 0x84 Announce Response - -pattern DataRequestType = PacketKind 133 -- 0x85 Onion Data Request (data to route request packet) -pattern DataResponseType = PacketKind 134 -- 0x86 Onion Data Response (data to route response packet) --- 0x8c Onion Response 3 --- 0x8d Onion Response 2 -pattern OnionResponse3Type = PacketKind 140 -- 0x8c Onion Response 3 -pattern OnionResponse2Type = PacketKind 141 -- 0x8d Onion Response 2 -pattern OnionResponse1Type = PacketKind 142 -- 0x8e Onion Response 1 --- 0xf0 Bootstrap Info - -pattern DHTRequestType = PacketKind 32 -- 0x20 DHT Request - -pattern CookieRequestType = PacketKind 0x18 -pattern CookieResponseType = PacketKind 0x19 - -pattern PingType = PacketKind 0 -- 0x00 Ping Request -pattern PongType = PacketKind 1 -- 0x01 Ping Response -pattern GetNodesType = PacketKind 2 -- 0x02 Nodes Request -pattern SendNodesType = PacketKind 4 -- 0x04 Nodes Response - - -instance Show PacketKind where - showsPrec d PingType = mappend "PingType" - showsPrec d PongType = mappend "PongType" - showsPrec d GetNodesType = mappend "GetNodesType" - showsPrec d SendNodesType = mappend "SendNodesType" - showsPrec d DHTRequestType = mappend "DHTRequestType" - showsPrec d OnionRequest0Type = mappend "OnionRequest0Type" - showsPrec d OnionResponse1Type = mappend "OnionResponse1Type" - showsPrec d OnionResponse3Type = mappend "OnionResponse3Type" - showsPrec d AnnounceType = mappend "AnnounceType" - showsPrec d AnnounceResponseType = mappend "AnnounceResponseType" - showsPrec d DataRequestType = mappend "DataRequestType" - showsPrec d DataResponseType = mappend "DataResponseType" - showsPrec d CookieRequestType = mappend "CookieRequestType" - showsPrec d CookieResponseType = mappend "CookieResponseType" - showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x - -msgType :: ( Serialize (f DHTRequest) - , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest) - , Serialize (f SendNodes), Serialize (f GetNodes) - , Serialize (f Pong), Serialize (f Ping) - ) => DHTMessage f -> PacketKind -msgType msg = PacketKind $ fst $ dhtMessageType msg - -classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message -classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client) -classify client msg = fromMaybe (IsUnknown "unknown") - $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg - where - go (DHTPing {}) = IsQuery PingType - go (DHTGetNodes {}) = IsQuery GetNodesType - go (DHTPong {}) = IsResponse - go (DHTSendNodes {}) = IsResponse - go (DHTCookieRequest {}) = IsQuery CookieRequestType - go (DHTCookie {}) = IsResponse - go (DHTDHTRequest {}) = IsQuery DHTRequestType - -data NodeInfoCallback = NodeInfoCallback - { interestingNodeId :: NodeId - , listenerId :: Int - , observedAddress :: POSIXTime -> NodeInfo -- Address and port for interestingNodeId - -> STM () - , rumoredAddress :: POSIXTime -> SockAddr -- source of information - -> NodeInfo -- Address and port for interestingNodeId - -> STM () - } - -data Routing = Routing - { tentativeId :: NodeInfo - , committee4 :: TriadCommittee NodeId SockAddr - , committee6 :: TriadCommittee NodeId SockAddr - , refresher4 :: BucketRefresher NodeId NodeInfo - , refresher6 :: BucketRefresher NodeId NodeInfo - , nodesOfInterest :: TVar (HashMap NodeId [NodeInfoCallback]) - } - -registerNodeCallback :: Routing -> NodeInfoCallback -> STM () -registerNodeCallback Routing{nodesOfInterest} cb = do - cbm <- readTVar nodesOfInterest - let ns = fromMaybe [] $ HashMap.lookup (interestingNodeId cb) cbm - bs = filter nonMatching ns - where nonMatching n = (listenerId n /= listenerId cb) - writeTVar nodesOfInterest $ HashMap.insert (interestingNodeId cb) - (cb : bs) - cbm - -unregisterNodeCallback :: Int -> Routing -> NodeId -> STM () -unregisterNodeCallback callbackId Routing{nodesOfInterest} nid = do - cbm <- readTVar nodesOfInterest - let ns = fromMaybe [] $ HashMap.lookup nid cbm - bs = filter nonMatching ns - where nonMatching n = (listenerId n /= callbackId) - writeTVar nodesOfInterest - $ if null bs - then HashMap.delete nid cbm - else HashMap.insert nid bs cbm - - -sched4 :: Routing -> TVar (Int.PSQ POSIXTime) -sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue - -sched6 :: Routing -> TVar (Int.PSQ POSIXTime) -sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue - -routing4 :: Routing -> TVar (R.BucketList NodeInfo) -routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets - -routing6 :: Routing -> TVar (R.BucketList NodeInfo) -routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets - -newRouting :: SockAddr -> TransportCrypto - -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv4 change - -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv6 change - -> IO (Client -> Routing) -newRouting addr crypto update4 update6 = do - let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr) - tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr) - tentative_info = NodeInfo - { nodeId = key2id $ transportPublic crypto - , nodeIP = fromMaybe (toEnum 0) (fromSockAddr addr) - , nodePort = fromMaybe 0 $ sockAddrPort addr - } - tentative_info4 = tentative_info { nodeIP = tentative_ip4 } - tentative_info6 <- - maybe (tentative_info { nodeIP = tentative_ip6 }) - (\ip6 -> tentative_info { nodeIP = IPv6 ip6 }) - <$> case addr of - SockAddrInet {} -> return Nothing - _ -> global6 - atomically $ do - -- We defer initializing the refreshSearch and refreshPing until we - -- have a client to send queries with. - let nullPing = const $ return False - nullSearch = Search - { searchSpace = toxSpace - , searchNodeAddress = nodeIP &&& nodePort - , searchQuery = Left $ \_ _ -> return Nothing - , searchAlpha = 1 - , searchK = 2 - } - tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 R.defaultBucketCount - tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount - refresher4 <- newBucketRefresher tbl4 nullSearch nullPing - refresher6 <- newBucketRefresher tbl6 nullSearch nullPing - committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4 - committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6 - cbvar <- newTVar HashMap.empty - return $ \client -> - -- Now we have a client, so tell the BucketRefresher how to search and ping. - let updIO r = updateRefresherIO (nodeSearch client cbvar) (ping client) r - in Routing { tentativeId = tentative_info - , committee4 = committee4 - , committee6 = committee6 - , refresher4 = updIO refresher4 - , refresher6 = updIO refresher6 - , nodesOfInterest = cbvar - } - - --- TODO: This should cover more cases -isLocal :: IP -> Bool -isLocal (IPv6 ip6) = (ip6 == toEnum 0) -isLocal (IPv4 ip4) = (ip4 == toEnum 0) - -isGlobal :: IP -> Bool -isGlobal = not . isLocal - -prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP -prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp - -toxSpace :: R.KademliaSpace NodeId NodeInfo -toxSpace = R.KademliaSpace - { R.kademliaLocation = nodeId - , R.kademliaTestBit = testNodeIdBit - , R.kademliaXor = xorNodeId - , R.kademliaSample = sampleNodeId - } - - -pingH :: NodeInfo -> Ping -> IO Pong -pingH _ Ping = return Pong - -getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes -getNodesH routing addr (GetNodes nid) = do - let preferred = prefer4or6 addr Nothing - - (append4,append6) <- atomically $ do - ni4 <- R.thisNode <$> readTVar (routing4 routing) - ni6 <- R.thisNode <$> readTVar (routing6 routing) - return $ case ipFamily (nodeIP addr) of - Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6])) - Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id) - _ -> (id, id) - ks <- go append4 $ routing4 routing - ks6 <- go append6 $ routing6 routing - let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks) - Want_IP4 -> (ks,ks6) - Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__ - return $ SendNodes - $ if null ns2 then ns1 - else take 4 (take 3 ns1 ++ ns2) - where - go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var) - - k = 4 - -createCookie :: TransportCrypto -> NodeInfo -> PublicKey -> IO (Cookie Encrypted) -createCookie crypto ni remoteUserKey = do - (n24,sym) <- atomically $ do - n24 <- transportNewNonce crypto - sym <- transportSymmetric crypto - return (n24,sym) - timestamp <- round . (* 1000000) <$> getPOSIXTime - let dta = encodePlain $ CookieData - { cookieTime = timestamp - , longTermKey = remoteUserKey - , dhtKey = id2key $ nodeId ni -- transportPublic crypto - } - edta = encryptSymmetric sym n24 dta - return $ Cookie n24 edta - -createCookieSTM :: POSIXTime -> TransportCrypto -> NodeInfo -> PublicKey -> STM (Cookie Encrypted) -createCookieSTM now crypto ni remoteUserKey = do - let dmsg msg = trace msg (return ()) - (n24,sym) <- do - n24 <- transportNewNonce crypto - sym <- transportSymmetric crypto - return (n24,sym) - let timestamp = round (now * 1000000) - let dta = encodePlain $ CookieData - { cookieTime = timestamp - , longTermKey = remoteUserKey - , dhtKey = id2key $ nodeId ni -- transportPublic crypto - } - edta = encryptSymmetric sym n24 dta - return $ Cookie n24 edta - -cookieRequestH :: TransportCrypto -> NodeInfo -> CookieRequest -> IO (Cookie Encrypted) -cookieRequestH crypto ni (CookieRequest remoteUserKey) = do - dput XNetCrypto $ unlines - [ show (nodeAddr ni) ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey) - , show (nodeAddr ni) ++ " --> sender=" ++ show (nodeId ni) ] - x <- createCookie crypto ni remoteUserKey - dput XNetCrypto $ show (nodeAddr ni) ++ " <-- cookie " ++ show (key2id remoteUserKey) - return x - -lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message)) -lanDiscoveryH client _ ni = do - dput XLan $ show (nodeAddr ni) ++ " --> LanAnnounce " ++ show (nodeId ni) - forkIO $ do - myThreadId >>= flip labelThread "lan-discover-ping" - ping client ni - return () - return Nothing - -type Message = DHTMessage ((,) Nonce8) - -type Client = QR.Client String PacketKind TransactionId NodeInfo Message - - -wrapAsymm :: TransactionId -> NodeInfo -> NodeInfo -> (Nonce8 -> dta) -> Asymm dta -wrapAsymm (TransactionId n8 n24) src dst dta = Asymm - { senderKey = id2key $ nodeId src - , asymmNonce = n24 - , asymmData = dta n8 - } - -serializer :: PacketKind - -> (Asymm (Nonce8,ping) -> Message) - -> (Message -> Maybe (Asymm (Nonce8,pong))) - -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong) -serializer pktkind mkping mkpong = MethodSerializer - { methodTimeout = \tid addr -> return (addr, 5000000) - , method = pktkind - -- wrapQuery :: tid -> addr -> addr -> qry -> x - , wrapQuery = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping) - -- unwrapResponse :: x -> b - , unwrapResponse = fmap (snd . asymmData) . mkpong - } - - -unpong :: Message -> Maybe (Asymm (Nonce8,Pong)) -unpong (DHTPong asymm) = Just asymm -unpong _ = Nothing - -ping :: Client -> NodeInfo -> IO Bool -ping client addr = do - dput XPing $ show addr ++ " <-- ping" - reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr - dput XPing $ show addr ++ " -pong-> " ++ show reply - maybe (return False) (\Pong -> return True) $ join reply - - -saveCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM () -saveCookieKey var saddr pk = do - cookiekeys <- readTVar var - case break (\(stored,_) -> stored == saddr) cookiekeys of - (xs,[]) -> writeTVar var $ (saddr, (1 ,pk)) : xs - (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c+1,pk)) : xs ++ ys - _ -> retry -- Wait for requests to this address - -- under a different key to time out - -- before we try this key. - -loseCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM () -loseCookieKey var saddr pk = do - cookiekeys <- readTVar var - case break (\(stored,_) -> stored == saddr) cookiekeys of - (xs,(_,(1,stored)):ys) | stored == pk -> writeTVar var $ xs ++ ys - (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c-1,pk)) : xs ++ ys - _ -> return () -- unreachable? - - -cookieRequest :: TransportCrypto -> Client -> PublicKey -> NodeInfo -> IO (Maybe (Cookie Encrypted)) -cookieRequest crypto client localUserKey addr = do - let sockAddr = nodeAddr addr - nid = id2key $ nodeId addr - cookieSerializer - = MethodSerializer - { methodTimeout = \tid addr -> return (addr, 5000000) - , method = CookieRequestType - , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr) - , unwrapResponse = fmap snd . unCookie - } - cookieRequest = CookieRequest localUserKey - atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid - dput XNetCrypto $ show addr ++ " <-- cookieRequest" - reply <- QR.sendQuery client cookieSerializer cookieRequest addr - atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid - dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply - return $ join reply - -unCookie :: DHTMessage t -> Maybe (t (Cookie Encrypted)) -unCookie (DHTCookie n24 fcookie) = Just fcookie -unCookie _ = Nothing - -unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes)) -unsendNodes (DHTSendNodes asymm) = Just asymm -unsendNodes _ = Nothing - -unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () ) -unwrapNodes (SendNodes ns) = (ns,ns,Just ()) - -data SendableQuery x a b = SendableQuery - { sendableSerializer :: MethodSerializer TransactionId NodeInfo Message PacketKind a (Maybe x) - , sendableQuery :: NodeId -> a - , sendableResult :: Maybe (Maybe x) -> IO b - } - -sendQ :: SendableQuery x a b - -> QR.Client err PacketKind TransactionId NodeInfo Message - -> NodeId - -> NodeInfo - -> IO b -sendQ s client nid addr = do - reply <- QR.sendQuery client (sendableSerializer s) (sendableQuery s nid) addr - sendableResult s reply - -asyncQ :: SendableQuery x a b - -> QR.Client err PacketKind TransactionId NodeInfo Message - -> NodeId - -> NodeInfo - -> (b -> IO ()) - -> IO () -asyncQ s client nid addr go = do - QR.asyncQuery client (sendableSerializer s) (sendableQuery s nid) addr - $ sendableResult s >=> go - -getNodesSendable :: TVar (HashMap NodeId [NodeInfoCallback]) - -> NodeInfo - -> SendableQuery SendNodes GetNodes (Maybe ([NodeInfo], [NodeInfo], Maybe ())) -getNodesSendable cbvar addr = SendableQuery (serializer GetNodesType DHTGetNodes unsendNodes) - GetNodes - go - where - go reply = do - forM_ (join reply) $ \(SendNodes ns) -> - forM_ ns $ \n -> do - now <- getPOSIXTime - atomically $ do - mcbs <- HashMap.lookup (nodeId n) <$> readTVar cbvar - forM_ mcbs $ \cbs -> do - forM_ cbs $ \cb -> do - rumoredAddress cb now (nodeAddr addr) n - return $ fmap unwrapNodes $ join reply - -getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) -getNodes client cbvar nid addr = - sendQ (getNodesSendable cbvar addr) client nid addr - -asyncGetNodes :: QR.Client err PacketKind TransactionId NodeInfo Message - -> TVar (HashMap NodeId [NodeInfoCallback]) - -> NodeId - -> NodeInfo - -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ()) - -> IO () -asyncGetNodes client cbvar nid addr go = - asyncQ (getNodesSendable cbvar addr) client nid addr go - -updateRouting :: Client -> Routing - -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) - -> NodeInfo - -> Message - -> IO () -updateRouting client routing orouter naddr msg - | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery - -- Ignore lan announcements until they reply to our ping. - -- We do this because the lan announce is not authenticated. - return () - | otherwise = do - now <- getPOSIXTime - atomically $ do - m <- HashMap.lookup (nodeId naddr) <$> readTVar (nodesOfInterest routing) - forM_ m $ mapM_ $ \NodeInfoCallback{interestingNodeId,observedAddress} -> do - when (interestingNodeId == nodeId naddr) - $ observedAddress now naddr - case prefer4or6 naddr Nothing of - Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing) - Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing) - Want_Both -> do dput XMisc "BUG:unreachable" - error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__ - -updateTable :: Client -> NodeInfo - -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) - -> TriadCommittee NodeId SockAddr - -> BucketRefresher NodeId NodeInfo - -> IO () -updateTable client naddr orouter committee refresher = do - self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher) - -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr) - when (self /= naddr) $ do - -- TODO: IP address vote? - insertNode (toxKademlia client committee orouter refresher) naddr - -toxKademlia :: Client - -> TriadCommittee NodeId SockAddr - -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) - -> BucketRefresher NodeId NodeInfo - -> Kademlia NodeId NodeInfo -toxKademlia client committee orouter refresher - = Kademlia quietInsertions - toxSpace - (vanillaIO (refreshBuckets refresher) $ ping client) - { tblTransition = \tr -> do - io1 <- transitionCommittee committee tr - io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr - -- hookBucketList toxSpace (refreshBuckets refresher) orouter tr - orouter (refreshBuckets refresher) tr - return $ do - io1 >> io2 - {- - dput XMisc $ unwords - [ show (transitionedTo tr) - , show (transitioningNode tr) - ] - -} - return () - } - -transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ()) -transitionCommittee committee (RoutingTransition ni Stranger) = do - delVote committee (nodeId ni) - return $ do - -- dput XMisc $ "delVote "++show (nodeId ni) - return () -transitionCommittee committee _ = return $ return () - -type Handler = MethodHandler String TransactionId NodeInfo Message - -isPing :: (f Ping -> Ping) -> DHTMessage f -> Either String Ping -isPing unpack (DHTPing a) = Right $ unpack $ asymmData a -isPing _ _ = Left "Bad ping" - -mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8) -mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong) - -isGetNodes :: (f GetNodes -> GetNodes) -> DHTMessage f -> Either String GetNodes -isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a -isGetNodes _ _ = Left "Bad GetNodes" - -mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8) -mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes) - -isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest -isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a -isCookieRequest _ _ = Left "Bad cookie request" - -mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie Encrypted -> DHTMessage ((,) Nonce8) -mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie) - -isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest -isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a -isDHTRequest _ _ = Left "Bad dht relay request" - -dhtRequestH :: NodeInfo -> DHTRequest -> IO () -dhtRequestH ni req = do - dput XMisc $ "Unhandled DHT Request: " ++ show req - -handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler -handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH -handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing -handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto -handlers _ _ DHTRequestType = Just $ NoReply (isDHTRequest snd) $ dhtRequestH -handlers _ _ typ = error $ "TODO DHT handlers " ++ show typ - -nodeSearch :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo -nodeSearch client cbvar = Search - { searchSpace = toxSpace - , searchNodeAddress = nodeIP &&& nodePort - , searchQuery = Right $ asyncGetNodes client cbvar - , searchAlpha = 8 - , searchK = 16 - - } diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs deleted file mode 100644 index b9b63165..00000000 --- a/src/Network/Tox/DHT/Transport.hs +++ /dev/null @@ -1,460 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Network.Tox.DHT.Transport - ( parseDHTAddr - , encodeDHTAddr - , forwardDHTRequests - , module Network.Tox.NodeId - , DHTMessage(..) - , Ping(..) - , Pong(..) - , GetNodes(..) - , SendNodes(..) - , DHTPublicKey(..) - , FriendRequest(..) - , NoSpam(..) - , CookieRequest(..) - , CookieResponse(..) - , Cookie(..) - , CookieData(..) - , DHTRequest - , mapMessage - , encrypt - , decrypt - , dhtMessageType - , asymNodeInfo - , putMessage -- Convenient for serializing DHTLanDiscovery - ) where - -import Network.Tox.NodeId -import Crypto.Tox hiding (encrypt,decrypt) -import qualified Crypto.Tox as ToxCrypto -import Network.QueryResponse - -import Control.Applicative -import Control.Arrow -import Control.Concurrent.STM -import Control.Monad -import Data.Bool -import qualified Data.ByteString as B - ;import Data.ByteString (ByteString) -import Data.Functor.Contravariant -import Data.Hashable -import Data.Maybe -import Data.Monoid -import Data.Serialize as S -import Data.Tuple -import Data.Word -import GHC.Generics -import Network.Socket - -type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8) -type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a - - -data DHTMessage (f :: * -> *) - = DHTPing (Asymm (f Ping)) - | DHTPong (Asymm (f Pong)) - | DHTGetNodes (Asymm (f GetNodes)) - | DHTSendNodes (Asymm (f SendNodes)) - | DHTCookieRequest (Asymm (f CookieRequest)) - | DHTCookie Nonce24 (f (Cookie Encrypted)) - | DHTDHTRequest PublicKey (Asymm (f DHTRequest)) - | DHTLanDiscovery NodeId - -deriving instance ( Show (f (Cookie Encrypted)) - , Show (f Ping) - , Show (f Pong) - , Show (f GetNodes) - , Show (f SendNodes) - , Show (f CookieRequest) - , Show (f DHTRequest) - ) => Show (DHTMessage f) - -mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> Maybe b -mapMessage f (DHTPing a) = Just $ f (asymmNonce a) (asymmData a) -mapMessage f (DHTPong a) = Just $ f (asymmNonce a) (asymmData a) -mapMessage f (DHTGetNodes a) = Just $ f (asymmNonce a) (asymmData a) -mapMessage f (DHTSendNodes a) = Just $ f (asymmNonce a) (asymmData a) -mapMessage f (DHTCookieRequest a) = Just $ f (asymmNonce a) (asymmData a) -mapMessage f (DHTDHTRequest _ a) = Just $ f (asymmNonce a) (asymmData a) -mapMessage f (DHTCookie nonce fcookie) = Just $ f nonce fcookie -mapMessage f (DHTLanDiscovery nid) = Nothing - - -instance Sized Ping where size = ConstSize 1 -instance Sized Pong where size = ConstSize 1 - -parseDHTAddr :: TransportCrypto -> (ByteString, SockAddr) -> IO (Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr)) -parseDHTAddr crypto (msg,saddr) - | Just (typ,bs) <- B.uncons msg - , let right = return $ Right (msg,saddr) - left = either (const right) (return . Left) - = case typ of - 0x00 -> left $ direct bs saddr DHTPing - 0x01 -> left $ direct bs saddr DHTPong - 0x02 -> left $ direct bs saddr DHTGetNodes - 0x04 -> left $ direct bs saddr DHTSendNodes - 0x18 -> left $ direct bs saddr DHTCookieRequest - 0x19 -> do - cs <- atomically $ readTVar (pendingCookies crypto) - let ni = fromMaybe (noReplyAddr saddr) $ do - (cnt,key) <- lookup saddr cs <|> listToMaybe (map snd cs) - either (const Nothing) Just $ nodeInfo (key2id key) saddr - left $ fanGet bs getCookie (uncurry DHTCookie) (const $ ni) - 0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd) - 0x21 -> left $ do - nid <- runGet get bs - ni <- nodeInfo nid saddr - return (DHTLanDiscovery nid, ni) - _ -> right - -encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> IO (ByteString, SockAddr) -encodeDHTAddr (msg,ni) = return (runPut $ putMessage msg, nodeAddr ni) - -dhtMessageType :: ( Serialize (f DHTRequest) - , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest) - , Serialize (f SendNodes), Serialize (f GetNodes) - , Serialize (f Pong), Serialize (f Ping) - ) => DHTMessage f -> (Word8, Put) -dhtMessageType (DHTPing a) = (0x00, putAsymm a) -dhtMessageType (DHTPong a) = (0x01, putAsymm a) -dhtMessageType (DHTGetNodes a) = (0x02, putAsymm a) -dhtMessageType (DHTSendNodes a) = (0x04, putAsymm a) -dhtMessageType (DHTCookieRequest a) = (0x18, putAsymm a) -dhtMessageType (DHTCookie n x) = (0x19, put n >> put x) -dhtMessageType (DHTDHTRequest k a) = (0x20, putPublicKey k >> putAsymm a) -dhtMessageType (DHTLanDiscovery nid) = (0x21, put nid) - -putMessage :: DHTMessage Encrypted8 -> Put -putMessage msg = case dhtMessageType msg of (typ,p) -> put typ >> p - -getCookie :: Get (Nonce24, Encrypted8 (Cookie Encrypted)) -getCookie = get - -getDHTReqest :: Get (PublicKey, Asymm (Encrypted8 DHTRequest)) -getDHTReqest = (,) <$> getPublicKey <*> getAsymm - --- ## DHT Request packets --- --- | Length | Contents | --- |:-------|:--------------------------| --- | `1` | `uint8_t` (0x20) | --- | `32` | receiver's DHT public key | --- ... ... - - -getDHT :: Sized a => Get (Asymm (Encrypted8 a)) -getDHT = getAsymm - - --- Throws an error if called with a non-internet socket. -direct :: Sized a => ByteString - -> SockAddr - -> (Asymm (Encrypted8 a) -> DHTMessage Encrypted8) - -> Either String (DHTMessage Encrypted8, NodeInfo) -direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr) - --- Throws an error if called with a non-internet socket. -asymNodeInfo :: SockAddr -> Asymm a -> NodeInfo -asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (key2id $ senderKey asym) saddr - - -fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b) -fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs - --- Throws an error if called with a non-internet socket. -noReplyAddr :: SockAddr -> NodeInfo -noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr - - -data DHTRequest - -- #### NAT ping request - -- - -- Length Contents - -- :------- :------------------------- - -- `1` `uint8_t` (0xfe) - -- `1` `uint8_t` (0x00) - -- `8` `uint64_t` random number - = NATPing Nonce8 - -- #### NAT ping response - -- - -- Length Contents - -- :------- :----------------------------------------------------------------- - -- `1` `uint8_t` (0xfe) - -- `1` `uint8_t` (0x01) - -- `8` `uint64_t` random number (the same that was received in request) - | NATPong Nonce8 - | DHTPK LongTermKeyWrap - -- From docs/Hardening_docs.txt - -- - -- All hardening requests must contain exactly 384 bytes of data. (The data sent - -- must be padded with zeros if it is smaller than that.) - -- - -- [byte with value: 02 (get nodes test request)][struct Node_format (the node to - -- test.)][client_id(32 bytes) the id to query the node with.][padding] - -- - -- packet id: CRYPTO_PACKET_HARDENING (48) - | Hardening -- TODO - deriving Show - -instance Sized DHTRequest where - size = VarSize $ \case - NATPing _ -> 10 - NATPong _ -> 10 - DHTPK wrap -> 1{-typ-} + 32{-key-} + 24{-nonce-} - + case size of - ConstSize n -> n - VarSize f -> f (wrapData wrap) - Hardening -> 1{-typ-} + 384 - -instance Serialize DHTRequest where - get = do - tag <- get - case tag :: Word8 of - 0xfe -> do - direction <- get - bool NATPong NATPing (direction==(0::Word8)) <$> get - 0x9c -> DHTPK <$> get - 0x30 -> pure Hardening -- TODO: CRYPTO_PACKET_HARDENING - _ -> fail ("unrecognized DHT request: "++show tag) - put (NATPing n) = put (0xfe00 :: Word16) >> put n - put (NATPong n) = put (0xfe01 :: Word16) >> put n - put (DHTPK pk) = put (0x9c :: Word8) >> put pk - put (Hardening) = put (0x30 :: Word8) >> putByteString (B.replicate 384 0) -- TODO - --- DHT public key packet: --- (As Onion data packet?) --- --- | Length | Contents | --- |:------------|:------------------------------------| --- | `1` | `uint8_t` (0x9c) | --- | `8` | `uint64_t` `no_replay` | --- | `32` | Our DHT public key | --- | `[39, 204]` | Maximum of 4 nodes in packed format | -data DHTPublicKey = DHTPublicKey - { dhtpkNonce :: Word64 -- ^ The `no_replay` number is protection if - -- someone tries to replay an older packet and - -- should be set to an always increasing number. - -- It is 8 bytes so you should set a high - -- resolution monotonic time as the value. - , dhtpk :: PublicKey -- dht public key - , dhtpkNodes :: SendNodes -- other reachable nodes - } - deriving (Eq, Show) - - --- int8_t (0x20 sent over onion, 0x12 for sent over net_crypto) --- [uint32_t nospam][Message (UTF8) 1 to ONION_CLIENT_MAX_DATA_SIZE bytes] -data FriendRequest = FriendRequest - { friendNoSpam :: Word32 - , friendRequestText :: ByteString -- UTF8 - } - deriving (Eq, Ord, Show) - - --- When sent as a DHT request packet (this is the data sent in the DHT request --- packet): --- --- Length Contents --- :--------- :------------------------------- --- `1` `uint8_t` (0x9c) --- `32` Long term public key of sender --- `24` Nonce --- variable Encrypted payload -data LongTermKeyWrap = LongTermKeyWrap - { wrapLongTermKey :: PublicKey - , wrapNonce :: Nonce24 - , wrapData :: Encrypted DHTPublicKey - } - deriving Show - -instance Serialize LongTermKeyWrap where - get = LongTermKeyWrap <$> getPublicKey <*> get <*> get - put (LongTermKeyWrap key nonce dta) = putPublicKey key >> put nonce >> put dta - - -instance Sized DHTPublicKey where - -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size. - -- WARNING: Serialize instance does not include this byte FIXME - size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of - ConstSize nodes -> nodes - VarSize sznodes -> sznodes nodes - -instance Sized Word32 where size = ConstSize 4 - --- FIXME: Inconsitently, this type does not include the 0x20 or 0x12 tag byte --- where the DHTPublicKey type does include its tag. -instance Sized FriendRequest where - size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length) - -instance Serialize DHTPublicKey where - -- TODO: This should agree with Sized instance. - get = DHTPublicKey <$> get <*> getPublicKey <*> get - put (DHTPublicKey nonce key nodes) = do - put nonce - putPublicKey key - put nodes - -instance Serialize FriendRequest where - get = FriendRequest <$> get <*> (remaining >>= getBytes) - put (FriendRequest nospam txt) = put nospam >> putByteString txt - -newtype GetNodes = GetNodes NodeId - deriving (Eq,Ord,Show,Read,S.Serialize) - -instance Sized GetNodes where - size = ConstSize 32 -- TODO This right? - -newtype SendNodes = SendNodes [NodeInfo] - deriving (Eq,Ord,Show,Read) - -instance Sized SendNodes where - size = VarSize $ \(SendNodes ns) -> case size of - ConstSize nodeFormatSize -> nodeFormatSize * length ns - VarSize nsize -> sum $ map nsize ns - -instance S.Serialize SendNodes where - get = do - cnt <- S.get :: S.Get Word8 - ns <- sequence $ replicate (fromIntegral cnt) S.get - return $ SendNodes ns - - put (SendNodes ns) = do - let ns' = take 4 ns - S.put (fromIntegral (length ns') :: Word8) - mapM_ S.put ns' - -data Ping = Ping deriving Show -data Pong = Pong deriving Show - -instance S.Serialize Ping where - get = do w8 <- S.get - if (w8 :: Word8) /= 0 - then fail "Malformed ping." - else return Ping - put Ping = S.put (0 :: Word8) - -instance S.Serialize Pong where - get = do w8 <- S.get - if (w8 :: Word8) /= 1 - then fail "Malformed pong." - else return Pong - put Pong = S.put (1 :: Word8) - -newtype CookieRequest = CookieRequest PublicKey - deriving (Eq, Show) -newtype CookieResponse = CookieResponse (Cookie Encrypted) - deriving (Eq, Show) - -data Cookie (f :: * -> *) = Cookie Nonce24 (f CookieData) - -deriving instance Eq (f CookieData) => Eq (Cookie f) -deriving instance Ord (f CookieData) => Ord (Cookie f) -deriving instance Show (f CookieData) => Show (Cookie f) -deriving instance Generic (f CookieData) => Generic (Cookie f) - -instance Hashable (Cookie Encrypted) - -instance Sized (Cookie Encrypted) where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data - -instance Serialize (Cookie Encrypted) where - get = Cookie <$> get <*> get - put (Cookie nonce dta) = put nonce >> put dta - -data CookieData = CookieData -- 16 (mac) - { cookieTime :: Word64 -- 8 - , longTermKey :: PublicKey -- 32 - , dhtKey :: PublicKey -- + 32 - } -- = 88 bytes when encrypted. - deriving (Show, Generic) - -instance Sized CookieData where - size = ConstSize 72 - -instance Serialize CookieData where - get = CookieData <$> get <*> getPublicKey <*> getPublicKey - put (CookieData tm userkey dhtkey) = do - put tm - putPublicKey userkey - putPublicKey userkey - -instance Sized CookieRequest where - size = ConstSize 64 -- 32 byte key + 32 byte padding - -instance Serialize CookieRequest where - get = CookieRequest <$> getPublicKey <* {- padding -} getPublicKey - put (CookieRequest k) = putPublicKey k >> {- padding -} putPublicKey k - -forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport -forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' } - where - await' :: HandleHi a -> IO a - await' pass = awaitMessage dht $ \case - Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto - -> do mni <- closeLookup target - -- Forward the message if the target is in our close list. - forM_ mni $ \ni -> sendMessage dht ni m - await' pass - m -> pass m - -encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> IO (DHTMessage Encrypted8, NodeInfo) -encrypt crypto msg ni = do - let cipher n plain = Composed $ encryptMessage crypto (id2key $ nodeId ni) n plain - m <- sequenceMessage $ transcode cipher msg - return (m, ni) - -encryptMessage :: Serialize a => - TransportCrypto -> - PublicKey -> - Nonce24 -> Either (Nonce8,a) (Asymm (Nonce8,a)) -> IO (Encrypted8 a) -encryptMessage crypto destKey n arg = do - let plain = encodePlain $ swap $ either id asymmData arg - secret <- lookupSharedSecret crypto (transportSecret crypto) destKey n - return $ E8 $ ToxCrypto.encrypt secret plain - -decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> IO (Either String (DHTMessage ((,) Nonce8), NodeInfo)) -decrypt crypto msg ni = do - let decipher n c = Composed $ decryptMessage crypto n . left ((,) $ id2key $ nodeId ni) $ c - msg' <- sequenceMessage $ transcode decipher msg - return $ fmap (, ni) $ sequenceMessage msg' - -decryptMessage :: Serialize x => - TransportCrypto - -> Nonce24 - -> Either (PublicKey, Encrypted8 x) (Asymm (Encrypted8 x)) - -> IO ((Either String ∘ ((,) Nonce8)) x) -decryptMessage crypto n arg = do - let (remotekey,E8 e) = either id (senderKey &&& asymmData) arg - plain8 = Composed . fmap swap . (>>= decodePlain) - secret <- lookupSharedSecret crypto (transportSecret crypto) remotekey n - return $ plain8 $ ToxCrypto.decrypt secret e - -sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f) -sequenceMessage (DHTPing asym) = fmap DHTPing $ sequenceA $ fmap uncomposed asym -sequenceMessage (DHTPong asym) = fmap DHTPong $ sequenceA $ fmap uncomposed asym -sequenceMessage (DHTGetNodes asym) = fmap DHTGetNodes $ sequenceA $ fmap uncomposed asym -sequenceMessage (DHTSendNodes asym) = fmap DHTSendNodes $ sequenceA $ fmap uncomposed asym -sequenceMessage (DHTCookieRequest asym) = fmap DHTCookieRequest $ sequenceA $ fmap uncomposed asym -sequenceMessage (DHTCookie n dta) = fmap (DHTCookie n) $ uncomposed dta -sequenceMessage (DHTDHTRequest pubkey asym) = fmap (DHTDHTRequest pubkey) $ sequenceA $ fmap uncomposed asym -sequenceMessage (DHTLanDiscovery nid) = pure $ DHTLanDiscovery nid - -transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> DHTMessage f -> DHTMessage g -transcode f (DHTPing asym) = DHTPing $ asym { asymmData = f (asymmNonce asym) (Right asym) } -transcode f (DHTPong asym) = DHTPong $ asym { asymmData = f (asymmNonce asym) (Right asym) } -transcode f (DHTGetNodes asym) = DHTGetNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) } -transcode f (DHTSendNodes asym) = DHTSendNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) } -transcode f (DHTCookieRequest asym) = DHTCookieRequest $ asym { asymmData = f (asymmNonce asym) (Right asym) } -transcode f (DHTCookie n dta) = DHTCookie n $ f n $ Left dta -transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { asymmData = f (asymmNonce asym) (Right asym) } -transcode f (DHTLanDiscovery nid) = DHTLanDiscovery nid diff --git a/src/Network/Tox/Handshake.hs b/src/Network/Tox/Handshake.hs deleted file mode 100644 index c48b7415..00000000 --- a/src/Network/Tox/Handshake.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -module Network.Tox.Handshake where - -import Control.Arrow -import Control.Concurrent.STM -import Control.Monad -import Crypto.Hash -import Crypto.Tox -import Data.Functor.Identity -import Data.Time.Clock.POSIX -import Network.Tox.Crypto.Transport -import Network.Tox.DHT.Handlers (createCookieSTM) -import Network.Tox.DHT.Transport (Cookie (..), CookieData (..)) -import Network.Tox.NodeId -#ifdef THREAD_DEBUG -#else -import Control.Concurrent -import GHC.Conc (labelThread) -#endif -import DPut -import DebugTag - - -anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1) -anyRight e [] f = return $ Left e -anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right) - -decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (SecretKey,Handshake Identity)) -decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do - (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto - <*> transportSymmetric crypto - let seckeys = map fst ukeys - now <- getPOSIXTime - -- dput XNetCrypto "decryptHandshake: trying the following keys:" - -- forM_ seckeys $ \k -> dput XNetCrypto $ " " ++ show (key2id . toPublic $ k) - fmap join . sequence $ do -- Either Monad - cd@(CookieData cookieTime remotePubkey remoteDhtkey) <- decodePlain =<< decryptSymmetric symkey n24 ecookie - Right $ do -- IO Monad - decrypted <- anyRight "missing key" seckeys $ \key -> do - -- dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey = " ++ show (key2id $ remotePubkey) - -- dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 = " ++ show nonce24 - secret <- lookupSharedSecret crypto key remotePubkey nonce24 - let step1 = decrypt secret encrypted - case step1 of - Left s -> do - -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s - return (Left s) - Right pln -> do - case decodePlain pln of - Left s -> do - -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s - return (Left s) - Right x -> return (Right (key,x)) - return $ do -- Either Monad - (key,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted - left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15) - let hinit = hashInit - hctx = hashUpdate hinit n24 - hctx' = hashUpdate hctx ecookie - digest = hashFinalize hctx' - left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest) - return ( key - , hshake { handshakeCookie = Cookie n24 (pure cd) - , handshakeData = pure hsdata - } ) - - -data HandshakeParams - = HParam - { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own - , hpOtherCookie :: Cookie Encrypted - , hpTheirSessionKeyPublic :: Maybe PublicKey - , hpMySecretKey :: SecretKey - , hpCookieRemotePubkey :: PublicKey - , hpCookieRemoteDhtkey :: PublicKey - } - -newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData -newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do - let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp - hinit = hashInit - Cookie n24 encrypted = hpOtherCookie - hctx = hashUpdate hinit n24 - hctx' = hashUpdate hctx encrypted - digest = hashFinalize hctx' - freshCookie <- createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey - return HandshakeData - { baseNonce = basenonce - , sessionKey = mySessionPublic - , cookieHash = digest - , otherCookie = freshCookie - } - -toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams -toHandshakeParams (key,hs) - = let hd = runIdentity $ handshakeData hs - Cookie _ cd0 = handshakeCookie hs - CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0 - in HParam { hpTheirBaseNonce = Just $ baseNonce hd - , hpOtherCookie = otherCookie hd - , hpTheirSessionKeyPublic = Just $ sessionKey hd - , hpMySecretKey = key - , hpCookieRemotePubkey = remotePublicKey - , hpCookieRemoteDhtkey = remoteDhtPublicKey - } - -encodeHandshake :: POSIXTime - -> TransportCrypto - -> SecretKey - -> PublicKey - -> Cookie Encrypted - -> HandshakeData - -> STM (Handshake Encrypted) -encodeHandshake timestamp crypto me them otherCookie myhandshakeData = do - n24 <- transportNewNonce crypto - state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto me them - return Handshake { handshakeCookie = otherCookie - , handshakeNonce = n24 - , handshakeData = encrypt state $ encodePlain myhandshakeData - } diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs deleted file mode 100644 index 9a9c893a..00000000 --- a/src/Network/Tox/NodeId.hs +++ /dev/null @@ -1,731 +0,0 @@ -{- LANGUAGE ApplicativeDo -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{- LANGUAGE TypeApplications -} -module Network.Tox.NodeId - ( NodeInfo(..) - , NodeId - , nodeInfo - , nodeAddr - , zeroID - , key2id - , id2key - , getIP - , xorNodeId - , testNodeIdBit - , sampleNodeId - , NoSpam(..) - , NoSpamId(..) - , noSpamIdToHex - , parseNoSpamId - , nospam64 - , nospam16 - , verifyChecksum - , ToxContact(..) - , ToxProgress(..) - , parseToken32 - , showToken32 - ) where - -import Control.Applicative -import Control.Arrow -import Control.Monad -#ifdef CRYPTONITE_BACKPORT -import Crypto.Error.Types (CryptoFailable (..), - throwCryptoError) -#else -import Crypto.Error -#endif - -import Crypto.PubKey.Curve25519 -import qualified Data.Aeson as JSON - ;import Data.Aeson (FromJSON, ToJSON, (.=)) -import Data.Bits.ByteString () -import qualified Data.ByteArray as BA - ;import Data.ByteArray as BA (ByteArrayAccess) -import qualified Data.ByteString as B - ;import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Base64 as Base64 -import qualified Data.ByteString.Char8 as C8 -import Data.Char -import Data.Data -import Data.Hashable -#if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) -#else -import Data.IP -#endif -import Data.List -import Data.Maybe -import Data.Serialize as S -import Data.Word -import Foreign.Storable -import GHC.TypeLits -import Network.Address hiding (nodePort) -import System.IO.Unsafe (unsafeDupablePerformIO) -import qualified Text.ParserCombinators.ReadP as RP -import Text.Read hiding (get) -import Data.Bits -import Crypto.Tox -import Foreign.Ptr -import Data.Function -import System.Endian -import qualified Data.Text as Text - ;import Data.Text (Text) -import Util (splitJID) - --- | perform io for hashes that do allocation and ffi. --- unsafeDupablePerformIO is used when possible as the --- computation is pure and the output is directly linked --- to the input. we also do not modify anything after it has --- been returned to the user. -unsafeDoIO :: IO a -> a -#if __GLASGOW_HASKELL__ > 704 -unsafeDoIO = unsafeDupablePerformIO -#else -unsafeDoIO = unsafePerformIO -#endif - -unpackPublicKey :: ByteArrayAccess bs => bs -> [Word64] -unpackPublicKey bs = loop 0 - where loop i - | i == (BA.length bs `div` 8) = [] - | otherwise = - let !v = unsafeDoIO $ BA.withByteArray bs (\p -> fromBE64 <$> peekElemOff p i) - in v : loop (i+1) - -packPublicKey :: BA.ByteArray bs => [Word64] -> bs -packPublicKey ws = BA.allocAndFreeze (8 * length ws) $ - flip fix ws $ \loop ys ptr -> case ys of - [] -> return () - x:xs -> do poke ptr (toBE64 x) - loop xs (plusPtr ptr 8) -{-# NOINLINE packPublicKey #-} - --- We represent the node id redundantly in two formats. The [Word64] format is --- convenient for short-circuiting xor/distance comparisons. The PublicKey --- format is convenient for encryption. -data NodeId = NodeId [Word64] !(Maybe PublicKey) - deriving Data - -instance Data PublicKey where - -- Data a => (forall d b . Data d => c (d -> b) -> d -> c b) -> (forall g . g -> c g) -> a -> c a - gfoldl f z txt = z (throwCryptoError . publicKey) `f` (BA.convert txt :: ByteString) - toConstr _ = error "Crypto.PubKey.Curve25519.toConstr" - gunfold _ _ = error "Crypto.PubKey.Curve25519.gunfold" -#if MIN_VERSION_base(4,2,0) - dataTypeOf _ = mkNoRepType "Crypto.PubKey.Curve25519.PublicKey" -#else - dataTypeOf _ = mkNorepType "Crypto.PubKey.Curve25519.PublicKey" -#endif - - -instance Eq NodeId where - (NodeId ws _) == (NodeId xs _) - = ws == xs - -instance Ord NodeId where - compare (NodeId ws _) (NodeId xs _) = compare ws xs - -instance Sized NodeId where size = ConstSize 32 - -key2id :: PublicKey -> NodeId -key2id k = NodeId (unpackPublicKey k) (Just k) - -bs2id :: ByteString -> NodeId -bs2id bs = uncurry NodeId . (unpackPublicKey &&& Just) $ throwCryptoError . publicKey $ bs - -id2key :: NodeId -> PublicKey -id2key (NodeId ws (Just key)) = key -id2key (NodeId key Nothing) = throwCryptoError . publicKey $ (packPublicKey key :: BA.Bytes) - -zeroKey :: PublicKey -zeroKey = throwCryptoError $ publicKey $ B.replicate 32 0 - -zeroID :: NodeId -zeroID = NodeId (replicate 4 0) (Just zeroKey) - --- | Convert to and from a Base64 variant that uses .- instead of +/. -nmtoken64 :: Bool -> Char -> Char -nmtoken64 False '.' = '+' -nmtoken64 False '-' = '/' -nmtoken64 True '+' = '.' -nmtoken64 True '/' = '-' -nmtoken64 _ c = c - --- | Parse 43-digit base64 token into 32-byte bytestring. -parseToken32 :: String -> Either String ByteString -parseToken32 str = fmap (BA.drop 1) $ Base64.decode $ C8.pack $ 'A':map (nmtoken64 False) (take 43 str) - --- | Encode 32-byte bytestring as 43-digit base64 token. -showToken32 :: ByteArrayAccess bin => bin -> String -showToken32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs - -instance Read NodeId where - readsPrec _ str - | (bs,_) <- Base16.decode (C8.pack $ take 64 str) - , CryptoPassed pub <- publicKey bs -- B.length bs == 32 - = [ (key2id pub, drop (2 * B.length bs) str) ] - | Right bs <- parseToken32 str - , CryptoPassed pub <- publicKey bs -- B.length bs == 32 - = [ (key2id pub, drop 43 str) ] - | otherwise = [] - -instance Show NodeId where - show nid = showToken32 $ id2key nid - -instance S.Serialize NodeId where - get = key2id <$> getPublicKey - put nid = putPublicKey $ id2key nid - -instance Hashable NodeId where - hashWithSalt salt (NodeId ws _) = hashWithSalt salt (head ws) - -testNodeIdBit :: NodeId -> Word -> Bool -testNodeIdBit (NodeId ws _) i -- TODO: Optmize: use ByteArray key if it's available. - | fromIntegral i < 256 -- 256 bits - , (q, r) <- quotRem (fromIntegral i) 64 - = testBit (ws !! q) (63 - r) - | otherwise = False - -xorNodeId :: NodeId -> NodeId -> NodeId -xorNodeId (NodeId xs _) (NodeId ys _) = NodeId (zipWith xor xs ys) Nothing - -sampleNodeId :: Applicative m => (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId -sampleNodeId gen (NodeId self k) (q,m,b) - | q <= 0 = bs2id <$> gen 32 - | q >= 32 = pure (NodeId self k) - | let (qw,r) = (q+7) `divMod` 8 -- How many Word64 to prepend? - bw = shiftL (fromIntegral b) (8*(7-r)) - mw = bw - 1 :: Word64 - (hd, t0 : _) = splitAt (qw-1) self - h = xor bw (complement mw .&. t0) - = flip fmap (gen $ 8 * (4 - (qw-1)) ) $ \bs -> - let (w:ws) = unpackPublicKey bs - in NodeId (hd ++ (h .|. (w .&. mw)) : ws) Nothing - -data NodeInfo = NodeInfo - { nodeId :: NodeId - , nodeIP :: IP - , nodePort :: PortNumber - } - deriving (Eq,Ord) - -nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo -nodeInfo nid saddr - | Just ip <- fromSockAddr saddr - , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port - | otherwise = Left "Address family not supported." - - -instance ToJSON NodeInfo where - toJSON (NodeInfo nid (IPv4 ip) port) - = JSON.object [ "public_key" .= show nid - , "ipv4" .= show ip - , "port" .= (fromIntegral port :: Int) - ] - toJSON (NodeInfo nid (IPv6 ip6) port) - | Just ip <- un4map ip6 - = JSON.object [ "public_key" .= show nid - , "ipv4" .= show ip - , "port" .= (fromIntegral port :: Int) - ] - | otherwise - = JSON.object [ "public_key" .= show nid - , "ipv6" .= show ip6 - , "port" .= (fromIntegral port :: Int) - ] -instance FromJSON NodeInfo where - parseJSON (JSON.Object v) = do - nidstr <- v JSON..: "public_key" - ip6str <- v JSON..:? "ipv6" - ip4str <- v JSON..:? "ipv4" - portnum <- v JSON..: "port" - ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) - <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) - let (bs,_) = Base16.decode (C8.pack nidstr) - enid = Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr) - idbs <- (guard (B.length bs == 32) >> return bs) - <|> either fail (return . B.drop 1) enid - return $ NodeInfo (bs2id idbs) ip (fromIntegral (portnum :: Word16)) - -getIP :: Word8 -> S.Get IP -getIP 0x02 = IPv4 <$> S.get -getIP 0x0a = IPv6 <$> S.get -getIP 0x82 = IPv4 <$> S.get -- TODO: TCP -getIP 0x8a = IPv6 <$> S.get -- TODO: TCP -getIP x = fail ("unsupported address family ("++show x++")") - -instance Sized NodeInfo where - size = VarSize $ \(NodeInfo nid ip port) -> - case ip of - IPv4 _ -> 39 -- 35 + 4 = 1 + 4 + 2 + 32 - IPv6 _ -> 51 -- 35 + 16 = 1 + 16 + 2 + 32 - -instance S.Serialize NodeInfo where - get = do - addrfam <- S.get :: S.Get Word8 - let fallback = do -- FIXME: Handle unrecognized address families. - IPv6 <$> S.get - return $ IPv6 (read "::" :: IPv6) - ip <- getIP addrfam <|> fallback - port <- S.get :: S.Get PortNumber - nid <- S.get - return $ NodeInfo nid ip port - - put (NodeInfo nid ip port) = do - case ip of - IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 - IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 - S.put port - S.put nid - -hexdigit :: Char -> Bool -hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') - -b64digit :: Char -> Bool -b64digit '.' = True -b64digit '+' = True -b64digit '-' = True -b64digit '/' = True -b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z') - -ip_w_port :: Int -> RP.ReadP (IP, PortNumber) -ip_w_port i = do - ip <- RP.between (RP.char '[') (RP.char ']') - (IPv6 <$> RP.readS_to_P (readsPrec i)) - RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) - _ <- RP.char ':' - port <- toEnum <$> RP.readS_to_P (readsPrec i) - return (ip, port) - - -instance Read NodeInfo where - readsPrec i = RP.readP_to_S $ do - RP.skipSpaces - let n = 43 -- characters in node id. - parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) - RP.+++ RP.munch (\c -> not (isSpace c) && not (c `elem` ("{}()"::[Char]))) - nodeidAt = do (is64,hexhash) <- - fmap (True,) (sequence $ replicate n (RP.satisfy b64digit)) - RP.+++ fmap (False,) (sequence $ replicate 64 (RP.satisfy isHexDigit)) - RP.char '@' RP.+++ RP.satisfy isSpace - addrstr <- parseAddr - nid <- if is64 - then case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of - Right bs | B.length bs - 1==32 -> return (bs2id $ BA.drop 1 bs) - _ -> fail "Bad node id." - else case Base16.decode $ C8.pack hexhash of - (bs,rem) | B.length bs == 32 && B.null rem -> return (bs2id bs) - _ -> fail "Bad node id." - return (nid,addrstr) - (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) - (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of - [] -> fail "Bad address." - ((ip,port),_):_ -> return (ip,port) - return $ NodeInfo nid ip port - --- The Hashable instance depends only on the IP address and port number. --- --- TODO: Why is the node id excluded? -instance Hashable NodeInfo where - hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) - {-# INLINE hashWithSalt #-} - - -instance Show NodeInfo where - showsPrec _ (NodeInfo nid ip port) = - shows nid . ('@' :) . showsip . (':' :) . shows port - where - showsip - | IPv4 ip4 <- ip = shows ip4 - | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 - | otherwise = ('[' :) . shows ip . (']' :) - - - - -{- -type NodeId = PubKey - -pattern NodeId bs = PubKey bs - --- TODO: This should probably be represented by Curve25519.PublicKey, but --- ByteString has more instances... -newtype PubKey = PubKey ByteString - deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable) - -instance Serialize PubKey where - get = PubKey <$> getBytes 32 - put (PubKey bs) = putByteString bs - -instance Show PubKey where - show (PubKey bs) = C8.unpack $ Base16.encode bs - -instance FiniteBits PubKey where - finiteBitSize _ = 256 - -instance Read PubKey where - readsPrec _ str - | (bs, xs) <- Base16.decode $ C8.pack str - , B.length bs == 32 - = [ (PubKey bs, drop 64 str) ] - | otherwise = [] - - - - -data NodeInfo = NodeInfo - { nodeId :: NodeId - , nodeIP :: IP - , nodePort :: PortNumber - } - deriving (Eq,Ord,Data) - -instance Data PortNumber where - dataTypeOf _ = mkNoRepType "PortNumber" - toConstr _ = error "PortNumber.toConstr" - gunfold _ _ = error "PortNumber.gunfold" - -instance ToJSON NodeInfo where - toJSON (NodeInfo nid (IPv4 ip) port) - = JSON.object [ "public_key" .= show nid - , "ipv4" .= show ip - , "port" .= (fromIntegral port :: Int) - ] - toJSON (NodeInfo nid (IPv6 ip6) port) - | Just ip <- un4map ip6 - = JSON.object [ "public_key" .= show nid - , "ipv4" .= show ip - , "port" .= (fromIntegral port :: Int) - ] - | otherwise - = JSON.object [ "public_key" .= show nid - , "ipv6" .= show ip6 - , "port" .= (fromIntegral port :: Int) - ] -instance FromJSON NodeInfo where - parseJSON (JSON.Object v) = do - nidstr <- v JSON..: "public_key" - ip6str <- v JSON..:? "ipv6" - ip4str <- v JSON..:? "ipv4" - portnum <- v JSON..: "port" - ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) - <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) - let (bs,_) = Base16.decode (C8.pack nidstr) - guard (B.length bs == 32) - return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16)) - -getIP :: Word8 -> S.Get IP -getIP 0x02 = IPv4 <$> S.get -getIP 0x0a = IPv6 <$> S.get -getIP 0x82 = IPv4 <$> S.get -- TODO: TCP -getIP 0x8a = IPv6 <$> S.get -- TODO: TCP -getIP x = fail ("unsupported address family ("++show x++")") - -instance S.Serialize NodeInfo where - get = do - addrfam <- S.get :: S.Get Word8 - ip <- getIP addrfam - port <- S.get :: S.Get PortNumber - nid <- S.get - return $ NodeInfo nid ip port - - put (NodeInfo nid ip port) = do - case ip of - IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 - IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 - S.put port - S.put nid - --- node format: --- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)] --- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6] --- [port (in network byte order), length=2 bytes] --- [char array (node_id), length=32 bytes] --- - - -hexdigit :: Char -> Bool -hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') - -instance Read NodeInfo where - readsPrec i = RP.readP_to_S $ do - RP.skipSpaces - let n = 64 -- characters in node id. - parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) - RP.+++ RP.munch (not . isSpace) - nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit) - RP.char '@' RP.+++ RP.satisfy isSpace - addrstr <- parseAddr - nid <- case Base16.decode $ C8.pack hexhash of - (bs,_) | B.length bs==32 -> return (PubKey bs) - _ -> fail "Bad node id." - return (nid,addrstr) - (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) - let raddr = do - ip <- RP.between (RP.char '[') (RP.char ']') - (IPv6 <$> RP.readS_to_P (readsPrec i)) - RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) - _ <- RP.char ':' - port <- toEnum <$> RP.readS_to_P (readsPrec i) - return (ip, port) - - (ip,port) <- case RP.readP_to_S raddr addrstr of - [] -> fail "Bad address." - ((ip,port),_):_ -> return (ip,port) - return $ NodeInfo nid ip port - - --- The Hashable instance depends only on the IP address and port number. -instance Hashable NodeInfo where - hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) - {-# INLINE hashWithSalt #-} - - -instance Show NodeInfo where - showsPrec _ (NodeInfo nid ip port) = - shows nid . ('@' :) . showsip . (':' :) . shows port - where - showsip - | IPv4 ip4 <- ip = shows ip4 - | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 - | otherwise = ('[' :) . shows ip . (']' :) - -nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo -nodeInfo nid saddr - | Just ip <- fromSockAddr saddr - , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port - | otherwise = Left "Address family not supported." - -zeroID :: NodeId -zeroID = PubKey $ B.replicate 32 0 - --} - -nodeAddr :: NodeInfo -> SockAddr -nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip - - -newtype ForwardPath (n::Nat) = ForwardPath ByteString - deriving (Eq, Ord,Data) - -{- -class KnownNat n => OnionPacket n where - mkOnion :: ReturnPath n -> Packet -> Packet -instance OnionPacket 0 where mkOnion _ = id -instance OnionPacket 3 where mkOnion = OnionResponse3 --} - -data NoSpam = NoSpam !Word32 !(Maybe Word16) - deriving (Eq,Ord,Show) - -instance Serialize NoSpam where - get = NoSpam <$> get <*> get - put (NoSpam w32 w16) = do - put w32 - put w16 - --- Utilizes Data.Serialize format for Word32 nospam and Word16 checksum. -instance Read NoSpam where - readsPrec d s = case break isSpace s of - ('$':ws ,rs) | (length ws == 8) -> base64decode rs (NoSpam <$> get <*> (Just <$> get)) ws - ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws - _ -> [] - -base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1) -base64decode rs getter s = - either fail (\a -> return (a,rs)) - $ runGet getter - =<< Base64.decode (C8.pack $ map (nmtoken64 False) s) - -base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1) -base16decode rs getter s = - either fail (\a -> return (a,rs)) - $ runGet getter - $ fst - $ Base16.decode (C8.pack s) - -verifyChecksum :: PublicKey -> Word16 -> Either String () -verifyChecksum _ _ = return () -- TODO - -data NoSpamId = NoSpamId NoSpam PublicKey - deriving (Eq,Ord) - -noSpamIdToHex :: NoSpamId -> String -noSpamIdToHex (NoSpamId nspam pub) = C8.unpack (Base16.encode $ BA.convert pub) - ++ nospam16 nspam - -nospam16 :: NoSpam -> String -nospam16 (NoSpam w32 Nothing) = n ++ "????" - where n = take 8 $ nospam16 (NoSpam w32 (Just 0)) -nospam16 (NoSpam w32 (Just w16)) = C8.unpack $ Base16.encode $ runPut $ do - put w32 - put w16 - -nospam64 :: NoSpam -> String -nospam64 (NoSpam w32 Nothing) = n ++ "???" - where n = take 5 $ nospam64 (NoSpam w32 (Just 0)) -nospam64 (NoSpam w32 (Just w16)) = map (nmtoken64 True) $ C8.unpack $ Base64.encode $ runPut $ do - put w32 - put w16 - -instance Show NoSpamId where - show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox" - -instance Read NoSpamId where - readsPrec d s = either fail id $ do - (jid,xs) <- Right $ break isSpace s - nsid <- parseNoSpamId $ Text.pack jid - return [(nsid,xs)] - -parseNoSpamHex :: Text -> Either String NoSpamId -parseNoSpamHex hex = Right $ NoSpamId (read $ "0x"++nospamsum) (id2key $ read hkey) - where - (hkey,nospamsum) = splitAt 64 $ Text.unpack hex - -parseNoSpamId :: Text -> Either String NoSpamId -parseNoSpamId spec | Text.length spec == 76 - , Text.all isHexDigit spec = parseNoSpamHex spec - | otherwise = parseNoSpamJID spec - -parseNoSpamJID :: Text -> Either String NoSpamId -parseNoSpamJID jid = do - (u,h) <- maybe (Left "Invalid JID.") Right - $ let (mu,h,_) = splitJID jid - in fmap (, h) mu - base64 <- case splitAt 43 $ Text.unpack h of - (base64,".tox") -> Right base64 - _ -> Left "Hostname should be 43 base64 digits followed by .tox." - pub <- id2key <$> readEither base64 - let ustr = Text.unpack u - case ustr of - '$' : b64digits -> solveBase64NoSpamID b64digits pub - '0' : 'x' : hexdigits -> do nospam <- readEither ('0':'x':hexdigits) - return $ NoSpamId nospam pub - _ -> Left "Missing nospam." - -solveBase64NoSpamID :: String -> PublicKey -> Either String NoSpamId -solveBase64NoSpamID b64digits pub = do - NoSpam nospam mx <- readEither $ '$' : map (\case; '?' -> '0'; c -> c) b64digits - maybe (const $ Left "missing checksum") (flip ($)) mx $ \x -> do - let nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 - nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 - sum = x `xor` nlo `xor` nhi `xor` xorsum pub - -- Find any question mark indices. - qs = catMaybes $ zipWith (\case; '?' -> Just ; _ -> const Nothing) b64digits [0..7] - -- Break up the /sum/ into a numbered list of two-bit non-zero nibbles. - ns = filter (\case; (_,0) -> False; _ -> True) - $ zip [0..7] - $ unfoldr (\s -> Just (s .&. 0xC000, s `shiftL` 2)) sum - -- Represent the nospam value as a Word64 - n64 = shiftL (fromIntegral nospam) 32 .|. shiftL (fromIntegral x) 16 :: Word64 - - -- q=0 1 2 3 4 5 6 7 - -- 012 345 670 123 456 701 234 567 - nibblePlace n q = case mod (n - 3 * q) 8 of - p | p < 3 -> Just (q,p) - _ -> Nothing - - solve [] !ac = Right ac - solve ((n,b):ns) !ac = do - -- Find nibble p of question-digit q that corresponds to nibble n. - (q,p) <- maybe (Left "Unsolvable nospam.") Right - $ foldr (<|>) Nothing $ map (nibblePlace n) qs - let bitpos = q * 6 + p * 2 - ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos - solve ns ac' - n64' <- solve ns n64 - let nospam' = fromIntegral (n64' `shiftR` 32) - cksum' = fromIntegral (n64' `shiftR` 16) - return $ NoSpamId (NoSpam nospam' (Just cksum')) pub - --- | This type indicates a roster-link relationship between a local toxid and a --- remote toxid. Note that these toxids are represented as the type 'NodeId' --- even though they are long-term keys rather than the public keys of Tox DHT --- nodes. -data ToxContact = ToxContact NodeId{-me-} NodeId{-them-} - deriving (Eq,Ord) - -instance Show ToxContact where show = show . showToxContact_ - -showToxContact_ :: ToxContact -> String -showToxContact_ (ToxContact me them) = show me ++ ":" ++ show them - --- | 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) - diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs deleted file mode 100644 index f44dd79c..00000000 --- a/src/Network/Tox/Onion/Handlers.hs +++ /dev/null @@ -1,369 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -module Network.Tox.Onion.Handlers where - -import Network.Kademlia.Search -import Network.Tox.DHT.Transport -import Network.Tox.DHT.Handlers hiding (Message,Client) -import Network.Tox.Onion.Transport -import Network.QueryResponse as QR hiding (Client) -import qualified Network.QueryResponse as QR (Client) -import Crypto.Tox -import qualified Data.Wrapper.PSQ as PSQ - ;import Data.Wrapper.PSQ (PSQ,pattern (:->)) -import Control.Arrow - -import Data.Function -import qualified Data.MinMaxPSQ as MinMaxPSQ - ;import Data.MinMaxPSQ (MinMaxPSQ') -import Network.BitTorrent.DHT.Token as Token - -import Control.Exception hiding (Handler) -import Control.Monad -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent -import GHC.Conc (labelThread) -#endif -import Control.Concurrent.STM -import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import Network.Socket -#if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) -#else -import Data.IP -#endif -import Data.Maybe -import Data.Functor.Identity -import DPut -import DebugTag - -type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message -type Message = OnionMessage Identity - -classify :: Message -> MessageClass String PacketKind TransactionId (OnionDestination r) Message -classify msg = go msg - where - go (OnionAnnounce announce) = IsQuery AnnounceType - $ TransactionId (snd $ runIdentity $ asymmData announce) - (asymmNonce announce) - go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24) - go (OnionToRoute {}) = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24)) - go (OnionToRouteResponse {}) = IsResponse (TransactionId (Nonce8 0) (Nonce24 zeros24)) - --- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time, --- some secret bytes generated when the instance is created, the current time --- divided by a 20 second timeout, the public key of the requester and the source --- ip/port that the packet was received from. Since the ip/port that the packet --- was received from is in the `ping_id`, the announce packets being sent with a --- ping id must be sent using the same path as the packet that we received the --- `ping_id` from or announcing will fail. --- --- The reason for this 20 second timeout in toxcore is that it gives a reasonable --- time (20 to 40 seconds) for a peer to announce himself while taking in count --- all the possible delays with some extra seconds. -announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse -announceH routing toks keydb oaddr req = do - case () of - _ | announcePingId req == zeros32 - -> go False - - _ -> let Nonce32 bs = announcePingId req - tok = fromPaddedByteString 32 bs - in checkToken toks (onionNodeInfo oaddr) tok >>= go - `catch` (\(SomeException e) -> dput XAnnounce ("announceH Exception! "++show e) >> throw e) - where - go withTok = do - let naddr = onionNodeInfo oaddr - ns <- getNodesH routing naddr (GetNodes (announceSeeking req)) - tm <- getPOSIXTime - - let storing = case oaddr of - OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth - _ -> Nothing - dput XAnnounce $ unlines [ "announceH: nodeId = " ++ show (nodeId naddr) - , " announceSeeking = " ++ show (announceSeeking req) - , " withTok = " ++ show withTok - , " storing = " ++ maybe "False" (const "True") storing - ] - record <- atomically $ do - forM_ storing $ \retpath -> when withTok $ do - let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath - -- Note: The following distance calculation assumes that - -- our nodeid doesn't change and is the same for both - -- routing4 and routing6. - d = xorNodeId (nodeId (tentativeId routing)) - (announceSeeking req) - modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d) - ks <- readTVar keydb - return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks) - newtok <- maybe (return $ zeros32) - (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr) - storing - let k = case record of - Nothing -> NotStored newtok - Just _ | isJust storing -> Acknowledged newtok - Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni) - let response = AnnounceResponse k ns - dput XAnnounce $ unwords ["Announce:", show req, "-reply->", show response] - return response - -dataToRouteH :: - TVar AnnouncedKeys - -> Transport err (OnionDestination r) (OnionMessage f) - -> addr - -> OnionMessage f - -> IO () -dataToRouteH keydb udp _ (OnionToRoute pub asymm) = do - let k = key2id pub - dput XOnion $ "dataToRouteH "++ show k - mb <- atomically $ do - ks <- readTVar keydb - forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do - writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) } - return rpath - dput XOnion $ "dataToRouteH "++ show (fmap (const ()) mb) - forM_ mb $ \rpath -> do - -- forward - dput XOnion $ "dataToRouteH sendMessage" - sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse asymm - dput XOnion $ "Forwarding data-to-route -->"++show k - -type NodeDistance = NodeId - -data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3) - -toOnionDestination :: AnnouncedRoute -> OnionDestination r -toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath - --- | --- The type 'NodeId' was originally made for the DHT key, but here --- we reuse it for user keys (public key/real key). --- --- To find someone using their user (public) key, you search for it on --- kademlia. At each iteration of the search, you get a response with --- closest known nodes(DHT keys) to the key you are searching for. --- --- To do an 'Announce' so your friends can find you, you do a search to --- find the closest nodes to your own user(public) key. At those nodes, --- you store a route back to yourself (using Announce message) so your --- friends can contact you. This means each node needs to store the --- saved routes, and that is the purpose of the 'AnnouncedKeys' data --- structure. --- -data AnnouncedKeys = AnnouncedKeys - { keyByAge :: !(PSQ NodeId (POSIXTime{-Time at which they announced to you-})) - , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute)) - -- ^ PSQ using NodeId(user/public key) as Key - -- and using 'NodeDistance' as priority. - -- (smaller number is higher priority) - -- - -- Keeping in a MinMaxPSQ will help us later when we want to make the structure - -- bounded. (We simply throw away the most NodeDistant keys. - } - - -insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys -insertKey tm pub toxpath d keydb = AnnouncedKeys - { keyByAge = PSQ.insert pub tm (keyByAge keydb) - , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of - Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb) - Nothing -> MinMaxPSQ.insert' pub (0 ,toxpath) d (keyAssoc keydb) - } - --- | Forks a thread to garbage-collect old key announcements. Keys may be --- discarded after 5 minutes. -forkAnnouncedKeysGC :: TVar AnnouncedKeys -> IO ThreadId -forkAnnouncedKeysGC db = forkIO $ do - myThreadId >>= flip labelThread "gc:toxids" - fix $ \loop -> do - cutoff <- getPOSIXTime - threadDelay 300000000 -- 300 seconds - join $ atomically $ do - fix $ \gc -> do - keys <- readTVar db - case PSQ.minView (keyByAge keys) of - Nothing -> return loop - Just (pub :-> tm,kba') - | tm > cutoff -> return loop - | otherwise -> do writeTVar db keys - { keyByAge = kba' - , keyAssoc = MinMaxPSQ.delete pub (keyAssoc keys) - } - gc - -areq :: Message -> Either String AnnounceRequest -areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm -areq _ = Left "Unexpected non-announce OnionMessage" - -handlers :: Transport err (OnionDestination r) Message - -> Routing - -> TVar SessionTokens - -> TVar AnnouncedKeys - -> PacketKind - -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message) -handlers net routing toks keydb AnnounceType - = Just - $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity) - $ announceH routing toks keydb -handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net - - -toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) - -> TransportCrypto - -> Client r - -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous -toxidSearch getTimeout crypto client = Search - { searchSpace = toxSpace - , searchNodeAddress = nodeIP &&& nodePort - , searchQuery = Right $ asyncGetRendezvous getTimeout crypto client - , searchAlpha = 3 - , searchK = 6 - } - -announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) - -> MethodSerializer - TransactionId - (OnionDestination r) - (OnionMessage Identity) - PacketKind - AnnounceRequest - (Maybe AnnounceResponse) -announceSerializer getTimeout = MethodSerializer - { methodTimeout = getTimeout - , method = AnnounceType - , wrapQuery = \(TransactionId n8 n24) src dst req -> - -- :: tid -> addr -> addr -> a -> OnionMessage Identity - OnionAnnounce $ Asymm - { -- The public key is our real long term public key if we want to - -- announce ourselves, a temporary one if we are searching for - -- friends. - senderKey = onionKey src - , asymmNonce = n24 - , asymmData = Identity (req, n8) - } - , unwrapResponse = \case -- :: OnionMessage Identity -> b - OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp - _ -> Nothing - } - -unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32) -unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns)) - = case is_stored of - NotStored n32 -> ( ns , [] , Just n32) - SendBackKey k -> ( ns , [Rendezvous k ni] , Nothing ) - Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32) - --- TODO Announce key to announce peers. --- --- Announce Peers are only put in the 8 closest peers array if they respond --- to an announce request. If the peers fail to respond to 3 announce --- requests they are deemed timed out and removed. --- --- ... --- --- For this reason, after the peer is announced successfully for 17 seconds, --- announce packets are sent aggressively every 3 seconds to each known close --- peer (in the list of 8 peers) to search aggressively for peers that know --- the peer we are searching for. - --- TODO --- If toxcore goes offline (no onion traffic for 20 seconds) toxcore will --- aggressively reannounce itself and search for friends as if it was just --- started. - - -sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) - -> Client r - -> AnnounceRequest - -> OnionDestination r - -> (NodeInfo -> AnnounceResponse -> t) - -> IO (Maybe t) -sendOnion getTimeout client req oaddr unwrap = - -- Four tries and then we tap out. - flip fix 4 $ \loop n -> do - mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr - forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r - maybe (if n>0 then loop $! n - 1 else return Nothing) - (return . Just . unwrap (onionNodeInfo oaddr)) - $ join mb - -asyncOnion :: (TransactionId - -> OnionDestination r -> STM (OnionDestination r, Int)) - -> QR.Client - err - PacketKind - TransactionId - (OnionDestination r) - (OnionMessage Identity) - -> AnnounceRequest - -> OnionDestination r - -> (NodeInfo -> AnnounceResponse -> a) - -> (Maybe a -> IO ()) - -> IO () -asyncOnion getTimeout client req oaddr unwrap go = - -- Four tries and then we tap out. - flip fix 4 $ \loop n -> do - QR.asyncQuery client (announceSerializer getTimeout) req oaddr - $ \mb -> do - forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r - maybe (if n>0 then loop $! n - 1 else go Nothing) - (go . Just . unwrap (onionNodeInfo oaddr)) - $ join mb - - --- | Lookup the secret counterpart for a given alias key. -getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) - -> TransportCrypto - -> Client r - -> NodeId - -> NodeInfo - -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32)) -getRendezvous getTimeout crypto client nid ni = do - asel <- atomically $ selectAlias crypto nid - let oaddr = OnionDestination asel ni Nothing - rkey = case asel of - SearchingAlias -> Nothing - _ -> Just $ key2id $ rendezvousPublic crypto - sendOnion getTimeout client - (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey) - oaddr - (unwrapAnnounceResponse rkey) - -asyncGetRendezvous - :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) - -> TransportCrypto - -> Client r - -> NodeId - -> NodeInfo - -> (Maybe ([NodeInfo], [Rendezvous], Maybe Nonce32) -> IO ()) - -> IO () -asyncGetRendezvous getTimeout crypto client nid ni go = do - asel <- atomically $ selectAlias crypto nid - let oaddr = OnionDestination asel ni Nothing - rkey = case asel of - SearchingAlias -> Nothing - _ -> Just $ key2id $ rendezvousPublic crypto - asyncOnion getTimeout client - (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey) - oaddr - (unwrapAnnounceResponse rkey) - go - -putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) - -> TransportCrypto - -> Client r - -> PublicKey - -> Nonce32 - -> NodeInfo - -> IO (Maybe (Rendezvous, AnnounceResponse)) -putRendezvous getTimeout crypto client pubkey nonce32 ni = do - let longTermKey = key2id pubkey - rkey = rendezvousPublic crypto - rendezvousKey = key2id rkey - asel <- atomically $ selectAlias crypto longTermKey - let oaddr = OnionDestination asel ni Nothing - sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr - $ \ni resp -> (Rendezvous rkey ni, resp) diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs deleted file mode 100644 index e746c414..00000000 --- a/src/Network/Tox/Onion/Transport.hs +++ /dev/null @@ -1,119 +0,0 @@ -module Network.Tox.Onion.Transport - ( parseOnionAddr - , encodeOnionAddr - , parseDataToRoute - , encodeDataToRoute - , forwardOnions - , AliasSelector(..) - , OnionDestination(..) - , OnionMessage(..) - , Rendezvous(..) - , DataToRoute(..) - , OnionData(..) - , AnnouncedRendezvous(..) - , AnnounceResponse(..) - , AnnounceRequest(..) - , Forwarding(..) - , ReturnPath(..) - , OnionRequest(..) - , OnionResponse(..) - , Addressed(..) - , UDPTransport - , KeyRecord(..) - , encrypt - , decrypt - , peelSymmetric - , OnionRoute(..) - , N0 - , N1 - , N2 - , N3 - , onionKey - , onionAliasSelector - , selectAlias - , RouteId(..) - , routeId - , putRequest - , wrapForRoute - , wrapSymmetric - , wrapOnion - , wrapOnionPure - ) where - -import Data.ByteString (ByteString) -import Data.Serialize -import Network.Socket - -import Crypto.Tox hiding (encrypt,decrypt) -import qualified Data.Tox.Relay as TCP -import Data.Tox.Onion -import Network.Tox.NodeId - -{- -encodeOnionAddr :: TransportCrypto - -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) - -> (OnionMessage Encrypted,OnionDestination RouteId) - -> IO (Maybe (ByteString, SockAddr)) --} -encodeOnionAddr :: TransportCrypto - -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) - -> (OnionMessage Encrypted, OnionDestination RouteId) - -> IO (Maybe - (Either (TCP.RelayPacket, TCP.NodeInfo) (ByteString, SockAddr))) -encodeOnionAddr crypto _ (msg,OnionToOwner ni p) = - return $ Just $ Right ( runPut $ putResponse (OnionResponse p msg) - , nodeAddr ni ) -encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do - encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) - -- dput XMisc $ "ONION encode missing routeid" - -- return Nothing -encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do - let go route = do - mreq <- wrapForRoute crypto msg ni route - case mreq of - Right req -> return $ Right ( runPut $ putRequest req , nodeAddr $ routeNodeA route) - Left o | Just port <- routeRelayPort route - -> return $ Left ( o, TCP.NodeInfo (routeNodeA route) port) - m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid - x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m - return x - --- wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0) -wrapForRoute :: TransportCrypto - -> OnionMessage Encrypted - -> NodeInfo - -> OnionRoute - -> IO (Either TCP.RelayPacket (OnionRequest N0)) -wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort=Nothing} = do - -- We needn't use the same nonce value here, but I think it is safe to do so. - let nonce = msgNonce msg - fwd <- wrapOnion crypto (routeAliasA r) - nonce - (id2key . nodeId $ routeNodeA r) - (nodeAddr $ routeNodeB r) - =<< wrapOnion crypto (routeAliasB r) - nonce - (id2key . nodeId $ routeNodeB r) - (nodeAddr $ routeNodeC r) - =<< wrapOnion crypto (routeAliasC r) - nonce - (id2key . nodeId $ routeNodeC r) - (nodeAddr ni) - (NotForwarded msg) - return $ Right OnionRequest - { onionNonce = nonce - , onionForward = fwd - , pathFromOwner = NoReturnPath - } -wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort = Just tcpport} = do - let nonce = msgNonce msg - fwd <- wrapOnion crypto (routeAliasB r) - nonce - (id2key . nodeId $ routeNodeB r) - (nodeAddr $ routeNodeC r) - =<< wrapOnion crypto (routeAliasC r) - nonce - (id2key . nodeId $ routeNodeC r) - (nodeAddr ni) - (NotForwarded msg) - return $ Left $ TCP.OnionPacket nonce $ Addressed (nodeAddr $ routeNodeB r) fwd diff --git a/src/Network/Tox/Relay.hs b/src/Network/Tox/Relay.hs deleted file mode 100644 index 2842fcc2..00000000 --- a/src/Network/Tox/Relay.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Network.Tox.Relay (tcpRelay) where - -import Control.Concurrent.MVar -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import qualified Data.ByteString as B -import Data.Function -import Data.Functor.Identity -import qualified Data.IntMap as IntMap - ;import Data.IntMap (IntMap) -import qualified Data.Map as Map - ;import Data.Map (Map) -import Data.Serialize -import Data.Word -import Network.Socket (SockAddr) -import System.IO -import System.IO.Error -import System.Timeout - -import Crypto.Tox -import qualified Data.IntervalSet as IntSet - ;import Data.IntervalSet (IntSet) -import Data.Tox.Relay -import Network.Address (getBindAddress) -import Network.SocketLike -import Network.StreamServer -import Network.Tox.Onion.Transport hiding (encrypt,decrypt) - - - -hGetPrefixed :: Serialize a => Handle -> IO (Either String a) -hGetPrefixed h = do - mlen <- runGet getWord16be <$> B.hGet h 2 - -- We treat parse-fail the same as EOF. - fmap join $ forM mlen $ \len -> runGet get <$> B.hGet h (fromIntegral len) - -hGetSized :: forall x. (Sized x, Serialize x) => Handle -> IO (Either String x) -hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF. - where - ConstSize len = size :: Size x - -data RelaySession = RelaySession - { indexPool :: IntSet -- ^ Ints that are either solicited or associated. - , solicited :: Map PublicKey Int -- ^ Reserved ids, not yet in associated. - , associated :: IntMap ((ConId -> RelayPacket) -> IO ()) -- ^ Peers this session is connected to. - } - -freshSession :: RelaySession -freshSession = RelaySession - { indexPool = IntSet.empty - , solicited = Map.empty - , associated = IntMap.empty - } - -disconnect :: TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession)) - -> PublicKey - -> IO () -disconnect cons who = join $ atomically $ do - Map.lookup who <$> readTVar cons - >>= \case - Nothing -> return $ return () - Just (_,session) -> do - modifyTVar' cons $ Map.delete who - RelaySession { associated = cs } <- readTVar session - return $ let notifyPeer i send = ((send DisconnectNotification) >>) - in IntMap.foldrWithKey notifyPeer (return ()) cs - -relaySession :: TransportCrypto - -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession)) - -> (SockAddr -> OnionRequest N1 -> IO ()) - -> sock - -> Int - -> Handle - -> IO () -relaySession crypto cons sendOnion _ conid h = do - -- atomically $ modifyTVar' cons $ IntMap.insert conid h - - -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h - - (hGetSized h >>=) $ mapM_ $ \helloE -> do - - let me = transportSecret crypto - them = helloFrom helloE - - noncef <- lookupNonceFunction crypto me them - let mhello = decryptPayload (noncef $ helloNonce helloE) helloE - forM_ mhello $ \hello -> do - let _ = hello :: Hello Identity - - (me',welcome) <- atomically $ do - skey <- transportNewKey crypto - dta <- HelloData (toPublic skey) <$> transportNewNonce crypto - w24 <- transportNewNonce crypto - return (skey, Welcome w24 $ pure dta) - - B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome - - noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello) - in lookupNonceFunction crypto me' them' - - let readPacket n24 = (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h - base = sessionBaseNonce $ runIdentity $ helloData hello - - -- You get 3 seconds to send a session packet. - mpkt0 <- join <$> timeout 3000000 (either (const Nothing) Just <$> readPacket base) - forM_ mpkt0 $ \pkt0 -> do - - disconnect cons (helloFrom hello) - (sendPacket,session) <- do - session <- atomically $ newTVar freshSession - sendPacket <- do - v <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome) - return $ \p -> do - case p of - DisconnectNotification con -> atomically $ do - modifyTVar' session $ \s -> s - { indexPool = maybe id IntSet.delete (c2key con) (indexPool s) - , associated = maybe id IntMap.delete (c2key con) (associated s) - } - _ -> return () - n24 <- takeMVar v - let bs = encode $ encrypt (noncef' n24) $ encodePlain (p :: RelayPacket) - do B.hPut h $ encode (fromIntegral (B.length bs) :: Word16) - B.hPut h bs - `catchIOError` \_ -> return () - putMVar v (incrementNonce24 n24) - atomically $ modifyTVar' cons $ Map.insert (helloFrom hello) (sendPacket,session) - return (sendPacket,session) - - handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0 - - flip fix (incrementNonce24 base) $ \loop n24 -> do - m <- readPacket n24 - forM_ m $ \p -> do - handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p - loop (incrementNonce24 n24) - `finally` - disconnect cons (helloFrom hello) - -handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession)) - -> Int - -> PublicKey - -> TransportCrypto - -> (SockAddr -> OnionRequest N1 -> IO ()) - -> (RelayPacket -> IO ()) - -> TVar RelaySession - -> RelayPacket - -> IO () -handlePacket cons thistcp me crypto sendOnion sendToMe session = \case - RoutingRequest them -> join $ atomically $ do - mySession <- readTVar session - mi <- case Map.lookup them (solicited mySession) of - Nothing -> fmap join $ forM (IntSet.nearestOutsider 0 (indexPool mySession)) $ \i -> do - if -120 <= i && i <= 119 - then do - writeTVar session mySession - { indexPool = IntSet.insert i (indexPool mySession) - , solicited = Map.insert them i (solicited mySession) - } - return $ Just i - else return Nothing -- No more slots available. - Just i -> return $ Just i - notifyConnect <- fmap (join . join) $ forM mi $ \i -> do - mp <- Map.lookup them <$> readTVar cons - forM mp $ \(sendToThem,peer) -> do - theirSession <- readTVar peer - forM (Map.lookup me $ solicited theirSession) $ \reserved_id -> do - let sendToThem' f = sendToThem $ f $ key2c reserved_id - sendToMe' f = sendToMe $ f $ key2c i - writeTVar peer theirSession - { solicited = Map.delete me (solicited theirSession) - , associated = IntMap.insert reserved_id sendToMe' (associated theirSession) - } - writeTVar session mySession - { solicited = Map.delete them (solicited mySession) - , associated = IntMap.insert i sendToThem' (associated mySession) - } - return $ do sendToThem' ConnectNotification - sendToMe' ConnectNotification - return $ do sendToMe $ RoutingResponse (maybe badcon key2c mi) them - sequence_ notifyConnect - - RelayPing x -> sendToMe $ RelayPong x -- TODO x==0 is invalid. Do we care? - - OOBSend them bs -> do - m <- atomically $ Map.lookup them <$> readTVar cons - forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv me bs - - RelayData bs con -> join $ atomically $ do - -- Data: Data packets can only be sent and received if the - -- corresponding connection_id is connection (a Connect notification - -- has been received from it) if the server receives a Data packet for - -- a non connected or existent connection it will discard it. - mySession <- readTVar session - return $ sequence_ $ do - i <- c2key con - sendToThem' <- IntMap.lookup i $ associated mySession - return $ sendToThem' $ RelayData bs - - OnionPacket n24 (Addressed addr req) -> do - rpath <- atomically $ do - sym <- transportSymmetric crypto - n <- transportNewNonce crypto - return $ wrapSymmetric sym n (TCPIndex thistcp) NoReturnPath - sendOnion addr $ OnionRequest n24 req rpath - - _ -> return () - - -sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionMessage Encrypted -> IO () -sendTCP_ st addr x = join $ atomically - $ IntMap.lookup addr <$> readTVar st >>= \case - Nothing -> return $ return () - Just send -> return $ send $ OnionPacketResponse x - -tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionMessage Encrypted -> IO ()) -tcpRelay udp_addr sendOnion = do - crypto <- newCrypto - cons <- newTVarIO Map.empty - clients <- newTVarIO IntMap.empty - b443 <- getBindAddress "443" True - b80 <- getBindAddress "80" True - b33445 <- getBindAddress "33445" True - bany <- getBindAddress "" True - h <- streamServer ServerConfig - { serverWarn = hPutStrLn stderr - , serverSession = relaySession crypto cons sendOnion - } - [b443,b80,udp_addr,b33445,bany] - return (h,sendTCP_ clients) - diff --git a/src/Network/Tox/Session.hs b/src/Network/Tox/Session.hs deleted file mode 100644 index 189967fa..00000000 --- a/src/Network/Tox/Session.hs +++ /dev/null @@ -1,243 +0,0 @@ --- | This module implements the lossless Tox session protocol. -{-# LANGUAGE TupleSections #-} -module Network.Tox.Session - ( SessionParams(..) - , SessionKey - , Session(..) - , sTheirUserKey - , sClose - , handshakeH - ) where - -import Control.Concurrent.STM -import Control.Monad -import Control.Exception -import Data.Dependent.Sum -import Data.Functor.Identity -import Data.Word -import Network.Socket (SockAddr) - -import Crypto.Tox -import Data.PacketBuffer (PacketInboundEvent (..)) -import Data.Tox.Msg -import DPut -import DebugTag -import Network.Lossless -import Network.QueryResponse -import Network.SessionTransports -import Network.Tox.Crypto.Transport -import Network.Tox.DHT.Transport (Cookie (..), key2id, longTermKey) -import Network.Tox.Handshake - --- | Alias for 'SecretKey' to document that it is used as the temporary Tox --- session key corresponding to the 'PublicKey' we sent in the handshake. -type SessionKey = SecretKey - --- | These inputs to 'handshakeH' indicate how to respond to handshakes, how to --- assign packets to sessions, and what to do with established sessions after --- they are made lossless by queuing packets and appending sequence numbers. -data SessionParams = SessionParams - { -- | The database of secret keys necessary to encrypt handshake packets. - spCrypto :: TransportCrypto - -- | This is used to create sessions and dispatch packets to them. - , spSessions :: Sessions (CryptoPacket Encrypted) - -- | This method returns the session information corresponding to the - -- cookie pair for the remote address. If no handshake was sent, this - -- should send one immediately. It should return 'Nothing' if anything - -- goes wrong. - , spGetSentHandshake :: SecretKey -> SockAddr - -> Cookie Identity - -> Cookie Encrypted - -> IO (Maybe (SessionKey, HandshakeData)) - -- | This method is invoked on each new session and is responsible for - -- launching any threads necessary to keep the session alive. - , spOnNewSession :: Session -> IO () - } - --- | After a session is established, this information is given to the --- 'spOnNewSession' callback. -data Session = Session - { -- | This is the secret user (toxid) key that corresponds to the - -- local-end of this session. - sOurKey :: SecretKey - -- | The remote address for this session. (Not unique, see 'sSessionID'). - , sTheirAddr :: SockAddr - -- | The information we sent in the handshake for this session. - , sSentHandshake :: HandshakeData - -- | The information we received in a handshake for this session. - , sReceivedHandshake :: Handshake Identity - -- | This method can be used to trigger packets to be re-sent given a - -- list of their sequence numbers. It should be used when the remote end - -- indicates they lost packets. - , sResendPackets :: [Word32] -> IO () - -- | This list of sequence numbers should be periodically polled and if - -- it is not empty, we should request they re-send these packets. For - -- convenience, a lower bound for the numbers in the list is also - -- returned. Suggested polling interval: a few seconds. - , sMissingInbound :: IO ([Word32],Word32) - -- | A lossless transport for sending and receiving packets in this - -- session. It is up to the caller to spawn the await-loop to handle - -- inbound packets. - , sTransport :: Transport String () CryptoMessage - -- | A unique small integer that identifies this session for as long as - -- it is established. - , sSessionID :: Int - } - --- | Helper to obtain the remote ToxID key from the locally-issued cookie --- associated with the session. -sTheirUserKey :: Session -> PublicKey -sTheirUserKey s = longTermKey $ runIdentity cookie - where - Cookie _ cookie = handshakeCookie (sReceivedHandshake s) - --- | Helper to close the 'Transport' associated with a session. -sClose :: Session -> IO () -sClose s = closeTransport (sTransport s) - - --- | Call this whenever a new handshake arrives so that a session is --- negotiated. It always returns Nothing which makes it convenient to use with --- 'Network.QueryResponse.addHandler'. -handshakeH :: SessionParams - -> SockAddr - -> Handshake Encrypted - -> IO (Maybe a) -handshakeH sp saddr handshake = do - decryptHandshake (spCrypto sp) handshake - >>= either (\err -> return ()) - (uncurry $ plainHandshakeH sp saddr) - return Nothing - - -plainHandshakeH :: SessionParams - -> SockAddr - -> SecretKey - -> Handshake Identity - -> IO () -plainHandshakeH sp saddr skey handshake = do - let hd = runIdentity $ handshakeData handshake - prelude = show saddr ++ " --> " - dput XNetCrypto $ unlines $ map (prelude ++) - [ "handshake: auth=" ++ show (handshakeCookie handshake) - , " : issuing=" ++ show (otherCookie hd) - , " : baseNonce=" ++ show (baseNonce hd) - ] - sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd) - -- TODO: this is always returning sent = Nothing - dput XNetCrypto $ " <-- (cached) handshake baseNonce " ++ show (fmap (baseNonce . snd) sent) - forM_ sent $ \(hd_skey,hd_sent) -> do - sk <- SessionKeys (spCrypto sp) - hd_skey - (sessionKey hd) - <$> atomically (newTVar $ baseNonce hd) - <*> atomically (newTVar $ baseNonce hd_sent) - m <- newSession (spSessions sp) (\() p -> return p) (decryptPacket sk) saddr - dput XNetCrypto $ prelude ++ "plainHandshakeH: session " ++ maybe "Nothing" (const "Just") m - forM_ m $ \(sid, t) -> do - (t2,resend,getMissing) - <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp) - (\seqno p@(Pkt m :=> _) _ -> do - y <- encryptPacket sk $ bookKeeping seqno p - return OutgoingInfo - { oIsLossy = lossyness m == Lossy - , oEncoded = y - , oHandleException = Just $ \e -> do - dput XUnexpected $ unlines - [ "<-- " ++ show e - , "<-- while sending " ++ show (seqno,p) ] - throwIO e - }) - () - t - let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted) - _ = t2 :: Transport String () CryptoMessage - sendMessage t2 () $ (Pkt ONLINE ==> ()) - spOnNewSession sp Session - { sOurKey = skey - , sTheirAddr = saddr - , sSentHandshake = hd_sent - , sReceivedHandshake = handshake - , sResendPackets = resend - , sMissingInbound = getMissing - , sTransport = t2 - , sSessionID = sid - } - return () - - --- | The per-session nonce and key state maintained by 'decryptPacket' and --- 'encryptPacket'. -data SessionKeys = SessionKeys - { skCrypto :: TransportCrypto -- ^ Cache of shared-secrets. - , skMe :: SessionKey -- ^ My session key - , skThem :: PublicKey -- ^ Their session key - , skNonceIncoming :: TVar Nonce24 -- ^ +21845 when a threshold is reached. - , skNonceOutgoing :: TVar Nonce24 -- ^ +1 on every packet - } - --- | Decrypt an inbound session packet and update the nonce for the next one. -decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ())) -decryptPacket sk saddr (CryptoPacket n16 ciphered) = do - (n24,δ) <- atomically $ do - n <- readTVar (skNonceIncoming sk) - let δ = n16 - nonce24ToWord16 n - return ( n `addtoNonce24` fromIntegral δ, δ ) - secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 - case decodePlain =<< decrypt secret ciphered of - Left e -> return Nothing - Right x -> do - when ( δ > 43690 ) - $ atomically $ writeTVar (skNonceIncoming sk) (n24 `addtoNonce24` 21845) - - do let them = key2id $ skThem sk - CryptoData ack seqno _ = x - cm = decodeRawCryptoMsg x - dput XNetCrypto $ unwords [take 8 (show them),"-->",show (msgID cm),show (n24,ack,seqno)] - - return $ Just ( CryptoPacket n16 (pure x), () ) - --- | Encrypt an outbound session packet and update the nonce for the next one. -encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted) -encryptPacket sk plain = do - n24 <- atomically $ do - n24 <- readTVar (skNonceOutgoing sk) - modifyTVar' (skNonceOutgoing sk) incrementNonce24 - return n24 - secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 - let ciphered = encrypt secret $ encodePlain $ plain - - do let them = key2id $ skThem sk - CryptoData ack seqno cm = plain - dput XNetCrypto $ unwords [take 8 (show them),"<--",show (msgID cm),show (n24,ack,seqno)] - - return $ CryptoPacket (nonce24ToWord16 n24) ciphered - - --- | Add sequence information to an outbound packet. --- --- From spec.md: --- --- Data in the encrypted packets: --- --- [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)] --- [uint32_t packet number if lossless, sendbuffer buffer_end if lossy, (big endian)] --- [data] -bookKeeping :: SequenceInfo -> CryptoMessage -> CryptoData -bookKeeping (SequenceInfo seqno ack) m = CryptoData - { bufferStart = ack :: Word32 - , bufferEnd = seqno :: Word32 - , bufferData = m - } - --- | Classify an inbound packet as lossy or lossless based on its id byte. -checkLossless :: CryptoData -> PacketInboundEvent CryptoMessage -checkLossless cd@CryptoData{ bufferStart = ack - , bufferEnd = no - , bufferData = x } = tag no x' ack - where - x' = decodeRawCryptoMsg cd - tag = case someLossyness (msgID x') of Lossy -> PacketReceivedLossy - _ -> PacketReceived - - diff --git a/src/Network/Tox/TCP.hs b/src/Network/Tox/TCP.hs deleted file mode 100644 index 13da804f..00000000 --- a/src/Network/Tox/TCP.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} -module Network.Tox.TCP - ( module Network.Tox.TCP - , NodeInfo(..) - ) where - -import Debug.Trace -import Control.Arrow -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import Crypto.Random -import Data.Aeson (ToJSON(..),FromJSON(..)) -import qualified Data.Aeson as JSON -import Data.Functor.Contravariant -import Data.Functor.Identity -import Data.Hashable -import qualified Data.HashMap.Strict as HashMap -import Data.IP -import Data.Maybe -import Data.Monoid -import Data.Serialize -import Data.Word -import qualified Data.Vector as Vector -import Network.Socket (SockAddr(..)) -import qualified Text.ParserCombinators.ReadP as RP -import System.IO.Error -import System.Timeout - -import ControlMaybe -import Crypto.Tox -import Data.ByteString (hPut,hGet,ByteString,length) -import Data.TableMethods -import Data.Tox.Relay -import qualified Data.Word64Map -import DebugTag -import DPut -import Network.Address (setPort,PortNumber,localhost4,fromSockAddr) -import Network.Kademlia.Routing -import Network.Kademlia.Search hiding (sendQuery) -import Network.QueryResponse -import Network.QueryResponse.TCP -import Network.Tox.DHT.Handlers (toxSpace) -import Network.Tox.Onion.Transport hiding (encrypt,decrypt) -import Network.Tox.Onion.Handlers (unwrapAnnounceResponse) -import qualified Network.Tox.NodeId as UDP - - -withSize :: Sized x => (Size x -> m (p x)) -> m (p x) -withSize f = case size of len -> f len - - -type NodeId = UDP.NodeId - --- example: --- KEyW2Bm.S-DpIGp72380BAfgintUWX1KX.6ZU.4m5Ex@80.99.99.99:33400{tcp:443} -instance Show NodeInfo where - show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}" - -nodeId :: NodeInfo -> NodeId -nodeId ni = UDP.nodeId $ udpNodeInfo ni - -nodeAddr :: NodeInfo -> SockAddr -nodeAddr ni = setPort (tcpPort ni) $ UDP.nodeAddr $ udpNodeInfo ni - -nodeIP :: NodeInfo -> IP -nodeIP ni = UDP.nodeIP $ udpNodeInfo ni - -tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) => - TransportCrypto -> StreamHandshake NodeInfo x y -tcpStream crypto = StreamHandshake - { streamHello = \addr h -> do - (skey, hello) <- atomically $ do - n24 <- transportNewNonce crypto - skey <- transportNewKey crypto - base24 <- transportNewNonce crypto - return $ (,) skey $ Hello $ Asymm - { senderKey = transportPublic crypto - , asymmNonce = n24 - , asymmData = pure HelloData - { sessionPublicKey = toPublic $ skey - , sessionBaseNonce = base24 - } - } - noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr) - dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello - hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello - welcomeE <- withSize $ fmap decode . hGet h . constSize - let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w - nil = SessionProtocol - { streamGoodbye = return () - , streamDecode = return Nothing - , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y - } - either (\_ -> return nil) id $ mwelcome <&> \welcome -> do - dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome - noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome) - nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello) - nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome) - let them = sessionPublicKey $ runIdentity $ welcomeData welcome - hvar <- newMVar h - return SessionProtocol - { streamGoodbye = do - dput XTCP $ "Closing " ++ show addr - return () -- No goodbye packet? Seems rude. - , streamDecode = - let go h = decode <$> hGet h 2 >>= \case - Left e -> do - dput XTCP $ "TCP: (" ++ show addr ++ ") Failed to get length: " ++ e - return Nothing - Right len -> do - decode <$> hGet h (fromIntegral (len :: Word16)) >>= \case - Left e -> do - dput XTCP $ "TCP: Failed to decode packet." - return Nothing - Right x -> do - m24 <- timeout 1000000 (takeMVar nread) - fmap join $ forM m24 $ \n24 -> do - let r = decrypt (noncef' n24) x >>= decodePlain - putMVar nread (incrementNonce24 n24) - either (dput XTCP . ("TCP decryption: " ++)) - (\x' -> do - dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x' - return ()) - r - return $ either (const Nothing) Just r - in bracket (takeMVar hvar) (putMVar hvar) - $ \h -> go h `catchIOError` \e -> do - dput XTCP $ "TCP exception: " ++ show e - return Nothing - , streamEncode = \y -> do - dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y - n24 <- takeMVar nsend - dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y - let bs = encode $ encrypt (noncef' n24) $ encodePlain y - ($ h) -- bracket (takeMVar hvar) (putMVar hvar) - $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs) - `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e - dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y - putMVar nsend (incrementNonce24 n24) - dput XTCP $ "TCP(finished): " ++ show addr ++ " <-- " ++ show y - } - , streamAddr = nodeAddr - } - -toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol RelayPacket RelayPacket) - , TransportA err NodeInfo RelayPacket (Bool,RelayPacket) ) -toxTCP crypto = tcpTransport 30 (tcpStream crypto) - -tcpSpace :: KademliaSpace NodeId NodeInfo -tcpSpace = contramap udpNodeInfo toxSpace - -{- -nodeSearch :: TCPClient err () Nonce8 -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo -nodeSearch tcp = Search - { searchSpace = tcpSpace - , searchNodeAddress = nodeIP &&& tcpPort - , searchQuery = getNodes tcp - } --} - -data TCPClient err tid = TCPClient - { tcpCrypto :: TransportCrypto - , tcpClient :: Client err PacketNumber tid NodeInfo (Bool,RelayPacket) - , tcpGetGateway :: UDP.NodeInfo -> STM (Maybe NodeInfo) - } - -{- -getTCPNodes :: TCPClient err () Nonce8 -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) -getTCPNodes tcp seeking dst = do - r <- getUDPNodes' tcp seeking (udpNodeInfo dst) - let tcps (ns,_,mb) = (ns',ns',mb) - where ns' = do - n <- ns - [ NodeInfo n (fromIntegral 443) , NodeInfo n (fromIntegral 80) , NodeInfo n (UDP.nodePort n) ] - fmap join $ forM r $ \(ns,gw) -> do - let ts = tcps ns - {- - if nodeId gw == nodeId dst - then return $ Just ts - else do - forkIO $ void $ tcpPing (tcpClient tcp) dst - return $ Just ts - -} - forM_ ((\(xs,_,_) -> xs) ts) (forkIO . void . tcpPing (tcpClient tcp)) - return $ Just ts --} - -getUDPNodes :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ())) -getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst - -getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo)) -getUDPNodes' tcp seeking dst0 = do - mgateway <- atomically $ tcpGetGateway tcp dst0 - fmap join $ forM mgateway $ \gateway -> do - (b,c,n24) <- atomically $ do - b <- transportNewKey (tcpCrypto tcp) - c <- transportNewKey (tcpCrypto tcp) - n24 <- transportNewNonce (tcpCrypto tcp) - return (b,c,n24) - let (dst,gateway') = if UDP.nodeId dst0 == nodeId gateway - then ( dst0 { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 } - , gateway { udpNodeInfo = (udpNodeInfo gateway) - { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 }}) - else (dst0,gateway) - wrap2 <- lookupNonceFunction (tcpCrypto tcp) b (UDP.id2key $ UDP.nodeId dst) - wrap1 <- lookupNonceFunction (tcpCrypto tcp) c (UDP.id2key $ nodeId gateway) - wrap0 <- lookupNonceFunction (tcpCrypto tcp) (transportSecret $ tcpCrypto tcp) (UDP.id2key $ UDP.nodeId dst) - let meth :: MethodSerializer - Nonce8 - a -- NodeInfo - (Bool, RelayPacket) - PacketNumber - AnnounceRequest - (Either String AnnounceResponse) - meth = MethodSerializer - { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout - , method = OnionPacketID -- meth - , wrapQuery = \n8 src gateway x -> (,) True $ - OnionPacket n24 $ Addressed (UDP.nodeAddr dst) - $ wrapOnionPure b (wrap2 n24) (nodeAddr gateway') - $ wrapOnionPure c (wrap1 n24) (UDP.nodeAddr dst) - $ NotForwarded $ encryptPayload (wrap0 n24) - $ OnionAnnounce Asymm - { senderKey = transportPublic (tcpCrypto tcp) - , asymmNonce = n24 - , asymmData = pure (x,n8) - } - , unwrapResponse = \case - (_,OnionPacketResponse (OnionAnnounceResponse _ n24' r)) - -> decrypt (wrap0 n24') r >>= decodePlain - x -> Left $ "getUDPNodes: unwrapResponse fail " ++ show x - } - r <- sendQuery (tcpClient tcp) meth (AnnounceRequest zeros32 seeking UDP.zeroID) gateway - forM r $ \response -> do - let (ns,_,mb) = either (const ([],[],Nothing)) (unwrapAnnounceResponse Nothing dst) $ response - return ( (ns,ns, const () <$> mb), gateway ) - - -handleOOB :: PublicKey -> ByteString -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x)) -handleOOB k bs src dst = do - dput XMisc $ "TODO: handleOOB " ++ show src - return Nothing - -handle2route :: OnionMessage Encrypted -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x)) -handle2route o src dst = do - dput XMisc $ "TODO: handle2route " ++ show src - return Nothing - -tcpPing :: Show addr => Client err PacketNumber Nonce8 addr (Bool,RelayPacket) -> addr -> IO (Maybe ()) -tcpPing client dst = do - dput XTCP $ "tcpPing " ++ show dst - sendQuery client meth () dst - where meth = MethodSerializer - { wrapQuery = \n8 src dst () -> (True,RelayPing n8) - , unwrapResponse = \_ -> () - , methodTimeout = \n8 dst -> return (dst,5000000) - , method = PingPacket - } - -type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket) - --- | Create a new TCP relay client. Because polymorphic existential record --- updates are currently hard with GHC, this function accepts parameters for --- generalizing the table-entry type for pending transactions. Safe trivial --- defaults are 'id' and 'tryPutMVar'. The resulting customized table state --- will be returned to the caller along with the new client. -newClient :: TransportCrypto - -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a) -- ^ store mvar for query - -> (a -> RelayPacket -> IO void) -- ^ load mvar for query - -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a) - , TCPCache (SessionProtocol RelayPacket RelayPacket) ) - , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)) -newClient crypto store load = do - (tcpcache,net) <- toxTCP crypto - drg <- drgNew - map_var <- atomically $ newTVar (drg, Data.Word64Map.empty) - return $ (,) (map_var,tcpcache) Client - { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net - , clientDispatcher = DispatchMethods - { classifyInbound = (. snd) $ \case - RelayPing n -> IsQuery PingPacket n - RelayPong n -> IsResponse n - OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8 - OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o - OOBRecv k bs -> IsUnsolicited $ handleOOB k bs - wut -> IsUnknown (show wut) - , lookupHandler = \case - PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler - { methodParse = \case (_,RelayPing n8) -> Right () - _ -> trace ("tcp-non-ping") $ Left "TCP: Non-ping?" - , methodSerialize = \n8 src dst () -> trace ("tcp-made-pong-"++show n8) (False, RelayPong n8) - , methodAction = \src () -> dput XTCP $ "TCP pinged by "++show src - } - w -> trace ("tcp-lookupHandler: "++show w) $ Just NoReply - { methodParse = \x -> Left "tcp-lookuphandler?" -- :: x -> Either err a - , noreplyAction = \addr a -> dput XTCP $ "tcp-lookupHandler: "++show w - } - , tableMethods = transactionMethods' store (\x -> mapM_ (load x . snd)) (contramap (\(Nonce8 w64) -> w64) w64MapMethods) - $ first (either error Nonce8 . decode) . randomBytesGenerate 8 - } - , clientErrorReporter = logErrors - , clientPending = map_var - , clientAddress = \_ -> return $ NodeInfo - { udpNodeInfo = either error id $ UDP.nodeInfo (UDP.key2id $ transportPublic crypto) (SockAddrInet 0 0) - , tcpPort = 0 - } - , clientResponseId = return - } diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs deleted file mode 100644 index 217d5b1d..00000000 --- a/src/Network/Tox/Transport.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -module Network.Tox.Transport (toxTransport, RouteId) where - -import Network.QueryResponse -import Crypto.Tox -import Data.Tox.Relay as TCP -import Network.Tox.DHT.Transport as UDP -import Network.Tox.Onion.Transport -import Network.Tox.Crypto.Transport -import OnionRouter - -import Network.Socket - -toxTransport :: - TransportCrypto - -> OnionRouter - -> (PublicKey -> IO (Maybe UDP.NodeInfo)) - -> UDPTransport - -> (TCP.NodeInfo -> RelayPacket -> IO ()) -- ^ TCP server-bound callback. - -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback. - -> IO ( Transport String SockAddr (CryptoPacket Encrypted) - , Transport String UDP.NodeInfo (DHTMessage Encrypted8) - , Transport String (OnionDestination RouteId) (OnionMessage Encrypted) - , Transport String AnnouncedRendezvous (PublicKey,OnionData) - , Transport String SockAddr (Handshake Encrypted)) -toxTransport crypto orouter closeLookup udp tcp2server tcp2client = do - (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp - (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) - $ forwardOnions crypto udp0 tcp2client - (onion1,udp2) <- partitionAndForkTransport tcp2server - (parseOnionAddr $ lookupSender orouter) - (encodeOnionAddr crypto $ lookupRoute orouter) - udp1 - (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1 - let handshakes = layerTransport parseHandshakes encodeHandshakes udp2 - return ( netcrypto - , forwardDHTRequests crypto closeLookup dht - , onion - , dta - , handshakes - ) - - --- instance (Sized a, Sized b) => Sized (a,b) where size = _todo - - --- Byte value Packet Kind Return address --- :----------- :-------------------- --- `0x00` Ping Request DHTNode --- `0x01` Ping Response - --- `0x02` Nodes Request DHTNode --- `0x04` Nodes Response - --- `0x18` Cookie Request DHTNode, but without sending pubkey in response --- `0x19` Cookie Response - (no pubkey) --- --- `0x21` LAN Discovery DHTNode (No reply, port 33445, trigger Nodes Request/Response) --- --- `0x20` DHT Request DHTNode/-forward --- --- `0x1a` Crypto Handshake CookieAddress --- --- `0x1b` Crypto Data SessionAddress --- --- `0x83` Announce Request OnionToOwner --- `0x84` Announce Response - --- `0x85` Onion Data Request OnionToOwner --- `0x86` Onion Data Response - --- --- `0xf0` Bootstrap Info SockAddr? --- --- `0x80` Onion Request 0 -forward --- `0x81` Onion Request 1 -forward --- `0x82` Onion Request 2 -forward --- `0x8c` Onion Response 3 -return --- `0x8d` Onion Response 2 -return --- `0x8e` Onion Response 1 -return - - - -- cgit v1.2.3