{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} module Network.Tox.Onion.Handlers where import Network.Kademlia.Search import Network.Tox.TCP.NodeId (udpNodeInfo) 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 dput XAnnounce "(gc:toxids) Garbage collecting announced toxids." 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 :: (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 = Left $ getRendezvous getTimeout crypto client , searchAlpha = 3 , searchK = 6 } announceSerializer :: (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 ns0)) | let ns = map udpNodeInfo ns0 = 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 :: (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 -- | Lookup the secret counterpart for a given alias key. getRendezvous :: (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) putRendezvous :: (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)