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/Address.hs | 1253 ------------------------- src/Network/BitTorrent/DHT/ContactInfo.hs | 254 ----- src/Network/BitTorrent/DHT/Readme.md | 13 - src/Network/BitTorrent/DHT/Token.hs | 201 ---- src/Network/BitTorrent/MainlineDHT.hs | 1169 ----------------------- src/Network/BitTorrent/MainlineDHT/Symbols.hs | 24 - src/Network/Kademlia.hs | 163 ---- src/Network/Kademlia/Bootstrap.hs | 437 --------- src/Network/Kademlia/CommonAPI.hs | 84 -- src/Network/Kademlia/Persistence.hs | 51 - src/Network/Kademlia/Routing.hs | 808 ---------------- src/Network/Kademlia/Search.hs | 236 ----- src/Network/Lossless.hs | 124 --- src/Network/QueryResponse.hs | 638 ------------- src/Network/QueryResponse/TCP.hs | 192 ---- src/Network/SessionTransports.hs | 98 -- src/Network/SocketLike.hs | 124 --- src/Network/StreamServer.hs | 154 --- src/Network/Tox.hs | 456 --------- 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 -- src/Network/UPNP.hs | 40 - 34 files changed, 11413 deletions(-) delete mode 100644 src/Network/Address.hs delete mode 100644 src/Network/BitTorrent/DHT/ContactInfo.hs delete mode 100644 src/Network/BitTorrent/DHT/Readme.md delete mode 100644 src/Network/BitTorrent/DHT/Token.hs delete mode 100644 src/Network/BitTorrent/MainlineDHT.hs delete mode 100644 src/Network/BitTorrent/MainlineDHT/Symbols.hs delete mode 100644 src/Network/Kademlia.hs delete mode 100644 src/Network/Kademlia/Bootstrap.hs delete mode 100644 src/Network/Kademlia/CommonAPI.hs delete mode 100644 src/Network/Kademlia/Persistence.hs delete mode 100644 src/Network/Kademlia/Routing.hs delete mode 100644 src/Network/Kademlia/Search.hs delete mode 100644 src/Network/Lossless.hs delete mode 100644 src/Network/QueryResponse.hs delete mode 100644 src/Network/QueryResponse/TCP.hs delete mode 100644 src/Network/SessionTransports.hs delete mode 100644 src/Network/SocketLike.hs delete mode 100644 src/Network/StreamServer.hs delete mode 100644 src/Network/Tox.hs 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 delete mode 100644 src/Network/UPNP.hs (limited to 'src/Network') diff --git a/src/Network/Address.hs b/src/Network/Address.hs deleted file mode 100644 index e1cec34d..00000000 --- a/src/Network/Address.hs +++ /dev/null @@ -1,1253 +0,0 @@ --- | --- Module : Network.Address --- Copyright : (c) Sam Truzjan 2013 --- (c) Daniel Gröber 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : provisional --- Portability : portable --- --- Peer and Node addresses. --- -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS -fno-warn-orphans #-} -module Network.Address - ( -- * Address - Address (..) - , fromAddr - , PortNumber - , SockAddr - - -- ** IP - , IPv4 - , IPv6 - , IP (..) - , un4map - , WantIP (..) - , ipFamily - , is4mapped - , either4or6 - - -- * PeerId - -- $peer-id - , PeerId - - -- ** Generation - , genPeerId - , timestamp - , entropy - - -- ** Encoding - , azureusStyle - , shadowStyle - , defaultClientId - , defaultVersionNumber - - -- * PeerAddr - -- $peer-addr - , PeerAddr(..) - , defaultPorts - , peerSockAddr - , peerSocket - - -- * Node - , NodeAddr (..) - - -- ** Id - , testIdBit - , bucketRange - , genBucketSample - , genBucketSample' - - -- * Fingerprint - -- $fingerprint - , Software (..) - , Fingerprint (..) - , libFingerprint - , fingerprint - - -- * Utils - , libUserAgent - , sockAddrPort - , setPort - , getBindAddress - , localhost4 - , localhost6 - , linesBy - ) where - -import Control.Applicative -import Control.Monad -import Control.Exception (onException) -#ifdef VERSION_bencoding -import Data.BEncode as BE -import Data.BEncode.BDict (BKey) -#endif -import Data.Bits -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS -import Data.ByteString.Char8 as BC -import Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Builder as BS -import Data.Char -import Data.Convertible -import Data.Default -#if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) -#else -import Data.IP -#endif -import Data.List as L -import Data.Maybe (fromMaybe, catMaybes) -import Data.Monoid -import Data.Hashable -import Data.Serialize as S -import Data.String -import Data.Time -import Data.Typeable -import Data.Version -import Data.Word -import qualified Text.ParserCombinators.ReadP as RP -import Text.Read (readMaybe) -import Network.HTTP.Types.QueryLike -import Network.Socket -import Text.PrettyPrint as PP hiding ((<>)) -import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) -#if !MIN_VERSION_time(1,5,0) -import System.Locale (defaultTimeLocale) -#endif -import System.Entropy -import DPut -import DebugTag - --- import Paths_bittorrent (version) - -instance Pretty UTCTime where - pPrint = PP.text . show - -setPort :: PortNumber -> SockAddr -> SockAddr -setPort port (SockAddrInet _ h ) = SockAddrInet port h -setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s -setPort _ addr = addr -{-# INLINE setPort #-} - --- | Obtains the port associated with a socket address --- if one is associated with it. -sockAddrPort :: SockAddr -> Maybe PortNumber -sockAddrPort (SockAddrInet p _ ) = Just p -sockAddrPort (SockAddrInet6 p _ _ _) = Just p -sockAddrPort _ = Nothing -{-# INLINE sockAddrPort #-} - -class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a) - => Address a where - toSockAddr :: a -> SockAddr - fromSockAddr :: SockAddr -> Maybe a - -fromAddr :: (Address a, Address b) => a -> Maybe b -fromAddr = fromSockAddr . toSockAddr - --- | Note that port is zeroed. -instance Address IPv4 where - toSockAddr = SockAddrInet 0 . toHostAddress - fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h) - fromSockAddr _ = Nothing - --- | Note that port is zeroed. -instance Address IPv6 where - toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0 - fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h) - fromSockAddr _ = Nothing - --- | Note that port is zeroed. -instance Address IP where - toSockAddr (IPv4 h) = toSockAddr h - toSockAddr (IPv6 h) = toSockAddr h - fromSockAddr sa = - IPv4 <$> fromSockAddr sa - <|> IPv6 <$> fromSockAddr sa - -data NodeAddr a = NodeAddr - { nodeHost :: !a - , nodePort :: {-# UNPACK #-} !PortNumber - } deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable) - -instance Show a => Show (NodeAddr a) where - showsPrec i NodeAddr {..} - = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort - -instance Read (NodeAddr IPv4) where - readsPrec i = RP.readP_to_S $ do - ipv4 <- RP.readS_to_P (readsPrec i) - _ <- RP.char ':' - port <- toEnum <$> RP.readS_to_P (readsPrec i) - return $ NodeAddr ipv4 port - --- | @127.0.0.1:6882@ -instance Default (NodeAddr IPv4) where - def = "127.0.0.1:6882" - --- | KRPC compatible encoding. -instance Serialize a => Serialize (NodeAddr a) where - get = NodeAddr <$> get <*> get - {-# INLINE get #-} - put NodeAddr {..} = put nodeHost >> put nodePort - {-# INLINE put #-} - --- | Example: --- --- @nodePort \"127.0.0.1:6881\" == 6881@ --- -instance IsString (NodeAddr IPv4) where - fromString str - | (hostAddrStr, portStr0) <- L.break (== ':') str - , let portStr = L.drop 1 portStr0 - , Just hostAddr <- readMaybe hostAddrStr - , Just portNum <- toEnum <$> readMaybe portStr - = NodeAddr hostAddr portNum - | otherwise = error $ "fromString: unable to parse (NodeAddr IPv4): " ++ str - - -instance Hashable a => Hashable (NodeAddr a) where - hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort) - {-# INLINE hashWithSalt #-} - -instance Pretty ip => Pretty (NodeAddr ip) where - pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort - - - -instance Address PeerAddr where - toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost - fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> sockAddrPort sa - -{----------------------------------------------------------------------- --- Peer id ------------------------------------------------------------------------} --- $peer-id --- --- 'PeerID' represent self assigned peer identificator. Ideally each --- host in the network should have unique peer id to avoid --- collisions, therefore for peer ID generation we use good entropy --- source. Peer ID is sent in /tracker request/, sent and received in --- /peer handshakes/ and used in DHT queries. --- - --- TODO use unpacked Word160 form (length is known statically) - --- | Peer identifier is exactly 20 bytes long bytestring. -newtype PeerId = PeerId { getPeerId :: ByteString } - deriving ( Show, Eq, Ord, Typeable -#ifdef VERSION_bencoding - , BEncode -#endif - ) - -peerIdLen :: Int -peerIdLen = 20 - --- | For testing purposes only. -instance Default PeerId where - def = azureusStyle defaultClientId defaultVersionNumber "" - -instance Hashable PeerId where - hashWithSalt = hashUsing getPeerId - {-# INLINE hashWithSalt #-} - -instance Serialize PeerId where - put = putByteString . getPeerId - get = PeerId <$> getBytes peerIdLen - -instance QueryValueLike PeerId where - toQueryValue (PeerId pid) = Just pid - {-# INLINE toQueryValue #-} - -instance IsString PeerId where - fromString str - | BS.length bs == peerIdLen = PeerId bs - | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str - where - bs = fromString str - -instance Pretty PeerId where - pPrint = text . BC.unpack . getPeerId - -instance Convertible BS.ByteString PeerId where - safeConvert bs - | BS.length bs == peerIdLen = pure (PeerId bs) - | otherwise = convError "invalid length" bs - ------------------------------------------------------------------------- - --- | Pad bytestring so it's becomes exactly request length. Conversion --- is done like so: --- --- * length < size: Complete bytestring by given charaters. --- --- * length = size: Output bytestring as is. --- --- * length > size: Drop last (length - size) charaters from a --- given bytestring. --- -byteStringPadded :: ByteString -- ^ bytestring to be padded. - -> Int -- ^ size of result builder. - -> Char -- ^ character used for padding. - -> BS.Builder -byteStringPadded bs s c = - BS.byteString (BS.take s bs) <> - BS.byteString (BC.replicate padLen c) - where - padLen = s - min (BS.length bs) s - --- | Azureus-style encoding have the following layout: --- --- * 1 byte : '-' --- --- * 2 bytes: client id --- --- * 4 bytes: version number --- --- * 1 byte : '-' --- --- * 12 bytes: random number --- -azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'. - -> ByteString -- ^ Version number, padded with 'X'. - -> ByteString -- ^ Random number, padded with '0'. - -> PeerId -- ^ Azureus-style encoded peer ID. -azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ - BS.char8 '-' <> - byteStringPadded cid 2 'H' <> - byteStringPadded ver 4 'X' <> - BS.char8 '-' <> - byteStringPadded rnd 12 '0' - --- | Shadow-style encoding have the following layout: --- --- * 1 byte : client id. --- --- * 0-4 bytes: version number. If less than 4 then padded with --- '-' char. --- --- * 15 bytes : random number. If length is less than 15 then --- padded with '0' char. --- -shadowStyle :: Char -- ^ Client ID. - -> ByteString -- ^ Version number. - -> ByteString -- ^ Random number. - -> PeerId -- ^ Shadow style encoded peer ID. -shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $ - BS.char8 cid <> - byteStringPadded ver 4 '-' <> - byteStringPadded rnd 15 '0' - - --- | 'HS'- 2 bytes long client identifier. -defaultClientId :: ByteString -defaultClientId = "HS" - --- | Gives exactly 4 bytes long version number for any version of the --- package. Version is taken from .cabal file. -defaultVersionNumber :: ByteString -defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $ - versionBranch myVersion - where - Fingerprint _ myVersion = libFingerprint - ------------------------------------------------------------------------- - --- | Gives 15 characters long decimal timestamp such that: --- --- * 6 bytes : first 6 characters from picoseconds obtained with %q. --- --- * 1 byte : character \'.\' for readability. --- --- * 9..* bytes: number of whole seconds since the Unix epoch --- (!)REVERSED. --- --- Can be used both with shadow and azureus style encoding. This --- format is used to make the ID's readable for debugging purposes. --- -timestamp :: IO ByteString -timestamp = (BC.pack . format) <$> getCurrentTime - where - format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++ - L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t)) - --- | Gives 15 character long random bytestring. This is more robust --- method for generation of random part of peer ID than 'timestamp'. -entropy :: IO ByteString -entropy = getEntropy 15 - --- NOTE: entropy generates incorrrect peer id - --- | Here we use 'azureusStyle' encoding with the following args: --- --- * 'HS' for the client id; ('defaultClientId') --- --- * Version of the package for the version number; --- ('defaultVersionNumber') --- --- * UTC time day ++ day time for the random number. ('timestamp') --- -genPeerId :: IO PeerId -genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp - -{----------------------------------------------------------------------- --- Peer Addr ------------------------------------------------------------------------} --- $peer-addr --- --- 'PeerAddr' is used to represent peer address. Currently it's --- just peer IP and peer port but this might change in future. --- - -{----------------------------------------------------------------------- --- Port number ------------------------------------------------------------------------} - -#ifdef VERSION_bencoding -instance BEncode PortNumber where - toBEncode = toBEncode . fromEnum - fromBEncode = fromBEncode >=> portNumber - where - portNumber :: Integer -> BE.Result PortNumber - portNumber n - | 0 <= n && n <= fromIntegral (maxBound :: Word16) - = pure $ fromIntegral n - | otherwise = decodingError $ "PortNumber: " ++ show n -#endif -{----------------------------------------------------------------------- --- IP addr ------------------------------------------------------------------------} - -class IPAddress i where - toHostAddr :: i -> Either HostAddress HostAddress6 - -instance IPAddress IPv4 where - toHostAddr = Left . toHostAddress - {-# INLINE toHostAddr #-} - -instance IPAddress IPv6 where - toHostAddr = Right . toHostAddress6 - {-# INLINE toHostAddr #-} - -instance IPAddress IP where - toHostAddr (IPv4 ip) = toHostAddr ip - toHostAddr (IPv6 ip) = toHostAddr ip - {-# INLINE toHostAddr #-} - -deriving instance Typeable IP -deriving instance Typeable IPv4 -deriving instance Typeable IPv6 - -#ifdef VERSION_bencoding -ipToBEncode :: Show i => i -> BValue -ipToBEncode ip = BString $ BS8.pack $ show ip -{-# INLINE ipToBEncode #-} - -ipFromBEncode :: Read a => BValue -> BE.Result a -ipFromBEncode (BString (BS8.unpack -> ipStr)) - | Just ip <- readMaybe (ipStr) = pure ip - | otherwise = decodingError $ "IP: " ++ ipStr -ipFromBEncode _ = decodingError $ "IP: addr should be a bstring" - -instance BEncode IP where - toBEncode = ipToBEncode - {-# INLINE toBEncode #-} - fromBEncode = ipFromBEncode - {-# INLINE fromBEncode #-} - -instance BEncode IPv4 where - toBEncode = ipToBEncode - {-# INLINE toBEncode #-} - fromBEncode = ipFromBEncode - {-# INLINE fromBEncode #-} - -instance BEncode IPv6 where - toBEncode = ipToBEncode - {-# INLINE toBEncode #-} - fromBEncode = ipFromBEncode - {-# INLINE fromBEncode #-} -#endif - --- | Peer address info normally extracted from peer list or peer --- compact list encoding. -data PeerAddr = PeerAddr - { peerId :: !(Maybe PeerId) - - -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved - -- 'HostName'. - , peerHost :: !IP - - -- | The port the peer listenning for incoming P2P sessions. - , peerPort :: {-# UNPACK #-} !PortNumber - } deriving (Show, Eq, Ord, Typeable) - -#ifdef VERSION_bencoding -peer_ip_key, peer_id_key, peer_port_key :: BKey -peer_ip_key = "ip" -peer_id_key = "peer id" -peer_port_key = "port" - --- | The tracker's 'announce response' compatible encoding. -instance BEncode PeerAddr where - toBEncode PeerAddr {..} = toDict $ - peer_ip_key .=! peerHost - .: peer_id_key .=? peerId - .: peer_port_key .=! peerPort - .: endDict - - fromBEncode = fromDict $ do - peerAddr <$>! peer_ip_key - <*>? peer_id_key - <*>! peer_port_key - where - peerAddr = flip PeerAddr -#endif - --- | The tracker's 'compact peer list' compatible encoding. The --- 'peerId' is always 'Nothing'. --- --- For more info see: --- --- WARNING: Input must be exactly 6 or 18 bytes so that we can identify IP version. --- -instance Serialize PeerAddr where - put PeerAddr {..} = put peerHost >> put peerPort - get = do - cnt <- remaining - PeerAddr Nothing <$> isolate (cnt - 2) get <*> get - --- | @127.0.0.1:6881@ -instance Default PeerAddr where - def = "127.0.0.1:6881" - --- | Example: --- --- @peerPort \"127.0.0.1:6881\" == 6881@ --- -instance IsString PeerAddr where - fromString str - | (hostAddrStr, portStr0) <- L.break (== ':') str - , let portStr = L.drop 1 portStr0 - , Just hostAddr <- readMaybe hostAddrStr - , Just portNum <- toEnum <$> readMaybe portStr - = PeerAddr Nothing (IPv4 hostAddr) portNum - | [((ip,port),"")] <- readsIPv6_port str = - PeerAddr Nothing (IPv6 ip) port - | otherwise = error $ "fromString: unable to parse IP: " ++ str - -instance Read PeerAddr where - readsPrec i = RP.readP_to_S $ do - ip <- IPv4 <$> ( RP.readS_to_P (readsPrec i) ) - <|> IPv6 <$> ( RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' ) - _ <- RP.char ':' - port <- toEnum <$> RP.readS_to_P (readsPrec i) - return $ PeerAddr Nothing ip port - -readsIPv6_port :: String -> [((IPv6, PortNumber), String)] -readsIPv6_port = RP.readP_to_S $ do - ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' - _ <- RP.char ':' - port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof - return (ip,port) - - --- | fingerprint + "at" + dotted.host.inet.addr:port -instance Pretty PeerAddr where - pPrint PeerAddr {..} - | Just pid <- peerId = pPrint (fingerprint pid) <+> "at" <+> paddr - | otherwise = paddr - where - paddr = pPrint peerHost <> ":" <> text (show peerPort) - -instance Hashable PeerAddr where - hashWithSalt s PeerAddr {..} = - s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort - --- | Ports typically reserved for bittorrent P2P listener. -defaultPorts :: [PortNumber] -defaultPorts = [6881..6889] - -_peerSockAddr :: PeerAddr -> (Family, SockAddr) -_peerSockAddr PeerAddr {..} = - case peerHost of - IPv4 ipv4 -> - (AF_INET, SockAddrInet peerPort (toHostAddress ipv4)) - IPv6 ipv6 -> - (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0) - -peerSockAddr :: PeerAddr -> SockAddr -peerSockAddr = snd . _peerSockAddr - --- | Create a socket connected to the address specified in a peerAddr -peerSocket :: SocketType -> PeerAddr -> IO Socket -peerSocket socketType pa = do - let (family, addr) = _peerSockAddr pa - sock <- socket family socketType defaultProtocol - connect sock addr - return sock - -{----------------------------------------------------------------------- --- Node info ------------------------------------------------------------------------} --- $node-info --- --- A \"node\" is a client\/server listening on a UDP port --- implementing the distributed hash table protocol. The DHT is --- composed of nodes and stores the location of peers. BitTorrent --- clients include a DHT node, which is used to contact other nodes --- in the DHT to get the location of peers to download from using --- the BitTorrent protocol. - --- asNodeId :: ByteString -> NodeId --- asNodeId bs = NodeId $ BS.take nodeIdSize bs - -{- - --- | Test if the nth bit is set. -testIdBit :: NodeId -> Word -> Bool -testIdBit (NodeId bs) i - | fromIntegral i < nodeIdSize * 8 - , (q, r) <- quotRem (fromIntegral i) 8 - = testBit (BS.index bs q) (7 - r) - | otherwise = False --} - -testIdBit :: FiniteBits bs => bs -> Word -> Bool -testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - 1 - fromIntegral i)) -{-# INLINE testIdBit #-} - --- | Generate a random 'NodeId' within a range suitable for a bucket. To --- obtain a sample for bucket number /index/ where /is_last/ indicates if this --- is for the current deepest bucket in our routing table: --- --- > sample <- genBucketSample nid (bucketRange index is_last) -genBucketSample :: ( FiniteBits nid - , Serialize nid - ) => nid -> (Int,Word8,Word8) -> IO nid -genBucketSample n qmb = genBucketSample' getEntropy n qmb - --- | Generalizion of 'genBucketSample' that accepts a byte generator --- function to use instead of the system entropy. -genBucketSample' :: forall m dht nid. - ( Applicative m - , FiniteBits nid - , Serialize nid - ) => - (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid -genBucketSample' gen self (q,m,b) - | q <= 0 = either error id . S.decode <$> gen nodeIdSize - | q >= nodeIdSize = pure self - | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1) - where - nodeIdSize = finiteBitSize (undefined :: nid) `div` 8 - - -- Prepends q bytes to modified input: - -- applies mask m - -- toggles bit b - build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl) - where - hd = BS.take q $ S.encode self - h = xor b (complement m .&. BS.last hd) - t = m .&. BS.head tl - - ------------------------------------------------------------------------- - --- | Accepts a depth/index of a bucket and whether or not it is the last one, --- yields: --- --- count of leading bytes to be copied from your node id. --- --- mask to clear the extra bits of the last copied byte --- --- mask to toggle the last copied bit if it is not the last bucket --- --- Normally this is used with 'genBucketSample' to obtain a random id suitable --- for refreshing a particular bucket. -bucketRange :: Int -> Bool -> (Int, Word8, Word8) -bucketRange depth is_last = (q,m,b) - where - (q,r) = divMod ((if is_last then (+7) else (+8)) depth) 8 - m = 2^(7-r) - 1 - b = if is_last then 0 else 2^(7-r) - ------------------------------------------------------------------------- - -#ifdef VERSION_bencoding --- | Torrent file compatible encoding. -instance BEncode a => BEncode (NodeAddr a) where - toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort) - {-# INLINE toBEncode #-} - fromBEncode b = uncurry NodeAddr <$> fromBEncode b - {-# INLINE fromBEncode #-} -#endif - - -instance Hashable PortNumber where - hashWithSalt s = hashWithSalt s . fromEnum - {-# INLINE hashWithSalt #-} - -instance Pretty PortNumber where - pPrint = PP.int . fromEnum - {-# INLINE pPrint #-} - -instance Serialize PortNumber where - get = fromIntegral <$> getWord16be - {-# INLINE get #-} - put = putWord16be . fromIntegral - {-# INLINE put #-} - -instance Pretty IPv4 where - pPrint = PP.text . show - {-# INLINE pPrint #-} - -instance Pretty IPv6 where - pPrint = PP.text . show - {-# INLINE pPrint #-} - -instance Pretty IP where - pPrint = PP.text . show - {-# INLINE pPrint #-} - - --- | When 'get'ing an IP it must be 'isolate'd to the appropriate --- number of bytes since we have no other way of telling which --- address type we are trying to parse -instance Serialize IP where - put (IPv4 ip) = put ip - put (IPv6 ip) = put ip - - get = do - n <- remaining - case n of - 4 -> IPv4 <$> get - 16 -> IPv6 <$> get - _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP") - -instance Serialize IPv4 where - put = putWord32host . toHostAddress - get = fromHostAddress <$> getWord32host - -instance Serialize IPv6 where - put ip = put $ toHostAddress6 ip - get = fromHostAddress6 <$> get - - -instance Hashable IPv4 where - hashWithSalt = hashUsing toHostAddress - {-# INLINE hashWithSalt #-} - -instance Hashable IPv6 where - hashWithSalt s a = hashWithSalt s (toHostAddress6 a) - -instance Hashable IP where - hashWithSalt s (IPv4 h) = hashWithSalt s h - hashWithSalt s (IPv6 h) = hashWithSalt s h - - - ------------------------------------------------------------------------- - -{----------------------------------------------------------------------- --- Fingerprint ------------------------------------------------------------------------} --- $fingerprint --- --- 'Fingerprint' is used to identify the client implementation and --- version which also contained in 'Peer'. For exsample first 6 --- bytes of peer id of this this library are @-HS0100-@ while for --- mainline we have @M4-3-6--@. We could extract this info and --- print in human-friendly form: this is useful for debugging and --- logging. --- --- For more information see: --- --- --- --- NOTE: Do /not/ use this information to control client --- capabilities (such as supported enchancements), this should be --- done using 'Network.BitTorrent.Extension'! --- - --- TODO FIXME -version :: Version -version = Version [0, 0, 0, 3] [] - --- | List of registered client versions + 'IlibHSbittorrent' (this --- package) + 'IUnknown' (for not recognized software). All names are --- prefixed by \"I\" because some of them starts from lowercase letter --- but that is not a valid Haskell constructor name. --- -data Software = - IUnknown - - | IMainline - - | IABC - | IOspreyPermaseed - | IBTQueue - | ITribler - | IShadow - | IBitTornado - --- UPnP(!) Bit Torrent !??? --- 'U' - UPnP NAT Bit Torrent - | IBitLord - | IOpera - | IMLdonkey - - | IAres - | IArctic - | IAvicora - | IBitPump - | IAzureus - | IBitBuddy - | IBitComet - | IBitflu - | IBTG - | IBitRocket - | IBTSlave - | IBittorrentX - | IEnhancedCTorrent - | ICTorrent - | IDelugeTorrent - | IPropagateDataClient - | IEBit - | IElectricSheep - | IFoxTorrent - | IGSTorrent - | IHalite - | IlibHSbittorrent - | IHydranode - | IKGet - | IKTorrent - | ILH_ABC - | ILphant - | ILibtorrent - | ILibTorrent - | ILimeWire - | IMonoTorrent - | IMooPolice - | IMiro - | IMoonlightTorrent - | INetTransport - | IPando - | IqBittorrent - | IQQDownload - | IQt4TorrentExample - | IRetriever - | IShareaza - | ISwiftbit - | ISwarmScope - | ISymTorrent - | Isharktorrent - | ITorrentDotNET - | ITransmission - | ITorrentstorm - | ITuoTu - | IuLeecher - | IuTorrent - | IVagaa - | IBitLet - | IFireTorrent - | IXunlei - | IXanTorrent - | IXtorrent - | IZipTorrent - deriving (Show, Eq, Ord, Enum, Bounded) - -parseSoftware :: ByteString -> Software -parseSoftware = f . BC.unpack - where - f "AG" = IAres - f "A~" = IAres - f "AR" = IArctic - f "AV" = IAvicora - f "AX" = IBitPump - f "AZ" = IAzureus - f "BB" = IBitBuddy - f "BC" = IBitComet - f "BF" = IBitflu - f "BG" = IBTG - f "BR" = IBitRocket - f "BS" = IBTSlave - f "BX" = IBittorrentX - f "CD" = IEnhancedCTorrent - f "CT" = ICTorrent - f "DE" = IDelugeTorrent - f "DP" = IPropagateDataClient - f "EB" = IEBit - f "ES" = IElectricSheep - f "FT" = IFoxTorrent - f "GS" = IGSTorrent - f "HL" = IHalite - f "HS" = IlibHSbittorrent - f "HN" = IHydranode - f "KG" = IKGet - f "KT" = IKTorrent - f "LH" = ILH_ABC - f "LP" = ILphant - f "LT" = ILibtorrent - f "lt" = ILibTorrent - f "LW" = ILimeWire - f "MO" = IMonoTorrent - f "MP" = IMooPolice - f "MR" = IMiro - f "ML" = IMLdonkey - f "MT" = IMoonlightTorrent - f "NX" = INetTransport - f "PD" = IPando - f "qB" = IqBittorrent - f "QD" = IQQDownload - f "QT" = IQt4TorrentExample - f "RT" = IRetriever - f "S~" = IShareaza - f "SB" = ISwiftbit - f "SS" = ISwarmScope - f "ST" = ISymTorrent - f "st" = Isharktorrent - f "SZ" = IShareaza - f "TN" = ITorrentDotNET - f "TR" = ITransmission - f "TS" = ITorrentstorm - f "TT" = ITuoTu - f "UL" = IuLeecher - f "UT" = IuTorrent - f "VG" = IVagaa - f "WT" = IBitLet - f "WY" = IFireTorrent - f "XL" = IXunlei - f "XT" = IXanTorrent - f "XX" = IXtorrent - f "ZT" = IZipTorrent - f _ = IUnknown - --- | Used to represent a not recognized implementation -instance Default Software where - def = IUnknown - {-# INLINE def #-} - --- | Example: @\"BitLet\" == 'IBitLet'@ -instance IsString Software where - fromString str - | Just impl <- L.lookup str alist = impl - | otherwise = error $ "fromString: not recognized " ++ str - where - alist = L.map mk [minBound..maxBound] - mk x = (L.tail $ show x, x) - --- | Example: @pPrint 'IBitLet' == \"IBitLet\"@ -instance Pretty Software where - pPrint = text . L.tail . show - --- | Just the '0' version. -instance Default Version where - def = Version [0] [] - {-# INLINE def #-} - -dropLastIf :: (a -> Bool) -> [a] -> [a] -dropLastIf pred [] = [] -dropLastIf pred (x:xs) = init' x xs - where init' y [] | pred y = [] - init' y [] = [y] - init' y (z:zs) = y : init' z zs - -linesBy :: (a -> Bool) -> [a] -> [[a]] -linesBy pred ys = dropLastIf L.null $ L.map dropDelim $ L.groupBy (\_ x -> not $ pred x) ys - where - dropDelim [] = [] - dropDelim (x:xs) | pred x = xs - | otherwise = x:xs - --- | For dot delimited version strings. --- Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@ --- -instance IsString Version where - fromString str - | Just nums <- chunkNums str = Version nums [] - | otherwise = error $ "fromString: invalid version string " ++ str - where - chunkNums = sequence . L.map readMaybe . linesBy ('.' ==) - -instance Pretty Version where - pPrint = text . showVersion - --- | The all sensible infomation that can be obtained from a peer --- identifier or torrent /createdBy/ field. -data Fingerprint = Fingerprint Software Version - deriving (Show, Eq, Ord) - --- | Unrecognized client implementation. -instance Default Fingerprint where - def = Fingerprint def def - {-# INLINE def #-} - --- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@ -instance IsString Fingerprint where - fromString str - | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver) - | otherwise = error $ "fromString: invalid client info string" ++ str - where - (impl, _ver) = L.span ((/=) '-') str - -instance Pretty Fingerprint where - pPrint (Fingerprint s v) = pPrint s <+> "version" <+> pPrint v - --- | Fingerprint of this (the bittorrent library) package. Normally, --- applications should introduce its own fingerprints, otherwise they --- can use 'libFingerprint' value. --- -libFingerprint :: Fingerprint -libFingerprint = Fingerprint IlibHSbittorrent version - --- | HTTP user agent of this (the bittorrent library) package. Can be --- used in HTTP tracker requests. -libUserAgent :: String -libUserAgent = render (pPrint IlibHSbittorrent <> "/" <> pPrint version) - -{----------------------------------------------------------------------- --- For torrent file ------------------------------------------------------------------------} --- TODO collect information about createdBy torrent field --- renderImpl :: ClientImpl -> Text --- renderImpl = T.pack . L.tail . show --- --- renderVersion :: Version -> Text --- renderVersion = undefined --- --- renderClientInfo :: ClientInfo -> Text --- renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion --- --- parseClientInfo :: Text -> ClientImpl --- parseClientInfo t = undefined - - --- code used for generation; remove it later on --- --- mkEnumTyDef :: NM -> String --- mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd --- --- mkPars :: NM -> String --- mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl) --- --- type NM = [(String, String)] --- nameMap :: NM --- nameMap = --- [ ("AG", "Ares") --- , ("A~", "Ares") --- , ("AR", "Arctic") --- , ("AV", "Avicora") --- , ("AX", "BitPump") --- , ("AZ", "Azureus") --- , ("BB", "BitBuddy") --- , ("BC", "BitComet") --- , ("BF", "Bitflu") --- , ("BG", "BTG") --- , ("BR", "BitRocket") --- , ("BS", "BTSlave") --- , ("BX", "BittorrentX") --- , ("CD", "EnhancedCTorrent") --- , ("CT", "CTorrent") --- , ("DE", "DelugeTorrent") --- , ("DP", "PropagateDataClient") --- , ("EB", "EBit") --- , ("ES", "ElectricSheep") --- , ("FT", "FoxTorrent") --- , ("GS", "GSTorrent") --- , ("HL", "Halite") --- , ("HS", "libHSnetwork_bittorrent") --- , ("HN", "Hydranode") --- , ("KG", "KGet") --- , ("KT", "KTorrent") --- , ("LH", "LH_ABC") --- , ("LP", "Lphant") --- , ("LT", "Libtorrent") --- , ("lt", "LibTorrent") --- , ("LW", "LimeWire") --- , ("MO", "MonoTorrent") --- , ("MP", "MooPolice") --- , ("MR", "Miro") --- , ("MT", "MoonlightTorrent") --- , ("NX", "NetTransport") --- , ("PD", "Pando") --- , ("qB", "qBittorrent") --- , ("QD", "QQDownload") --- , ("QT", "Qt4TorrentExample") --- , ("RT", "Retriever") --- , ("S~", "Shareaza") --- , ("SB", "Swiftbit") --- , ("SS", "SwarmScope") --- , ("ST", "SymTorrent") --- , ("st", "sharktorrent") --- , ("SZ", "Shareaza") --- , ("TN", "TorrentDotNET") --- , ("TR", "Transmission") --- , ("TS", "Torrentstorm") --- , ("TT", "TuoTu") --- , ("UL", "uLeecher") --- , ("UT", "uTorrent") --- , ("VG", "Vagaa") --- , ("WT", "BitLet") --- , ("WY", "FireTorrent") --- , ("XL", "Xunlei") --- , ("XT", "XanTorrent") --- , ("XX", "Xtorrent") --- , ("ZT", "ZipTorrent") --- ] - --- TODO use regexps - --- | Tries to extract meaningful information from peer ID bytes. If --- peer id uses unknown coding style then client info returned is --- 'def'. --- -fingerprint :: PeerId -> Fingerprint -fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid) - where - getCI = do - leading <- BS.w2c <$> getWord8 - case leading of - '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion - 'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion - 'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion - 'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion - c -> do - c1 <- BS.w2c <$> S.lookAhead getWord8 - if c1 == 'P' - then do - _ <- getWord8 - Fingerprint <$> pure IOpera <*> getOperaVersion - else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion - - getMainlineVersion = do - str <- BC.unpack <$> getByteString 7 - let mnums = L.filter (not . L.null) $ linesBy ('-' ==) str - return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) [] - - getAzureusImpl = parseSoftware <$> getByteString 2 - getAzureusVersion = mkVer <$> getByteString 4 - where - mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] [] - - getBitCometImpl = do - bs <- getByteString 3 - S.lookAhead $ do - _ <- getByteString 2 - lr <- getByteString 4 - return $ - if lr == "LORD" then IBitLord else - if bs == "UTB" then IBitComet else - if bs == "xbc" then IBitComet else def - - getBitCometVersion = do - x <- getWord8 - y <- getWord8 - return $ Version [fromIntegral x, fromIntegral y] [] - - getOperaVersion = do - str <- BC.unpack <$> getByteString 4 - return $ Version [fromMaybe 0 $ readMaybe str] [] - - getShadowImpl 'A' = IABC - getShadowImpl 'O' = IOspreyPermaseed - getShadowImpl 'Q' = IBTQueue - getShadowImpl 'R' = ITribler - getShadowImpl 'S' = IShadow - getShadowImpl 'T' = IBitTornado - getShadowImpl _ = IUnknown - - decodeShadowVerNr :: Char -> Maybe Int - decodeShadowVerNr c - | '0' < c && c <= '9' = Just (fromEnum c - fromEnum '0') - | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10) - | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36) - | otherwise = Nothing - - getShadowVersion = do - str <- BC.unpack <$> getByteString 5 - return $ Version (catMaybes $ L.map decodeShadowVerNr str) [] - - - --- | Given a string specifying a port (numeric or service name) --- and a flag indicating whether you want to support IPv6, this --- function will return a SockAddr to bind to. If the input --- is not understood as a port number, zero will be set in order --- to ask the system for an unused port. -getBindAddress :: String -> Bool -> IO SockAddr -getBindAddress bindspec enabled6 = do - let (host,listenPortString) = case L.break (==':') (L.reverse bindspec) of - (rport,':':rhost) -> (Just $ L.reverse rhost, L.reverse rport) - _ -> (Nothing, bindspec) - -- Bind addresses for localhost - xs <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE] })) - host - (Just listenPortString) - `onException` return [] - -- We prefer IPv6 because that can also handle connections from IPv4 - -- clients... - let (x6s,x4s) = partition (\s -> addrFamily s == AF_INET6) xs - listenAddr = - case if enabled6 then x6s++x4s else x4s of - AddrInfo { addrAddress = addr } : _ -> addr - _ -> if enabled6 - then SockAddrInet6 (parsePort listenPortString) 0 iN6ADDR_ANY 0 - else SockAddrInet (parsePort listenPortString) iNADDR_ANY - where parsePort s = fromMaybe 0 $ readMaybe s - dput XMisc $ "Listening on " ++ show listenAddr - return listenAddr - --- | True if the argument is an IPv4-mapped address with prefix ::FFFF:0:0/96 --- as defined in RFC 4291. -is4mapped :: IPv6 -> Bool -is4mapped ip - | [0,0,0,0,0,0xffff,_,_] <- fromIPv6 ip - = True - | otherwise = False - -un4map :: IPv6 -> Maybe IPv4 -un4map ip - | [0,0,0,0,0,0xffff,x,y] <- fromIPv6 ip - = Just $ toIPv4 - $ L.map (.&. 0xFF) - [x `shiftR` 8, x, y `shiftR` 8, y ] - | otherwise = Nothing - -ipFamily :: IP -> WantIP -ipFamily ip = case ip of - IPv4 _ -> Want_IP4 - IPv6 a | is4mapped a -> Want_IP4 - | otherwise -> Want_IP6 - -either4or6 :: SockAddr -> Either SockAddr SockAddr -either4or6 a4@(SockAddrInet port addr) = Left a4 -either4or6 a6@(SockAddrInet6 port _ addr _) - | Just ip4 <- (fromSockAddr a6 >>= un4map) = Left (setPort port $ toSockAddr ip4) - | otherwise = Right a6 - -data WantIP = Want_IP4 | Want_IP6 | Want_Both - deriving (Eq, Enum, Ord, Show) - -localhost6 :: SockAddr -localhost6 = SockAddrInet6 0 0 (0,0,0,1) 0 -- [::1]:0 - -localhost4 :: SockAddr -localhost4 = SockAddrInet 0 16777343 -- 127.0.0.1:0 - diff --git a/src/Network/BitTorrent/DHT/ContactInfo.hs b/src/Network/BitTorrent/DHT/ContactInfo.hs deleted file mode 100644 index ec7e6658..00000000 --- a/src/Network/BitTorrent/DHT/ContactInfo.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Network.BitTorrent.DHT.ContactInfo - ( PeerStore - , PeerAddr(..) - , Network.BitTorrent.DHT.ContactInfo.lookup - , Network.BitTorrent.DHT.ContactInfo.freshPeers - , Network.BitTorrent.DHT.ContactInfo.insertPeer - , deleteOlderThan - , knownSwarms - ) where - -import Control.Applicative -import Data.Default -import Data.List as L -import Data.Maybe -import Data.HashMap.Strict as HM -import Data.Serialize -import Data.Semigroup -import Data.Wrapper.PSQ as PSQ -import Data.Time.Clock.POSIX -import Data.ByteString (ByteString) -import Data.Word - -import Data.Torrent -import Network.Address - --- {- --- import Data.HashMap.Strict as HM --- --- import Data.Torrent.InfoHash --- import Network.Address --- --- -- increase prefix when table is too large --- -- decrease prefix when table is too small --- -- filter outdated peers --- --- {----------------------------------------------------------------------- --- -- PeerSet --- -----------------------------------------------------------------------} --- --- type PeerSet a = [(PeerAddr, NodeInfo a, Timestamp)] --- --- -- compare PSQueue vs Ordered list --- --- takeNewest :: PeerSet a -> [PeerAddr] --- takeNewest = undefined --- --- dropOld :: Timestamp -> PeerSet a -> PeerSet a --- dropOld = undefined --- --- insert :: PeerAddr -> Timestamp -> PeerSet a -> PeerSet a --- insert = undefined --- --- type Mask = Int --- type Size = Int --- type Timestamp = Int --- --- {----------------------------------------------------------------------- --- -- InfoHashMap --- -----------------------------------------------------------------------} --- --- -- compare handwritten prefix tree versus IntMap --- --- data Tree a --- = Nil --- | Tip !InfoHash !(PeerSet a) --- | Bin !InfoHash !Mask !Size !Timestamp (Tree a) (Tree a) --- --- insertTree :: InfoHash -> a -> Tree a -> Tree a --- insertTree = undefined --- --- type Prio = Int --- --- --shrink :: ContactInfo ip -> Int --- shrink Nil = Nil --- shrink (Tip _ _) = undefined --- shrink (Bin _ _) = undefined --- --- {----------------------------------------------------------------------- --- -- InfoHashMap --- -----------------------------------------------------------------------} --- --- -- compare new design versus HashMap --- --- data IntMap k p a --- type ContactInfo = Map InfoHash Timestamp (Set (PeerAddr IP) Timestamp) --- --- data ContactInfo ip = PeerStore --- { maxSize :: Int --- , prefixSize :: Int --- , thisNodeId :: NodeId --- --- , count :: Int -- ^ Cached size of the 'peerSet' --- , peerSet :: HashMap InfoHash [PeerAddr ip] --- } --- --- size :: ContactInfo ip -> Int --- size = undefined --- --- prefixSize :: ContactInfo ip -> Int --- prefixSize = undefined --- --- lookup :: InfoHash -> ContactInfo ip -> [PeerAddr ip] --- lookup = undefined --- --- insert :: InfoHash -> PeerAddr ip -> ContactInfo ip -> ContactInfo ip --- insert = undefined --- --- -- | Limit in size. --- prune :: NodeId -> Int -> ContactInfo ip -> ContactInfo ip --- prune pref targetSize Nil = Nil --- prune pref targetSize (Tip _ _) = undefined --- --- -- | Remove expired entries. --- splitGT :: Timestamp -> ContactInfo ip -> ContactInfo ip --- splitGT = undefined --- -} - --- | Storage used to keep track a set of known peers in client, --- tracker or DHT sessions. -newtype PeerStore = PeerStore (HashMap InfoHash SwarmData) - -type Timestamp = POSIXTime - -data SwarmData = SwarmData - { peers :: !(PSQ PeerAddr Timestamp) - , name :: !(Maybe ByteString) - } - --- | This wrapper will serialize an ip address with a '4' or '6' prefix byte --- to indicate whether it is IPv4 or IPv6. --- --- Note: it does not serialize port numbers. -newtype SerializeAddress a = SerializeAddress { unserializeAddress :: a } - -instance Address a => Serialize (SerializeAddress a) where - get = SerializeAddress <$> do - c <- get - case (c::Word8) of - 0x34 -> do ip4 <- get - return $ fromJust $ fromAddr (ip4::IPv4) - 0x36 -> do ip6 <- get - return $ fromJust $ fromAddr (ip6::IPv6) - _ -> return $ error "cannot deserialize non-IP SerializeAddress" - put (SerializeAddress a) - | Just ip4 <- fromAddr a - = put (0x34::Word8) >> put (ip4::IPv4) - | Just ip6 <- fromAddr a - = put (0x36::Word8) >> put (ip6::IPv6) - | otherwise = return $ error "cannot serialize non-IP SerializeAddress" - - -instance Serialize SwarmData where - get = flip SwarmData <$> get - <*> ( PSQ.fromList . L.map parseAddr <$> get ) - where - parseAddr (pid,addr,port) = PeerAddr { peerId = pid - , peerHost = unserializeAddress addr - , peerPort = port - } - :-> 0 - - put SwarmData{..} = do - put name - put $ L.map (\(addr :-> _) -> (peerId addr, SerializeAddress addr, peerPort addr)) - -- XXX: should we serialize the timestamp? - $ PSQ.toList peers - -knownSwarms :: PeerStore -> [ (InfoHash, Int, Maybe ByteString) ] -knownSwarms (PeerStore m) = L.map (\(ih,SwarmData q n) -> (ih,PSQ.size q,n)) $ HM.toList m - -swarmSingleton :: PeerAddr -> SwarmData -swarmSingleton a = SwarmData - { peers = PSQ.singleton a 0 - , name = Nothing } - -swarmInsert :: SwarmData -> SwarmData -> SwarmData -swarmInsert new old = SwarmData - { peers = L.foldl' (\q (a :-> t) -> PSQ.insertWith newerTimeStamp a t q) (peers old) (PSQ.toList $ peers new) - , name = name new <|> name old -- TODO: decodeUtf8' check - } - where - newerTimeStamp newtime oldtime = if newtime > oldtime then newtime else oldtime - -isSwarmOccupied :: SwarmData -> Bool -isSwarmOccupied SwarmData{..} = not $ PSQ.null peers - --- | Empty store. -instance Default (PeerStore) where - def = PeerStore HM.empty - {-# INLINE def #-} - -instance Semigroup PeerStore where - PeerStore a <> PeerStore b = - PeerStore (HM.unionWith swarmInsert a b) - {-# INLINE (<>) #-} - --- | Monoid under union operation. -instance Monoid PeerStore where - mempty = def - {-# INLINE mempty #-} - - mappend (PeerStore a) (PeerStore b) = - PeerStore (HM.unionWith swarmInsert a b) - {-# INLINE mappend #-} - --- | Can be used to store peers between invocations of the client --- software. -instance Serialize PeerStore where - get = PeerStore . HM.fromList <$> get - put (PeerStore m) = put (L.filter (isSwarmOccupied . snd) $ HM.toList m) - --- | Returns all peers associated with a given info hash. -lookup :: InfoHash -> PeerStore -> [PeerAddr] -lookup ih (PeerStore m) = maybe [] (PSQ.keys . peers) $ HM.lookup ih m - -batchSize :: Int -batchSize = 64 - --- | Used in 'get_peers' DHT queries. -freshPeers :: InfoHash -> Timestamp -> PeerStore -> ([PeerAddr], PeerStore) -freshPeers ih tm (PeerStore m) = fromMaybe ([],PeerStore m) $ do - swarm <- HM.lookup ih m - let ps0 = take batchSize $ unfoldr (incomp minView) (peers swarm) - peers' = case reverse ps0 of - (_,psq):_ -> psq - _ -> peers swarm - ps = L.map (key . fst) ps0 - m' = HM.insert ih swarm { peers = L.foldl' (\q p -> PSQ.insert p tm q) peers' ps } m - return $! m' `seq` (ps,PeerStore m') - -incomp :: (x -> Maybe (r,x)) -> x -> Maybe ((r,x),x) -incomp !f !x = do - (result,x') <- f x - pure $! ( (result,x'), x' ) - --- | Used in 'announce_peer' DHT queries. -insertPeer :: InfoHash -> Maybe ByteString -> PeerAddr -> PeerStore -> PeerStore -insertPeer !ih !name !a !(PeerStore m) = seq a' $ PeerStore (HM.insertWith swarmInsert ih a' m) - where - a' = SwarmData { peers = PSQ.singleton a 0 - , name = name } - -deleteOlderThan :: POSIXTime -> PeerStore -> PeerStore -deleteOlderThan cutoff (PeerStore m) = PeerStore $ HM.mapMaybe gc m - where - gc :: SwarmData -> Maybe SwarmData - gc swarms = fmap (\ps -> swarms { peers = ps }) $ gcPSQ (peers swarms) - - gcPSQ :: PSQKey a => PSQ a Timestamp -> Maybe (PSQ a Timestamp) - gcPSQ ps = case minView ps of - Nothing -> Nothing - Just (_ :-> tm, ps') | tm < cutoff -> gcPSQ ps' - Just _ -> Just ps diff --git a/src/Network/BitTorrent/DHT/Readme.md b/src/Network/BitTorrent/DHT/Readme.md deleted file mode 100644 index e2352f10..00000000 --- a/src/Network/BitTorrent/DHT/Readme.md +++ /dev/null @@ -1,13 +0,0 @@ -References -========== - -Some good references excluding BEPs: - -* [Kademlia wiki page][kademlia-wiki] -* [Kademlia: A Peer-to-peer Information System Based on the XOR Metric][kademlia-paper] -* [BitTorrent Mainline DHT Measurement][mldht] -* Profiling a Million User DHT. (paper) - -[kademlia-wiki]: http://en.wikipedia.org/wiki/Kademlia -[kademlia-paper]: http://pdos.csail.mit.edu/~petar/papers/maymounkov-kademlia-lncs.pdf -[mldht]: http://www.cs.helsinki.fi/u/jakangas/MLDHT/ diff --git a/src/Network/BitTorrent/DHT/Token.hs b/src/Network/BitTorrent/DHT/Token.hs deleted file mode 100644 index 171cc8be..00000000 --- a/src/Network/BitTorrent/DHT/Token.hs +++ /dev/null @@ -1,201 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- The return value for a query for peers includes an opaque value --- known as the 'Token'. For a node to announce that its controlling --- peer is downloading a torrent, it must present the token received --- from the same queried node in a recent query for peers. When a node --- attempts to \"announce\" a torrent, the queried node checks the --- token against the querying node's 'IP' address. This is to prevent --- malicious hosts from signing up other hosts for torrents. Since the --- token is merely returned by the querying node to the same node it --- received the token from, the implementation is not defined. Tokens --- must be accepted for a reasonable amount of time after they have --- been distributed. --- -{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-} -module Network.BitTorrent.DHT.Token - ( -- * Token - Token - , maxInterval - , toPaddedByteString - , fromPaddedByteString - - -- * Session tokens - , TokenMap - , SessionTokens - , nullSessionTokens - , checkToken - , grantToken - - -- ** Construction - , Network.BitTorrent.DHT.Token.tokens - - -- ** Query - , Network.BitTorrent.DHT.Token.lookup - , Network.BitTorrent.DHT.Token.member - - -- ** Modification - , Network.BitTorrent.DHT.Token.defaultUpdateInterval - , Network.BitTorrent.DHT.Token.update - ) where - -import Control.Arrow -import Control.Monad.State -#ifdef VERSION_bencoding -import Data.BEncode (BEncode) -#endif -import Data.ByteString as BS -import Data.ByteString.Char8 as B8 -import Data.ByteString.Lazy as BL -import Data.ByteString.Lazy.Builder as BS -import qualified Data.ByteString.Base16 as Base16 -import Data.Default -import Data.List as L -import Data.Hashable -import Data.String -import Data.Time -import System.Random -import Control.Concurrent.STM - --- TODO use ShortByteString - --- | An opaque value. -newtype Token = Token BS.ByteString - deriving ( Eq, IsString -#ifdef VERSION_bencoding - , BEncode -#endif - ) - -instance Show Token where - show (Token bs) = B8.unpack $ Base16.encode bs - -instance Read Token where - readsPrec i s = pure $ (Token *** B8.unpack) $ Base16.decode (B8.pack s) - --- | Meaningless token, for testing purposes only. -instance Default Token where - def = makeToken (0::Int) 0 - --- | Prepend token with 0x20 bytes to fill the available width. --- --- If n > 8, then this will also guarantee a nonzero token, which is useful for --- Tox ping-id values for announce responses. -toPaddedByteString :: Int -> Token -> BS.ByteString -toPaddedByteString n (Token bs) = BS.append (BS.replicate (n - BS.length bs) 0x20) bs - -fromPaddedByteString :: Int -> BS.ByteString -> Token -fromPaddedByteString n bs = Token $ BS.drop (n - len) bs - where - len = BS.length tok where Token tok = def - --- | The secret value used as salt. -type Secret = Int - --- The BitTorrent implementation uses the SHA1 hash of the IP address --- concatenated onto a secret, we use hashable instead. -makeToken :: Hashable a => a -> Secret -> Token -makeToken n s = Token $ toBS $ hashWithSalt s n - where - toBS = toStrict . toLazyByteString . int64BE . fromIntegral -{-# INLINE makeToken #-} - --- | Constant space 'Node' to 'Token' map based on the secret value. -data TokenMap = TokenMap - { prevSecret :: {-# UNPACK #-} !Secret - , curSecret :: {-# UNPACK #-} !Secret - , generator :: {-# UNPACK #-} !StdGen - } deriving Show - --- | A new token map based on the specified seed value. Returned token --- map should be periodicatically 'update'd. --- --- Normally, the seed value should vary between invocations of the --- client software. -tokens :: Int -> TokenMap -tokens seed = (`evalState` mkStdGen seed) $ - TokenMap <$> state next - <*> state next - <*> get - --- | Get token for the given node. A token becomes invalid after 2 --- 'update's. --- --- Typically used to handle find_peers query. -lookup :: Hashable a => a -> TokenMap -> Token -lookup addr TokenMap {..} = makeToken addr curSecret - --- | Check if token is valid. --- --- Typically used to handle 'Network.DHT.Mainline.Announce' --- query. If token is invalid the 'Network.KRPC.ProtocolError' should --- be sent back to the malicious node. -member :: Hashable a => a -> Token -> TokenMap -> Bool -member addr token TokenMap {..} = token `L.elem` valid - where valid = makeToken addr <$> [curSecret, prevSecret] - --- | Secret changes every five minutes and tokens up to ten minutes old --- are accepted. -defaultUpdateInterval :: NominalDiffTime -defaultUpdateInterval = 5 * 60 - --- | Update current tokens. -update :: TokenMap -> TokenMap -update TokenMap {..} = TokenMap - { prevSecret = curSecret - , curSecret = newSecret - , generator = newGen - } - where - (newSecret, newGen) = next generator - -data SessionTokens = SessionTokens - { tokenMap :: !TokenMap - , lastUpdate :: !UTCTime - , maxInterval :: !NominalDiffTime - } - -nullSessionTokens :: IO SessionTokens -nullSessionTokens = SessionTokens - <$> (tokens <$> randomIO) - <*> getCurrentTime - <*> pure defaultUpdateInterval - --- TODO invalidate *twice* if needed -invalidateTokens :: UTCTime -> SessionTokens -> SessionTokens -invalidateTokens curTime ts @ SessionTokens {..} - | curTime `diffUTCTime` lastUpdate > maxInterval = SessionTokens - { tokenMap = update tokenMap - , lastUpdate = curTime - , maxInterval = maxInterval - } - | otherwise = ts - -{----------------------------------------------------------------------- --- Tokens ------------------------------------------------------------------------} - -tryUpdateSecret :: TVar SessionTokens -> IO () -tryUpdateSecret toks = do - curTime <- getCurrentTime - atomically $ modifyTVar' toks (invalidateTokens curTime) - -grantToken :: Hashable addr => TVar SessionTokens -> addr -> IO Token -grantToken sessionTokens addr = do - tryUpdateSecret sessionTokens - toks <- readTVarIO sessionTokens - return $ Network.BitTorrent.DHT.Token.lookup addr $ tokenMap toks - --- | Throws 'HandlerError' if the token is invalid or already --- expired. See 'TokenMap' for details. -checkToken :: Hashable addr => TVar SessionTokens -> addr -> Token -> IO Bool -checkToken sessionTokens addr questionableToken = do - tryUpdateSecret sessionTokens - toks <- readTVarIO sessionTokens - return $ member addr questionableToken (tokenMap toks) - diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs deleted file mode 100644 index 89851e88..00000000 --- a/src/Network/BitTorrent/MainlineDHT.hs +++ /dev/null @@ -1,1169 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -module Network.BitTorrent.MainlineDHT where - -import Control.Applicative -import Control.Arrow -import Control.Concurrent.STM -import Control.Monad -import Crypto.Random -import Data.BEncode as BE -import qualified Data.BEncode.BDict as BE - ;import Data.BEncode.BDict (BKey) -import Data.BEncode.Pretty -import Data.BEncode.Types (BDict) -import Data.Bits -import Data.Bits.ByteString () -import Data.Bool -import Data.ByteArray (ByteArrayAccess) -import qualified Data.ByteString as B - ;import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as C8 -import Data.ByteString.Lazy (toStrict) -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.Char -import Data.Coerce -import Data.Data -import Data.Default -import Data.Digest.CRC32C -import Data.Function (fix) -import Data.Hashable -#if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) -#else -import Data.IP -#endif -import Data.Maybe -import Data.Monoid -import Data.Ord -import qualified Data.Serialize as S -import Data.Set (Set) -import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import Data.Torrent -import Data.Word -import qualified Data.Wrapper.PSQInt as Int -import Debug.Trace -import Network.BitTorrent.MainlineDHT.Symbols -import Network.Kademlia -import Network.Kademlia.Bootstrap -import Network.Address (fromSockAddr, - setPort, sockAddrPort, testIdBit, - toSockAddr, genBucketSample', WantIP(..), - un4map,either4or6,ipFamily) -import Network.BitTorrent.DHT.ContactInfo as Peers -import Network.Kademlia.Search (Search (..)) -import Network.BitTorrent.DHT.Token as Token -import qualified Network.Kademlia.Routing as R - ;import Network.Kademlia.Routing (getTimestamp) -import Network.QueryResponse -import Network.Socket -import System.IO.Error -import System.IO.Unsafe (unsafeInterleaveIO) -import qualified Text.ParserCombinators.ReadP as RP -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -import GHC.Conc (labelThread) -#endif -import qualified Data.Aeson as JSON - ;import Data.Aeson (FromJSON, ToJSON, (.=)) -import Text.Read -import System.Global6 -import Control.TriadCommittee -import Data.TableMethods -import DPut -import DebugTag - -newtype NodeId = NodeId ByteString - deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable) - -instance BEncode NodeId where - fromBEncode bval = do - bs <- fromBEncode bval - if B.length bs /= 20 - then Left "Invalid length node id." - else Right $ NodeId bs - - toBEncode (NodeId bs) = toBEncode bs - -instance Show NodeId where - show (NodeId bs) = C8.unpack $ Base16.encode bs - -instance S.Serialize NodeId where - get = NodeId <$> S.getBytes 20 - put (NodeId bs) = S.putByteString bs - -instance FiniteBits NodeId where - finiteBitSize _ = 160 - -instance Read NodeId where - readsPrec _ str - | (bs, xs) <- Base16.decode $ C8.pack str - , B.length bs == 20 - = [ (NodeId bs, drop 40 str) ] - | otherwise = [] - -zeroID :: NodeId -zeroID = NodeId $ B.replicate 20 0 - -data NodeInfo = NodeInfo - { nodeId :: NodeId - , nodeIP :: IP - , nodePort :: PortNumber - } - deriving (Eq,Ord) - -instance ToJSON NodeInfo where - toJSON (NodeInfo nid (IPv4 ip) port) - = JSON.object [ "node-id" .= show nid - , "ipv4" .= show ip - , "port" .= (fromIntegral port :: Int) - ] - toJSON (NodeInfo nid (IPv6 ip6) port) - | Just ip <- un4map ip6 - = JSON.object [ "node-id" .= show nid - , "ipv4" .= show ip - , "port" .= (fromIntegral port :: Int) - ] - | otherwise - = JSON.object [ "node-id" .= show nid - , "ipv6" .= show ip6 - , "port" .= (fromIntegral port :: Int) - ] -instance FromJSON NodeInfo where - parseJSON (JSON.Object v) = do - nidstr <- v JSON..: "node-id" - 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 == 20) - return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16)) - -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 = 40 -- 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==20 -> return (NodeId 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. It is --- used to compute the announce token. -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 . (']' :) - -{- - --- | KRPC 'compact list' compatible encoding: contact information for --- nodes is encoded as a 26-byte string. Also known as "Compact node --- info" the 20-byte Node ID in network byte order has the compact --- IP-address/port info concatenated to the end. - get = NodeInfo <$> (NodeId <$> S.getBytes 20 ) <*> S.get <*> S.get --} - -getNodeInfo4 :: S.Get NodeInfo -getNodeInfo4 = NodeInfo <$> (NodeId <$> S.getBytes 20) - <*> (IPv4 <$> S.get) - <*> S.get - -putNodeInfo4 :: NodeInfo -> S.Put -putNodeInfo4 (NodeInfo (NodeId nid) ip port) - | IPv4 ip4 <- ip = put4 ip4 - | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = put4 ip4 - | otherwise = return () - where - put4 ip4 = S.putByteString nid >> S.put ip4 >> S.put port - -getNodeInfo6 :: S.Get NodeInfo -getNodeInfo6 = NodeInfo <$> (NodeId <$> S.getBytes 20) - <*> (IPv6 <$> S.get) - <*> S.get - -putNodeInfo6 :: NodeInfo -> S.Put -putNodeInfo6 (NodeInfo (NodeId nid) (IPv6 ip) port) - = S.putByteString nid >> S.put ip >> S.put port -putNodeInfo6 _ = return () - - --- | TODO: This should depend on the bind address to support IPv4-only. For --- now, in order to support dual-stack listen, we're going to assume IPv6 is --- wanted and map IPv4 addresses accordingly. -nodeAddr :: NodeInfo -> SockAddr -nodeAddr (NodeInfo _ ip port) = - case ip of - IPv4 ip4 -> setPort port $ toSockAddr (ipv4ToIPv6 ip4) - IPv6 ip6 -> setPort port $ toSockAddr ip6 - -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." - --- | Types of RPC errors. -data ErrorCode - -- | Some error doesn't fit in any other category. - = GenericError - - -- | Occurs when server fail to process procedure call. - | ServerError - - -- | Malformed packet, invalid arguments or bad token. - | ProtocolError - - -- | Occurs when client trying to call method server don't know. - | MethodUnknown - deriving (Show, Read, Eq, Ord, Bounded, Typeable, Data) - --- | According to the table: --- -instance Enum ErrorCode where - fromEnum GenericError = 201 - fromEnum ServerError = 202 - fromEnum ProtocolError = 203 - fromEnum MethodUnknown = 204 - {-# INLINE fromEnum #-} - toEnum 201 = GenericError - toEnum 202 = ServerError - toEnum 203 = ProtocolError - toEnum 204 = MethodUnknown - toEnum _ = GenericError - {-# INLINE toEnum #-} - -instance BEncode ErrorCode where - toBEncode = toBEncode . fromEnum - {-# INLINE toBEncode #-} - fromBEncode b = toEnum <$> fromBEncode b - {-# INLINE fromBEncode #-} - -data Error = Error - { errorCode :: !ErrorCode -- ^ The type of error. - , errorMessage :: !ByteString -- ^ Human-readable text message. - } deriving ( Show, Eq, Ord, Typeable, Data, Read ) - -newtype TransactionId = TransactionId ByteString - deriving (Eq, Ord, Show, BEncode) - -newtype Method = Method ByteString - deriving (Eq, Ord, Show, BEncode) - -data Message a = Q { msgOrigin :: NodeId - , msgID :: TransactionId - , qryPayload :: a - , qryMethod :: Method - , qryReadOnly :: Bool } - - | R { msgOrigin :: NodeId - , msgID :: TransactionId - , rspPayload :: Either Error a - , rspReflectedIP :: Maybe SockAddr } - -showBE :: BValue -> String -showBE bval = L8.unpack (showBEncode bval) - -instance BE.BEncode (Message BValue) where - toBEncode m = encodeMessage m - {- - in case m of - Q {} -> trace ("encoded(query): "++showBE r) r - R {} -> trace ("encoded(response): "++showBE r) r -} - fromBEncode bval = decodeMessage bval - {- - in case r of - Left e -> trace (show e) r - Right (Q {}) -> trace ("decoded(query): "++showBE bval) r - Right (R {}) -> trace ("decoded(response): "++showBE bval) r -} - -decodeMessage :: BValue -> Either String (Message BValue) -decodeMessage = fromDict $ do - key <- lookAhead (field (req "y")) - let _ = key :: BKey - f <- case key of - "q" -> do a <- field (req "a") - g <- either fail return $ flip fromDict a $ do - who <- field (req "id") - ro <- fromMaybe False <$> optional (field (req "ro")) - return $ \meth tid -> Q who tid a meth ro - meth <- field (req "q") - return $ g meth - "r" -> do ip <- do - ipstr <- optional (field (req "ip")) - mapM (either fail return . decodeAddr) ipstr - vals <- field (req "r") - either fail return $ flip fromDict vals $ do - who <- field (req "id") - return $ \tid -> R who tid (Right vals) ip - "e" -> do (ecode,emsg) <- field (req "e") - ip <- do - ipstr <- optional (field (req "ip")) - mapM (either fail return . decodeAddr) ipstr - -- FIXME:Spec does not give us the NodeId of the sender. - -- Using 'zeroID' as place holder. - -- We should ignore the msgOrigin for errors in 'updateRouting'. - -- We should consider making msgOrigin a Maybe value. - return $ \tid -> R zeroID tid (Left (Error ecode emsg)) ip - _ -> fail $ "Mainline message is not a query, response, or an error: " - ++ show key - tid <- field (req "t") - return $ f (tid :: TransactionId) - - -encodeMessage :: Message BValue -> BValue -encodeMessage (Q origin tid a meth ro) - = case a of - BDict args -> encodeQuery tid meth (BDict $ genericArgs origin ro `BE.union` args) - _ -> encodeQuery tid meth a -- XXX: Not really a valid query. -encodeMessage (R origin tid v ip) - = case v of - Right (BDict vals) -> encodeResponse tid (BDict $ genericArgs origin False `BE.union` vals) ip - Left err -> encodeError tid err - - -encodeAddr :: SockAddr -> ByteString -encodeAddr = either encode4 encode6 . either4or6 - where - encode4 (SockAddrInet port addr) - = S.runPut (S.putWord32host addr >> S.putWord16be (fromIntegral port)) - - encode6 (SockAddrInet6 port _ addr _) - = S.runPut (S.put addr >> S.putWord16be (fromIntegral port)) - encode6 _ = B.empty - -decodeAddr :: ByteString -> Either String SockAddr -decodeAddr bs = S.runGet g bs - where - g | (B.length bs == 6) = flip SockAddrInet <$> S.getWord32host <*> (fromIntegral <$> S.getWord16be) - | otherwise = do host <- S.get -- TODO: Is this right? - port <- fromIntegral <$> S.getWord16be - return $ SockAddrInet6 port 0 host 0 - -genericArgs :: BEncode a => a -> Bool -> BDict -genericArgs nodeid ro = - "id" .=! nodeid - .: "ro" .=? bool Nothing (Just (1 :: Int)) ro - .: endDict - -encodeError :: BEncode a => a -> Error -> BValue -encodeError tid (Error ecode emsg) = encodeAny tid "e" (ecode,emsg) id - -encodeResponse :: (BEncode tid, BEncode vals) => - tid -> vals -> Maybe SockAddr -> BValue -encodeResponse tid rvals rip = - encodeAny tid "r" rvals ("ip" .=? (BString . encodeAddr <$> rip) .:) - -encodeQuery :: (BEncode args, BEncode tid, BEncode method) => - tid -> method -> args -> BValue -encodeQuery tid qmeth qargs = encodeAny tid "q" qmeth ("a" .=! qargs .:) - -encodeAny :: - (BEncode tid, BEncode a) => - tid -> BKey -> a -> (BDict -> BDict) -> BValue -encodeAny tid key val aux = toDict $ - aux $ key .=! val - .: "t" .=! tid - .: "y" .=! key - .: endDict - - -showPacket :: ([L8.ByteString] -> [L8.ByteString]) -> SockAddr -> L8.ByteString -> ByteString -> String -showPacket f addr flow bs = L8.unpack $ L8.unlines es - where - es = map (L8.append prefix) (f $ L8.lines pp) - - prefix = L8.pack (either show show $ either4or6 addr) <> flow - - pp = either L8.pack showBEncode $ BE.decode bs - --- Add detailed printouts for every packet. -addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString -addVerbosity tr = - tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do - forM_ m $ mapM_ $ \(msg,addr) -> do - dput XBitTorrent (showPacket id addr " --> " msg) - kont m - , sendMessage = \addr msg -> do - dput XBitTorrent (showPacket id addr " <-- " msg) - sendMessage tr addr msg - } - - -showParseError :: ByteString -> SockAddr -> String -> String -showParseError bs addr err = showPacket (L8.pack err :) addr " --> " bs - -parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo) -parsePacket bs addr = left (showParseError bs addr) $ do - pkt <- BE.decode bs - -- TODO: Error packets do not include a valid msgOrigin. - -- The BE.decode method is using 'zeroID' as a placeholder. - ni <- nodeInfo (msgOrigin pkt) addr - return (pkt, ni) - -encodePacket :: Message BValue -> NodeInfo -> (ByteString, SockAddr) -encodePacket msg ni = ( toStrict $ BE.encode msg - , nodeAddr ni ) - -classify :: Message BValue -> MessageClass String Method TransactionId NodeInfo (Message BValue) -classify (Q { msgID = tid, qryMethod = meth }) = IsQuery meth tid -classify (R { msgID = tid }) = IsResponse tid - -encodeResponsePayload :: BEncode a => TransactionId -> NodeInfo -> NodeInfo -> a -> Message BValue -encodeResponsePayload tid self dest b = R (nodeId self) tid (Right $ BE.toBEncode b) (Just $ nodeAddr dest) - -encodeQueryPayload :: BEncode a => - Method -> Bool -> TransactionId -> NodeInfo -> NodeInfo -> a -> Message BValue -encodeQueryPayload meth isReadonly tid self dest b = Q (nodeId self) tid (BE.toBEncode b) meth isReadonly - -errorPayload :: TransactionId -> NodeInfo -> NodeInfo -> Error -> Message a -errorPayload tid self dest e = R (nodeId self) tid (Left e) (Just $ nodeAddr dest) - -decodePayload :: BEncode a => Message BValue -> Either String a -decodePayload msg = BE.fromBEncode $ qryPayload msg - -type Handler = MethodHandler String TransactionId NodeInfo (Message BValue) - -handler :: ( BEncode a - , BEncode b - ) => - (NodeInfo -> a -> IO b) -> Maybe Handler -handler f = Just $ MethodHandler decodePayload encodeResponsePayload f - - -handlerE :: ( BEncode a - , BEncode b - ) => - (NodeInfo -> a -> IO (Either Error b)) -> Maybe Handler -handlerE f = Just $ MethodHandler decodePayload enc f - where - enc tid self dest (Left e) = errorPayload tid self dest e - enc tid self dest (Right b) = encodeResponsePayload tid self dest b - -type AnnounceSet = Set (InfoHash, PortNumber) - -data SwarmsDatabase = SwarmsDatabase - { contactInfo :: !( TVar PeerStore ) -- ^ Published by other nodes. - , sessionTokens :: !( TVar SessionTokens ) -- ^ Query session IDs. - , announceInfo :: !( TVar AnnounceSet ) -- ^ To publish by this node. - } - -newSwarmsDatabase :: IO SwarmsDatabase -newSwarmsDatabase = do - toks <- nullSessionTokens - atomically - $ SwarmsDatabase <$> newTVar def - <*> newTVar toks - <*> newTVar def - -data Routing = Routing - { tentativeId :: NodeInfo - , committee4 :: TriadCommittee NodeId SockAddr - , committee6 :: TriadCommittee NodeId SockAddr - , refresher4 :: BucketRefresher NodeId NodeInfo - , refresher6 :: BucketRefresher NodeId NodeInfo - } - -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 - -traced :: Show tid => TableMethods t tid -> TableMethods t tid -traced (TableMethods ins del lkup) - = TableMethods (\tid mvar t -> trace ("insert "++show tid) $ ins tid mvar t) - (\tid t -> trace ("del "++show tid) $ del tid t) - (\tid t -> trace ("lookup "++show tid) $ lkup tid t) - - -type MainlineClient = Client String Method TransactionId NodeInfo (Message BValue) - --- | Like 'nodeInfo' but falls back to 'iNADDR_ANY' for nodeIP' and 'nodePort'. -mkNodeInfo :: NodeId -> SockAddr -> NodeInfo -mkNodeInfo nid addr = NodeInfo - { nodeId = nid - , nodeIP = fromMaybe (toEnum 0) $ fromSockAddr addr - , nodePort = fromMaybe 0 $ sockAddrPort addr - } - -newClient :: SwarmsDatabase -> SockAddr - -> IO ( MainlineClient - , Routing - , [NodeInfo] -> [NodeInfo] -> IO () - , [NodeInfo] -> [NodeInfo] -> IO () - ) -newClient swarms addr = do - udp <- udpTransport addr - nid <- NodeId <$> getRandomBytes 20 - let tentative_info = mkNodeInfo nid addr - tentative_info6 <- - maybe tentative_info - (\ip6 -> tentative_info { nodeId = fromMaybe (nodeId tentative_info) - $ bep42 (toSockAddr ip6) (nodeId tentative_info) - , nodeIP = IPv6 ip6 - }) - <$> global6 - addr4 <- atomically $ newTChan - addr6 <- atomically $ newTChan - mkrouting <- atomically $ do - -- We defer initializing the refreshSearch and refreshPing until we - -- have a client to send queries with. - let nullPing = const $ return False - nullSearch = mainlineSearch $ Left $ \_ _ -> return Nothing - tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info R.defaultBucketCount - refresher4 <- newBucketRefresher tbl4 nullSearch nullPing - tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount - refresher6 <- newBucketRefresher tbl6 nullSearch nullPing - let updateIPVote tblvar addrvar a = do - bkts <- readTVar tblvar - case bep42 a (nodeId $ R.thisNode bkts) of - Just nid -> do - let tbl = R.nullTable (comparing nodeId) - (\s -> hashWithSalt s . nodeId) - (mkNodeInfo nid a) - (R.defaultBucketCount) - writeTVar tblvar tbl - writeTChan addrvar (a,map fst $ concat $ R.toList bkts) - Nothing -> return () - committee4 <- newTriadCommittee $ updateIPVote tbl4 addr4 - committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6 - return $ \client -> - -- Now we have a client, so tell the BucketRefresher how to search and ping. - let updIO r = updateRefresherIO (nodeSearch client) (ping client) r - in Routing tentative_info committee4 committee6 (updIO refresher4) (updIO refresher6) - map_var <- atomically $ newTVar (0, mempty) - - let routing = mkrouting outgoingClient - - net = onInbound (updateRouting outgoingClient routing) - $ layerTransport parsePacket encodePacket - $ udp - - -- Paranoid: It's safe to define /net/ and /client/ to be mutually - -- recursive since 'updateRouting' does not invoke 'awaitMessage' which - -- which was modified by 'onInbound'. However, I'm going to avoid the - -- mutual reference just to be safe. - outgoingClient = client { clientNet = net { awaitMessage = ($ Nothing) } } - - dispatch = DispatchMethods - { classifyInbound = classify -- :: x -> MessageClass err meth tid addr x - , lookupHandler = handlers -- :: meth -> Maybe (MethodHandler err tid addr x) - , tableMethods = mapT -- :: TransactionMethods tbl tid x - } - - handlers :: Method -> Maybe Handler - handlers ( Method "ping" ) = handler pingH - handlers ( Method "find_node" ) = handler $ findNodeH routing - handlers ( Method "get_peers" ) = handler $ getPeersH routing swarms - handlers ( Method "announce_peer" ) = handlerE $ announceH swarms - handlers ( Method meth ) = Just $ defaultHandler meth - - mapT = transactionMethods mapMethods gen - - gen :: Word16 -> (TransactionId, Word16) - gen cnt = (TransactionId $ S.encode cnt, cnt+1) - - ignoreParseError :: String -> IO () - ignoreParseError _ = return () - - client = Client - { clientNet = addHandler ignoreParseError (handleMessage client) net - , clientDispatcher = dispatch - , clientErrorReporter = ignoreErrors -- printErrors stderr - , clientPending = map_var - , clientAddress = \maddr -> atomically $ do - let var = case flip prefer4or6 Nothing <$> maddr of - Just Want_IP6 -> routing6 routing - _ -> routing4 routing - R.thisNode <$> readTVar var - , clientResponseId = return - } - - -- TODO: Provide some means of shutting down these five auxillary threads: - - fork $ fix $ \again -> do - myThreadId >>= flip labelThread "addr4" - (addr, ns) <- atomically $ readTChan addr4 - dput XBitTorrent $ "External IPv4: "++show (addr, length ns) - forM_ ns $ \n -> do - dput XBitTorrent $ "Change IP, ping: "++show n - ping outgoingClient n - -- TODO: trigger bootstrap ipv4 - again - fork $ fix $ \again -> do - myThreadId >>= flip labelThread "addr6" - (addr,ns) <- atomically $ readTChan addr6 - dput XBitTorrent $ "External IPv6: "++show (addr, length ns) - forM_ ns $ \n -> do - dput XBitTorrent $ "Change IP, ping: "++show n - ping outgoingClient n - -- TODO: trigger bootstrap ipv6 - again - - - refresh_thread4 <- forkPollForRefresh $ refresher4 routing - refresh_thread6 <- forkPollForRefresh $ refresher6 routing - - forkAnnouncedInfohashesGC (contactInfo swarms) - - return (client, routing, bootstrap (refresher4 routing), bootstrap (refresher6 routing)) - --- Note that you should call .put() every hour for content that you want to --- keep alive, since nodes may discard data nodes older than 2 hours. (source: --- https://www.npmjs.com/package/bittorrent-dht) --- --- This function will discard records between 3 and 6 hours old. -forkAnnouncedInfohashesGC :: TVar PeerStore -> IO ThreadId -forkAnnouncedInfohashesGC vpeers = fork $ do - myThreadId >>= flip labelThread "gc:bt-peers" - fix $ \loop -> do - cutoff <- getPOSIXTime - threadDelay 10800000000 -- 3 hours - atomically $ modifyTVar' vpeers $ deleteOlderThan cutoff - loop - --- | Modifies a purely random 'NodeId' to one that is related to a given --- routable address in accordance with BEP 42. --- --- Test vectors from the spec: --- --- IP rand example node ID --- ============ ===== ========================================== --- 124.31.75.21 1 5fbfbf f10c5d6a4ec8a88e4c6ab4c28b95eee4 01 --- 21.75.31.124 86 5a3ce9 c14e7a08645677bbd1cfe7d8f956d532 56 --- 65.23.51.170 22 a5d432 20bc8f112a3d426c84764f8c2a1150e6 16 --- 84.124.73.14 65 1b0321 dd1bb1fe518101ceef99462b947a01ff 41 --- 43.213.53.83 90 e56f6c bf5b7c4be0237986d5243b87aa6d5130 5a -bep42 :: SockAddr -> NodeId -> Maybe NodeId -bep42 addr0 (NodeId r) - | let addr = either id id $ either4or6 addr0 -- unmap 4mapped SockAddrs - , Just ip <- fmap S.encode (fromSockAddr addr :: Maybe IPv4) - <|> fmap S.encode (fromSockAddr addr :: Maybe IPv6) - = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0) - | otherwise - = Nothing - where - ip4mask = "\x03\x0f\x3f\xff" :: ByteString - ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString - nbhood_select = B.last r .&. 7 - retr n = pure $ B.drop (B.length r - n) r - crc = S.encode . crc32c . B.pack - applyMask ip = case B.zipWith (.&.) msk ip of - (b:bs) -> (b .|. shiftL nbhood_select 5) : bs - bs -> bs - where msk | B.length ip == 4 = ip4mask - | otherwise = ip6mask - - - -defaultHandler :: ByteString -> Handler -defaultHandler meth = MethodHandler decodePayload errorPayload returnError - where - returnError :: NodeInfo -> BValue -> IO Error - returnError _ _ = return $ Error MethodUnknown ("Unknown method " <> meth) - -mainlineKademlia :: MainlineClient - -> TriadCommittee NodeId SockAddr - -> BucketRefresher NodeId NodeInfo - -> Kademlia NodeId NodeInfo -mainlineKademlia client committee refresher - = Kademlia quietInsertions - mainlineSpace - (vanillaIO (refreshBuckets refresher) $ ping client) - { tblTransition = \tr -> do - io1 <- transitionCommittee committee tr - io2 <- touchBucket refresher tr - return $ do - io1 >> io2 - {- noisy (timestamp updates are currently reported as transitions to Accepted) - dput XBitTorrent $ unwords - [ show (transitionedTo tr) - , show (transitioningNode tr) - ] -} - } - - -mainlineSpace :: R.KademliaSpace NodeId NodeInfo -mainlineSpace = R.KademliaSpace - { R.kademliaLocation = nodeId - , R.kademliaTestBit = testIdBit - , R.kademliaXor = xor - , R.kademliaSample = genBucketSample' - } - -transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ()) -transitionCommittee committee (RoutingTransition ni Stranger) = do - delVote committee (nodeId ni) - return $ do - dput XBitTorrent $ "delVote "++show (nodeId ni) -transitionCommittee committee _ = return $ return () - -updateRouting :: MainlineClient -> Routing -> NodeInfo -> Message BValue -> IO () -updateRouting client routing naddr msg = do - case prefer4or6 naddr Nothing of - Want_IP4 -> go (committee4 routing) (refresher4 routing) - Want_IP6 -> go (committee6 routing) (refresher6 routing) - where - go committee refresher = do - self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher) - when (nodeIP self /= nodeIP naddr) $ do - case msg of - R { rspReflectedIP = Just sockaddr } - -> do - -- dput XBitTorrent $ "External: "++show (nodeId naddr,sockaddr) - atomically $ addVote committee (nodeId naddr) sockaddr - _ -> return () - insertNode (mainlineKademlia client committee refresher) naddr - -data Ping = Ping deriving Show - --- Pong is the same as Ping. -type Pong = Ping -pattern Pong = Ping - -instance BEncode Ping where - toBEncode Ping = toDict endDict - fromBEncode _ = pure Ping - -wantList :: WantIP -> [ByteString] -wantList Want_IP4 = ["ip4"] -wantList Want_IP6 = ["ip6"] -wantList Want_Both = ["ip4","ip6"] - -instance BEncode WantIP where - toBEncode w = toBEncode $ wantList w - fromBEncode bval = do - wants <- fromBEncode bval - let _ = wants :: [ByteString] - case (elem "ip4" wants, elem "ip6" wants) of - (True,True) -> Right Want_Both - (True,False) -> Right Want_IP4 - (False,True) -> Right Want_IP6 - _ -> Left "Unrecognized IP type." - -data FindNode = FindNode NodeId (Maybe WantIP) - -instance BEncode FindNode where - toBEncode (FindNode nid iptyp) = toDict $ target_key .=! nid - .: want_key .=? iptyp - .: endDict - fromBEncode = fromDict $ FindNode <$>! target_key - <*>? want_key - -data NodeFound = NodeFound - { nodes4 :: [NodeInfo] - , nodes6 :: [NodeInfo] - } - -instance BEncode NodeFound where - toBEncode (NodeFound ns ns6) = toDict $ - nodes_key .=? - (if Prelude.null ns then Nothing - else Just (S.runPut (mapM_ putNodeInfo4 ns))) - .: nodes6_key .=? - (if Prelude.null ns6 then Nothing - else Just (S.runPut (mapM_ putNodeInfo6 ns6))) - .: endDict - - fromBEncode bval = NodeFound <$> ns4 <*> ns6 - where - opt ns = fromMaybe [] <$> optional ns - ns4 = opt $ fromDict (binary getNodeInfo4 nodes_key) bval - ns6 = opt $ fromDict (binary getNodeInfo6 nodes6_key) bval - -binary :: S.Get a -> BKey -> BE.Get [a] -binary get k = field (req k) >>= either (fail . format) return . - S.runGet (many get) - where - format str = "fail to deserialize " ++ show k ++ " field: " ++ str - -pingH :: NodeInfo -> Ping -> IO Pong -pingH _ Ping = return Pong - -prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP -prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp - -findNodeH :: Routing -> NodeInfo -> FindNode -> IO NodeFound -findNodeH routing addr (FindNode node iptyp) = do - let preferred = prefer4or6 addr iptyp - - (append4,append6) <- atomically $ do - ni4 <- R.thisNode <$> readTVar (routing4 routing) - ni6 <- R.thisNode <$> readTVar (routing6 routing) - return $ case ipFamily (nodeIP addr) of - Want_IP4 -> (id, (++ [ni6])) - Want_IP6 -> ((++ [ni4]), id) - ks <- bool (return []) (go append4 $ routing4 routing) (preferred /= Want_IP6) - ks6 <- bool (return []) (go append6 $ routing6 routing) (preferred /= Want_IP4) - return $ NodeFound ks ks6 - where - go f var = f . R.kclosest mainlineSpace k node <$> atomically (readTVar var) - - k = R.defaultK - - -data GetPeers = GetPeers InfoHash (Maybe WantIP) - -instance BEncode GetPeers where - toBEncode (GetPeers ih iptyp) - = toDict $ info_hash_key .=! ih - .: want_key .=? iptyp - .: endDict - fromBEncode = fromDict $ GetPeers <$>! info_hash_key <*>? want_key - - -data GotPeers = GotPeers - { -- | If the queried node has no peers for the infohash, returned - -- the K nodes in the queried nodes routing table closest to the - -- infohash supplied in the query. - peers :: [PeerAddr] - - , nodes :: NodeFound - - -- | The token value is a required argument for a future - -- announce_peer query. - , grantedToken :: Token - } -- deriving (Show, Eq, Typeable) - -nodeIsIPv6 :: NodeInfo -> Bool -nodeIsIPv6 (NodeInfo _ (IPv6 _) _) = True -nodeIsIPv6 _ = False - -instance BEncode GotPeers where - toBEncode GotPeers { nodes = NodeFound ns4 ns6, ..} = toDict $ - nodes_key .=? (if null ns4 then Nothing - else Just $ S.runPut (mapM_ putNodeInfo4 ns4)) - .: nodes6_key .=? (if null ns6 then Nothing - else Just $ S.runPut (mapM_ putNodeInfo4 ns6)) - .: token_key .=! grantedToken - .: peers_key .=! map S.encode peers - .: endDict - - fromBEncode = fromDict $ do - ns4 <- fromMaybe [] <$> optional (binary getNodeInfo4 nodes_key) -- "nodes" - ns6 <- fromMaybe [] <$> optional (binary getNodeInfo6 nodes6_key) -- "nodes6" - -- TODO: BEP 42... - -- - -- Once enforced, responses to get_peers requests whose node ID does not - -- match its external IP should be considered to not contain a token and - -- thus not be eligible as storage target. Implementations should take - -- care that they find the closest set of nodes which return a token and - -- whose IDs matches their IPs before sending a store request to those - -- nodes. - -- - -- Sounds like something to take care of at peer-search time, so I'll - -- ignore it for now. - tok <- field (req token_key) -- "token" - ps <- fromMaybe [] <$> optional (field (req peers_key) >>= decodePeers) -- "values" - pure $ GotPeers ps (NodeFound ns4 ns6) tok - where - decodePeers = either fail pure . mapM S.decode - -getPeersH :: Routing -> SwarmsDatabase -> NodeInfo -> GetPeers -> IO GotPeers -getPeersH routing (SwarmsDatabase peers toks _) naddr (GetPeers ih iptyp) = do - ps <- do - tm <- getTimestamp - atomically $ do - (ps,store') <- Peers.freshPeers ih tm <$> readTVar peers - writeTVar peers store' - return ps - -- Filter peer results to only a single address family, IPv4 or IPv6, as - -- per BEP 32. - let notboth = iptyp >>= \case Want_Both -> Nothing - specific -> Just specific - selected = prefer4or6 naddr notboth - ps' = filter ( (== selected) . ipFamily . peerHost ) ps - tok <- grantToken toks naddr - ns <- findNodeH routing naddr (FindNode (coerce ih) iptyp) - return $ GotPeers ps' ns tok - --- | Announce that the peer, controlling the querying node, is --- downloading a torrent on a port. -data Announce = Announce - { -- | If set, the 'port' field should be ignored and the source - -- port of the UDP packet should be used as the peer's port - -- instead. This is useful for peers behind a NAT that may not - -- know their external port, and supporting uTP, they accept - -- incoming connections on the same port as the DHT port. - impliedPort :: Bool - - -- | infohash of the torrent; - , topic :: InfoHash - - -- | some clients announce the friendly name of the torrent here. - , announcedName :: Maybe ByteString - - -- | the port /this/ peer is listening; - , port :: PortNumber - - -- TODO: optional boolean "seed" key - - -- | received in response to a previous get_peers query. - , sessionToken :: Token - - } deriving (Show, Eq, Typeable) - -mkAnnounce :: PortNumber -> InfoHash -> Token -> Announce -mkAnnounce portnum info token = Announce - { topic = info - , port = portnum - , sessionToken = token - , announcedName = Nothing - , impliedPort = False - } - - -instance BEncode Announce where - toBEncode Announce {..} = toDict $ - implied_port_key .=? flagField impliedPort - .: info_hash_key .=! topic - .: name_key .=? announcedName - .: port_key .=! port - .: token_key .=! sessionToken - .: endDict - where - flagField flag = if flag then Just (1 :: Int) else Nothing - - fromBEncode = fromDict $ do - Announce <$> (boolField <$> optional (field (req implied_port_key))) - <*>! info_hash_key - <*>? name_key - <*>! port_key - <*>! token_key - where - boolField = maybe False (/= (0 :: Int)) - - - --- | The queried node must verify that the token was previously sent --- to the same IP address as the querying node. Then the queried node --- should store the IP address of the querying node and the supplied --- port number under the infohash in its store of peer contact --- information. -data Announced = Announced - deriving (Show, Eq, Typeable) - -instance BEncode Announced where - toBEncode _ = toBEncode Ping - fromBEncode _ = pure Announced - -announceH :: SwarmsDatabase -> NodeInfo -> Announce -> IO (Either Error Announced) -announceH (SwarmsDatabase peers toks _) naddr announcement = do - checkToken toks naddr (sessionToken announcement) - >>= bool (Left <$> return (Error ProtocolError "invalid parameter: token")) - (Right <$> go) - where - go = atomically $ do - modifyTVar' peers - $ insertPeer (topic announcement) (announcedName announcement) - $ PeerAddr - { peerId = Nothing - -- Avoid storing IPv4-mapped addresses. - , peerHost = case nodeIP naddr of - IPv6 ip6 | Just ip4 <- un4map ip6 -> IPv4 ip4 - a -> a - , peerPort = if impliedPort announcement - then nodePort naddr - else port announcement - } - return Announced - -isReadonlyClient :: MainlineClient -> Bool -isReadonlyClient client = False -- TODO - -mainlineSend :: ( BEncode a - , BEncode a2 - ) => Method - -> (a2 -> b) - -> (t -> a) - -> MainlineClient - -> t - -> NodeInfo - -> IO (Maybe b) -mainlineSend meth unwrap msg client nid addr = do - reply <- sendQuery client (mainlineSerializeer meth unwrap client) (msg nid) addr - -- sendQuery will return (Just (Left _)) on a parse error. We're going to - -- blow it away with the join-either sequence. - -- TODO: Do something with parse errors. - return $ join $ either (const Nothing) Just <$> reply - -mainlineAsync :: (BEncode a1, BEncode a2) => - Method - -> (a2 -> a3) - -> (t -> a1) - -> Client String Method TransactionId NodeInfo (Message BValue) - -> t - -> NodeInfo - -> (Maybe a3 -> IO ()) - -> IO () -mainlineAsync meth unwrap msg client nid addr onresult = do - asyncQuery client (mainlineSerializeer meth unwrap client) (msg nid) addr - $ \reply -> - -- sendQuery will return (Just (Left _)) on a parse error. We're going to - -- blow it away with the join-either sequence. - -- TODO: Do something with parse errors. - onresult $ join $ either (const Nothing) Just <$> reply - -mainlineSerializeer :: (BEncode a2, BEncode a1) => - Method - -> (a2 -> b) - -> MainlineClient - -> MethodSerializer - TransactionId NodeInfo (Message BValue) Method a1 (Either Error b) -mainlineSerializeer meth unwrap client = MethodSerializer - { methodTimeout = \_ ni -> return (ni, 5000000) - , method = meth - , wrapQuery = encodeQueryPayload meth (isReadonlyClient client) - , unwrapResponse = (>>= either (Left . Error GenericError . C8.pack) - (Right . unwrap) - . BE.fromBEncode) - . rspPayload - } - -ping :: MainlineClient -> NodeInfo -> IO Bool -ping client addr = - fromMaybe False - <$> mainlineSend (Method "ping") (\Pong -> True) (const Ping) client () addr - --- searchQuery :: ni -> IO (Maybe [ni], [r], tok)) -getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) -getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) - -asyncGetNodes :: Client String Method TransactionId NodeInfo (Message BValue) - -> NodeId - -> NodeInfo - -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ()) - -> IO () -asyncGetNodes = mainlineAsync (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) - -unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ()) -unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ()) - -getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token)) -getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce - -asyncGetPeers :: Client String Method TransactionId NodeInfo (Message BValue) - -> NodeId - -> NodeInfo - -> (Maybe ([NodeInfo], [PeerAddr], Maybe Token) -> IO ()) - -> IO () -asyncGetPeers = mainlineAsync (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce - -unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token) -unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok) - -mainlineSearch :: Either (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], Maybe tok))) - (NodeId -> NodeInfo -> (Maybe ([NodeInfo], [r], Maybe tok) -> IO ()) -> IO ()) - -> Search NodeId (IP, PortNumber) tok NodeInfo r -mainlineSearch qry = Search - { searchSpace = mainlineSpace - , searchNodeAddress = nodeIP &&& nodePort - , searchQuery = qry - , searchAlpha = 8 - , searchK = 16 - } - -nodeSearch :: MainlineClient -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo -nodeSearch client = mainlineSearch (Right $ asyncGetNodes client) - -peerSearch :: MainlineClient -> Search NodeId (IP, PortNumber) Token NodeInfo PeerAddr -peerSearch client = mainlineSearch (Right $ asyncGetPeers client) - --- | List of bootstrap nodes maintained by different bittorrent --- software authors. -bootstrapNodes :: WantIP -> IO [NodeInfo] -bootstrapNodes want = unsafeInterleaveIO $ do - let wellknowns = - [ "router.bittorrent.com:6881" -- by BitTorrent Inc. - - -- doesn't work at the moment (use git blame) of commit - , "dht.transmissionbt.com:6881" -- by Transmission project - - , "router.utorrent.com:6881" - ] - nss <- forM wellknowns $ \hostAndPort -> do - e <- resolve want hostAndPort - case e of - Left _ -> return [] - Right sockaddr -> either (const $ return []) - (return . (: [])) - $ nodeInfo zeroID sockaddr - return $ concat nss - --- | Resolve either a numeric network address or a hostname to a --- numeric IP address of the node. -resolve :: WantIP -> String -> IO (Either IOError SockAddr) -resolve want hostAndPort = do - let hints = defaultHints { addrSocketType = Datagram - , addrFamily = case want of - Want_IP4 -> AF_INET - _ -> AF_INET6 - } - (rport,rhost) = span (/= ':') $ reverse hostAndPort - (host,port) = case rhost of - [] -> (hostAndPort, Nothing) - (_:hs) -> (reverse hs, Just (reverse rport)) - tryIOError $ do - -- getAddrInfo throws exception on empty list, so this - -- pattern matching never fails. - info : _ <- getAddrInfo (Just hints) (Just host) port - return $ addrAddress info - - -announce :: MainlineClient -> Announce -> NodeInfo -> IO (Maybe Announced) -announce client msg addr = do - mainlineSend (Method "announce_peer") id (\() -> msg) client () addr diff --git a/src/Network/BitTorrent/MainlineDHT/Symbols.hs b/src/Network/BitTorrent/MainlineDHT/Symbols.hs deleted file mode 100644 index 05a64014..00000000 --- a/src/Network/BitTorrent/MainlineDHT/Symbols.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Network.BitTorrent.MainlineDHT.Symbols where - -import Data.BEncode.BDict - -peer_ip_key = "ip" :: BKey -peer_id_key = "peer id" :: BKey -peer_port_key = "port" :: BKey -msg_type_key = "msg_type" :: BKey -piece_key = "piece" :: BKey -total_size_key = "total_size" :: BKey -node_id_key = "id" :: BKey -read_only_key = "ro" :: BKey -want_key = "want" :: BKey -target_key = "target" :: BKey -nodes_key = "nodes" :: BKey -nodes6_key = "nodes6" :: BKey -info_hash_key = "info_hash" :: BKey -peers_key = "values" :: BKey -token_key = "token" :: BKey -name_key = "name" :: BKey -port_key = "port" :: BKey -implied_port_key = "implied_port" :: BKey - diff --git a/src/Network/Kademlia.hs b/src/Network/Kademlia.hs deleted file mode 100644 index e61afe9b..00000000 --- a/src/Network/Kademlia.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, PartialTypeSignatures, FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DeriveFunctor, DeriveTraversable #-} --- {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -module Network.Kademlia where - -import Data.Maybe -import Data.Time.Clock.POSIX -import Network.Kademlia.Routing as R -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -import GHC.Conc (labelThread) -#endif -import Control.Concurrent.STM -import Control.Monad -import Data.Time.Clock.POSIX (POSIXTime) - --- | The status of a given node with respect to a given routint table. -data RoutingStatus - = Stranger -- ^ The node is unknown to the Kademlia routing table. - | Applicant -- ^ The node may be inserted pending a ping timeout. - | Accepted -- ^ The node has a slot in one of the Kademlia buckets. - deriving (Eq,Ord,Enum,Show,Read) - --- | A change occured in the kademlia routing table. -data RoutingTransition ni = RoutingTransition - { transitioningNode :: ni - , transitionedTo :: !RoutingStatus - } - deriving (Eq,Ord,Show,Read) - -data InsertionReporter ni = InsertionReporter - { -- | Called on every inbound packet. Accepts: - -- - -- * Origin of packet. - -- - -- * List of nodes to be pinged as a result. - reportArrival :: POSIXTime - -> ni - -> [ni] - -> IO () - -- | Called on every ping probe. Accepts: - -- - -- * Who was pinged. - -- - -- * True Bool value if they ponged. - , reportPingResult :: POSIXTime - -> ni - -> Bool - -> IO () - } - -quietInsertions :: InsertionReporter ni -quietInsertions = InsertionReporter - { reportArrival = \_ _ _ -> return () - , reportPingResult = \_ _ _ -> return () - } - -contramapIR :: (t -> ni) -> InsertionReporter ni -> InsertionReporter t -contramapIR f ir = InsertionReporter - { reportArrival = \tm ni nis -> reportArrival ir tm (f ni) (map f nis) - , reportPingResult = \tm ni b -> reportPingResult ir tm (f ni) b - } - --- | All the IO operations necessary to maintain a Kademlia routing table. -data TableStateIO ni = TableStateIO - { -- | Write the routing table. Typically 'writeTVar'. - tblWrite :: R.BucketList ni -> STM () - - -- | Read the routing table. Typically 'readTVar'. - , tblRead :: STM (R.BucketList ni) - - -- | Issue a ping to a remote node and report 'True' if the node - -- responded within an acceptable time and 'False' otherwise. - , tblPing :: ni -> IO Bool - - -- | Convenience method provided to assist in maintaining state - -- consistent with the routing table. It will be invoked in the same - -- transaction that 'tblRead'\/'tblWrite' occured but only when there was - -- an interesting change. The returned IO action will be triggered soon - -- afterward. - -- - -- It is not necessary to do anything interesting here. The following - -- trivial implementation is fine: - -- - -- > tblTransition = const $ return $ return () - , tblTransition :: RoutingTransition ni -> STM (IO ()) - } - -vanillaIO :: TVar (BucketList ni) -> (ni -> IO Bool) -> TableStateIO ni -vanillaIO var ping = TableStateIO - { tblRead = readTVar var - , tblWrite = writeTVar var - , tblPing = ping - , tblTransition = const $ return $ return () - } - --- | Everything necessary to maintain a routing table of /ni/ (node --- information) entries. -data Kademlia nid ni = Kademlia { kademInsertionReporter :: InsertionReporter ni - , kademSpace :: KademliaSpace nid ni - , kademIO :: TableStateIO ni - } - - --- Helper to 'insertNode'. --- --- Adapt return value from 'updateForPingResult' into a --- more easily grokked list of transitions. -transition :: (ni,Maybe (t,ni)) -> [RoutingTransition ni] -transition (x,m) = - -- Just _ <- m = Node transition: Accepted --> Stranger - -- Nothing <- m = Node transition: Applicant --> Stranger - RoutingTransition x Stranger - : maybeToList (accepted <$> m) - --- Helper to 'transition' --- --- Node transition: Applicant --> Accepted -accepted :: (t,ni) -> RoutingTransition ni -accepted (_,y) = RoutingTransition y Accepted - - -insertNode :: Kademlia nid ni -> ni -> IO () -insertNode (Kademlia reporter space io) node = do - - tm <- getPOSIXTime - - (ps,reaction) <- atomically $ do - tbl <- tblRead io - let (inserted, ps,t') = R.updateForInbound space tm node tbl - tblWrite io t' - reaction <- case ps of - _ | inserted -> -- Node transition: Stranger --> Accepted - tblTransition io $ RoutingTransition node Accepted - (_:_) -> -- Node transition: Stranger --> Applicant - tblTransition io $ RoutingTransition node Applicant - _ -> return $ return () - return (ps, reaction) - - reportArrival reporter tm node ps - reaction - - _ <- fork $ do - myThreadId >>= flip labelThread "pingResults" - forM_ ps $ \n -> do - b <- tblPing io n - reportPingResult reporter tm n b -- XXX: tm is timestamp of original triggering packet, not result - join $ atomically $ do - tbl <- tblRead io - let (replacements, t') = R.updateForPingResult space n b tbl - tblWrite io t' - ios <- sequence $ concatMap - (map (tblTransition io) . transition) - replacements - return $ sequence_ ios - - return () - diff --git a/src/Network/Kademlia/Bootstrap.hs b/src/Network/Kademlia/Bootstrap.hs deleted file mode 100644 index 1324ae77..00000000 --- a/src/Network/Kademlia/Bootstrap.hs +++ /dev/null @@ -1,437 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Network.Kademlia.Bootstrap where - -import Data.Function -import Data.Maybe -import qualified Data.Set as Set -import Data.Time.Clock.POSIX (getPOSIXTime) -import Network.Kademlia.Routing as R -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -import GHC.Conc (labelThread) -#endif -import Control.Concurrent.STM -import Control.Monad -import Data.Hashable -import Data.Time.Clock.POSIX (POSIXTime) -import Data.Ord -import System.Entropy -import System.Timeout -import DPut -import DebugTag - -import qualified Data.Wrapper.PSQInt as Int - ;import Data.Wrapper.PSQInt (pattern (:->)) -import Network.Address (bucketRange) -import Network.Kademlia.Search -import Control.Concurrent.Tasks -import Network.Kademlia - -type SensibleNodeId nid ni = - ( Show nid - , Ord nid - , Ord ni - , Hashable nid - , Hashable ni ) - -data BucketRefresher nid ni = forall tok addr. Ord addr => BucketRefresher - { -- | A staleness threshold (if a bucket goes this long without being - -- touched, a refresh will be triggered). - refreshInterval :: POSIXTime - -- | A TVar with the time-to-refresh schedule for each bucket. - -- - -- To "touch" a bucket and prevent it from being refreshed, reschedule - -- its refresh time to some time into the future by modifying its - -- priority in this priority search queue. - , refreshQueue :: TVar (Int.PSQ POSIXTime) - -- | This is the kademlia node search specification. - , refreshSearch :: Search nid addr tok ni ni - -- | The current kademlia routing table buckets. - , refreshBuckets :: TVar (R.BucketList ni) - -- | Action to ping a node. This is used only during initial bootstrap - -- to get some nodes in our table. A 'True' result is interpreted as a a - -- pong, where 'False' is a non-response. - , refreshPing :: ni -> IO Bool - , -- | Timestamp of last bucket event. - refreshLastTouch :: TVar POSIXTime - , -- | This variable indicates whether or not we are in bootstrapping mode. - bootstrapMode :: TVar Bool - , -- | When this countdown reaches 0, we exit bootstrap mode. It is decremented on - -- every finished refresh. - bootstrapCountdown :: TVar (Maybe Int) - } - -newBucketRefresher :: ( Ord addr, Hashable addr - , SensibleNodeId nid ni ) - => TVar (R.BucketList ni) - -> Search nid addr tok ni ni - -> (ni -> IO Bool) - -> STM (BucketRefresher nid ni) -newBucketRefresher bkts sch ping = do - let spc = searchSpace sch - nodeId = kademliaLocation spc - -- bkts <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) template_ni R.defaultBucketCount - sched <- newTVar Int.empty - lasttouch <- newTVar 0 -- Would use getPOSIXTime here, or minBound, but alas... - bootstrapVar <- newTVar True -- Start in bootstrapping mode. - bootstrapCnt <- newTVar Nothing - return BucketRefresher - { refreshInterval = 15 * 60 - , refreshQueue = sched - , refreshSearch = sch - , refreshBuckets = bkts - , refreshPing = ping - , refreshLastTouch = lasttouch - , bootstrapMode = bootstrapVar - , bootstrapCountdown = bootstrapCnt - } - --- | This was added to avoid the compile error "Record update for --- insufficiently polymorphic field" when trying to update the existentially --- quantified field 'refreshSearch'. -updateRefresherIO :: Ord addr - => Search nid addr tok ni ni - -> (ni -> IO Bool) - -> BucketRefresher nid ni -> BucketRefresher nid ni -updateRefresherIO sch ping BucketRefresher{..} = BucketRefresher - { refreshSearch = sch - , refreshPing = ping - , refreshInterval = refreshInterval - , refreshBuckets = refreshBuckets - , refreshQueue = refreshQueue - , refreshLastTouch = refreshLastTouch - , bootstrapMode = bootstrapMode - , bootstrapCountdown = bootstrapCountdown - } - --- | Fork a refresh loop. Kill the returned thread to terminate it. -forkPollForRefresh :: SensibleNodeId nid ni => BucketRefresher nid ni -> IO ThreadId -forkPollForRefresh r@BucketRefresher{ refreshInterval - , refreshQueue - , refreshBuckets - , refreshSearch } = fork $ do - myThreadId >>= flip labelThread "pollForRefresh" - fix $ \again -> do - join $ atomically $ do - nextup <- Int.findMin <$> readTVar refreshQueue - maybe retry (return . go again) nextup - where - refresh :: Int -> IO Int - refresh n = do - -- dput XRefresh $ "Refresh time! "++ show n - refreshBucket r n - - go again ( bktnum :-> refresh_time ) = do - now <- getPOSIXTime - case fromEnum (refresh_time - now) of - x | x <= 0 -> do -- Refresh time! - -- Move it to the back of the refresh queue. - atomically $ do - interval <- effectiveRefreshInterval r bktnum - modifyTVar' refreshQueue - $ Int.insert bktnum (now + interval) - -- Now fork the refresh operation. - -- TODO: We should probably propogate the kill signal to this thread. - fork $ do myThreadId >>= flip labelThread ("refresh."++show bktnum) - _ <- refresh bktnum - return () - return () - picoseconds -> do - -- dput XRefresh $ show (picoseconds `div` 10^12) ++ " seconds until refresh " ++ show bktnum - threadDelay ( picoseconds `div` 10^6 ) - again - - --- | This is a helper to 'refreshBucket' which does some book keeping to decide --- whether or not a bucket is sufficiently refreshed or not. It will return --- false when we can terminate a node search. -checkBucketFull :: Ord ni => KademliaSpace nid ni -- ^ Obtain a node id from a node. - -> TVar (BucketList ni) -- ^ The current routing table. - -> TVar (Set.Set ni) -- ^ In-range nodes found so far. - -> TVar Bool -- ^ The result will also be written here. - -> Int -- ^ The bucket number of interest. - -> ni -- ^ A newly found node. - -> STM Bool -checkBucketFull space var resultCounter fin n found_node = do - let fullcount = R.defaultBucketSize - saveit True = writeTVar fin True >> return True - saveit _ = return False - tbl <- readTVar var - let counts = R.shape tbl - nid = kademliaLocation space found_node - -- Update the result set with every found node that is in the - -- bucket of interest. - when (n == R.bucketNumber space nid tbl) - $ modifyTVar' resultCounter (Set.insert found_node) - resultCount <- readTVar resultCounter - saveit $ case drop (n - 1) counts of - (cnt:_) | cnt < fullcount -> True -- bucket not full, keep going - _ | Set.size resultCount < fullcount -> True -- we haven't got many results, keep going - _ -> False -- okay, good enough, let's quit. - --- | Called from 'refreshBucket' with the current time when a refresh of the --- supplied bucket number finishes. -onFinishedRefresh :: BucketRefresher nid ni -> Int -> POSIXTime -> STM (IO ()) -onFinishedRefresh BucketRefresher { bootstrapCountdown - , bootstrapMode - , refreshQueue - , refreshBuckets } num now = do - bootstrapping <- readTVar bootstrapMode - if not bootstrapping then return $ return () -- dput XRefresh $ "Finished non-boostrapping refresh: "++show num - else do - tbl <- readTVar refreshBuckets - action <- - if num /= R.bktCount tbl - 1 - then do modifyTVar' bootstrapCountdown (fmap pred) - return $ return () -- dput XRefresh $ "BOOTSTRAP decrement" - else do - -- The last bucket finished. - cnt <- readTVar bootstrapCountdown - case cnt of - Nothing -> do - let fullsize = R.defaultBucketSize - notfull (n,len) | n==num = False - | len>=fullsize = False - | otherwise = True - unfull = case filter notfull $ zip [0..] (R.shape tbl) of - [] -> [(0,0)] -- Schedule at least 1 more refresh. - xs -> xs - forM_ unfull $ \(n,_) -> do - -- Schedule immediate refresh for unfull buckets (other than this one). - modifyTVar' refreshQueue $ Int.insert n (now - 1) - writeTVar bootstrapCountdown $! Just $! length unfull - return $ return () -- dput XRefresh $ "BOOTSTRAP scheduling: "++show unfull - Just n -> do writeTVar bootstrapCountdown $! Just $! pred n - return $ return () -- dput XRefresh "BOOTSTRAP decrement (last bucket)" - cnt <- readTVar bootstrapCountdown - if (cnt == Just 0) - then do - -- Boostrap finished! - writeTVar bootstrapMode False - writeTVar bootstrapCountdown Nothing - return $ do action ; dput XRefresh $ "BOOTSTRAP complete (" ++ show (R.shape tbl) ++ ")." - else return $ do action ; dput XRefresh $ "BOOTSTRAP progress " ++ show (num,R.shape tbl,cnt) - -refreshBucket :: (Show nid, Ord ni, Ord nid, Hashable nid, Hashable ni) => - BucketRefresher nid ni -> Int -> IO Int -refreshBucket r@BucketRefresher{ refreshSearch = sch - , refreshBuckets = var } - n = do - tbl <- atomically (readTVar var) - let count = bktCount tbl - nid = kademliaLocation (searchSpace sch) (thisNode tbl) - sample <- if n+1 >= count -- Is this the last bucket? - then return nid -- Yes? Search our own id. - else kademliaSample (searchSpace sch) -- No? Generate a random id. - getEntropy - nid - (bucketRange n (n + 1 < count)) - fin <- atomically $ newTVar False - resultCounter <- atomically $ newTVar Set.empty - - dput XRefresh $ "Start refresh " ++ show (n,sample) - - -- Set 15 minute timeout in order to avoid overlapping refreshes. - s <- search sch tbl sample $ if n+1 == R.defaultBucketCount - then const $ return True -- Never short-circuit the last bucket. - else checkBucketFull (searchSpace sch) var resultCounter fin n - _ <- timeout (15*60*1000000) $ do - atomically $ searchIsFinished s >>= check - atomically $ searchCancel s - dput XDHT $ "Finish refresh " ++ show (n,sample) - now <- getPOSIXTime - join $ atomically $ onFinishedRefresh r n now - rcount <- atomically $ do - c <- Set.size <$> readTVar resultCounter - b <- readTVar fin - return $ if b then 1 else c - return rcount - -refreshLastBucket :: SensibleNodeId nid ni => BucketRefresher nid ni -> IO () -refreshLastBucket r@BucketRefresher { refreshBuckets - , refreshQueue } = do - - now <- getPOSIXTime - atomically $ do - cnt <- bktCount <$> readTVar refreshBuckets - -- Schedule immediate refresh. - modifyTVar' refreshQueue $ Int.insert (cnt-1) (now - 1) - -restartBootstrap :: (Hashable ni, Hashable nid, Ord ni, Ord nid, Show nid) => - BucketRefresher nid ni -> STM (IO ()) -restartBootstrap r@BucketRefresher{ bootstrapMode, bootstrapCountdown } = do - unchanged <- readTVar bootstrapMode - writeTVar bootstrapMode True - writeTVar bootstrapCountdown Nothing - if not unchanged then return $ do - dput XRefresh "BOOTSTRAP entered bootstrap mode" - refreshLastBucket r - else return $ dput XRefresh "BOOTSTRAP already bootstrapping" - -bootstrap :: (Ord ni, Ord nid, Hashable nid, Hashable ni, Foldable t, Foldable t1, Show nid) => - BucketRefresher nid ni - -> t1 ni -- ^ Nodes to bootstrap from. - -> t ni -- ^ Fallback nodes; used only if the others are unresponsive. - -> IO () -bootstrap r@BucketRefresher { refreshSearch = sch - , refreshBuckets = var - , refreshPing = ping - , bootstrapMode } ns ns0 = do - gotPing <- atomically $ newTVar False - - -- First, ping the given nodes so that they are added to - -- our routing table. - withTaskGroup "bootstrap.resume" 20 $ \g -> do - forM_ ns $ \n -> do - let lbl = show $ kademliaLocation (searchSpace sch) n - forkTask g lbl $ do - b <- ping n - when b $ atomically $ writeTVar gotPing True - - -- We resort to the hardcoded fallback nodes only when we got no - -- responses. This is to lesson the burden on well-known boostrap - -- nodes. - fallback <- atomically (readTVar gotPing) >>= return . when . not - fallback $ withTaskGroup "bootstrap.ping" 20 $ \g -> do - forM_ ns0 $ \n -> do - forkTask g (show $ kademliaLocation (searchSpace sch) n) - (void $ ping n) - dput XDHT "Finished bootstrap pings." - -- Now search our own Id by entering bootstrap mode from non-bootstrap mode. - join $ atomically $ do - writeTVar bootstrapMode False - restartBootstrap r - -- - -- Hopefully 'forkPollForRefresh' was invoked and can take over - -- maintenance. - - -effectiveRefreshInterval :: BucketRefresher nid ni -> Int -> STM POSIXTime -effectiveRefreshInterval BucketRefresher{ refreshInterval - , refreshBuckets - , bootstrapMode } num = do - tbl <- readTVar refreshBuckets - bootstrapping <- readTVar bootstrapMode - case bootstrapping of - False -> return refreshInterval - True -> do - -- When bootstrapping, refresh interval for non-full buckets is only 15 seconds. - let fullcount = R.defaultBucketSize - count = fromMaybe fullcount $ listToMaybe $ drop (num - 1) $ R.shape tbl - if count == fullcount - then return refreshInterval - else return 15 -- seconds - - - --- | Reschedule a bucket's refresh-time. It should be called whenever a bucket --- changes. This will typically be invoked from 'tblTransition'. --- --- From BEP 05: --- --- > Each bucket should maintain a "last changed" property to indicate how --- > "fresh" the contents are. --- --- We will use a "time to next refresh" property instead and store it in --- a priority search queue. --- --- In detail using an expository (not actually implemented) type --- 'BucketTouchEvent'... --- --- >>> data BucketTouchEvent = RoutingStatus :--> RoutingStatus --- >>> bucketEvents = --- >>> [ Applicant :--> Stranger -- a node in a bucket is pinged and it responds, --- >>> --- >>> , Stranger :--> Accepted -- or a node is added to a bucket, --- >>> --- >>> , Accepted :--> Stranger -- or a node in a bucket is replaced --- >>> , Applicant :--> Accepted -- with another node, --- >>> ] --- --- the bucket's last changed property should be updated. Buckets that have not --- been changed in 15 minutes (see 'refreshInterval') should be "refreshed." --- This is done by picking a random ID in the range of the bucket and --- performing a find_nodes search on it. --- --- The only other possible BucketTouchEvents are as follows: --- --- >>> not_handled = --- >>> , Stranger :--> Applicant -- A ping is pending, it's result is covered: --- >>> -- (Applicant :--> Stranger) --- >>> -- (Applicant :--> Accepted) --- >>> , Accepted :--> Applicant -- Never happens --- >>> ] --- --- Because this BucketTouchEvent type is not actually implemented and we only --- receive notifications of a node's new state, it suffices to reschedule the --- bucket refresh 'touchBucket' on every transition to a state other than --- 'Applicant'. --- --- XXX: Unfortunately, this means redundantly triggering twice upon every node --- replacement because we do not currently distinguish between standalone --- insertion/deletion events and an insertion/deletion pair constituting --- replacement. --- --- It might also be better to pass the timestamp of the transition here and --- keep the refresh queue in better sync with the routing table by updating it --- within the STM monad. --- --- We embed the result in the STM monad but currently, no STM state changes --- occur until the returned IO action is invoked. TODO: simplify? -touchBucket :: SensibleNodeId nid ni - => BucketRefresher nid ni - -> RoutingTransition ni -- ^ What happened to the bucket? - -> STM (IO ()) -touchBucket r@BucketRefresher{ refreshSearch - , refreshInterval - , refreshBuckets - , refreshQueue - , refreshLastTouch - , bootstrapMode - , bootstrapCountdown } - RoutingTransition{ transitionedTo - , transitioningNode } - = case transitionedTo of - Applicant -> return $ return () -- Ignore transition to applicant. - _ -> return $ do -- Reschedule for any other transition. - now <- getPOSIXTime - join $ atomically $ do - let space = searchSpace refreshSearch - nid = kademliaLocation space transitioningNode - tbl <- readTVar refreshBuckets - let num = R.bucketNumber space nid tbl - stamp <- readTVar refreshLastTouch - action <- case stamp /= 0 && (now - stamp > 60) of - True -> do - -- It's been one minute since any bucket has been touched, re-enter bootstrap mode. - restartBootstrap r - False -> return $ return () - interval <- effectiveRefreshInterval r num - modifyTVar' refreshQueue $ Int.insert num (now + interval) - writeTVar refreshLastTouch now - return action - -refreshKademlia :: SensibleNodeId nid ni => BucketRefresher nid ni -> Kademlia nid ni -refreshKademlia r@BucketRefresher { refreshSearch = sch - , refreshPing = ping - , refreshBuckets = bkts - } - = Kademlia quietInsertions (searchSpace sch) (vanillaIO bkts ping) - { tblTransition = \tr -> do - io <- touchBucket r tr - return io - } diff --git a/src/Network/Kademlia/CommonAPI.hs b/src/Network/Kademlia/CommonAPI.hs deleted file mode 100644 index 601be5d8..00000000 --- a/src/Network/Kademlia/CommonAPI.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Network.Kademlia.CommonAPI where - - -import Control.Concurrent -import Control.Concurrent.STM -import Data.Aeson as J (FromJSON, ToJSON) -import Data.Hashable -import qualified Data.Map as Map -import Data.Serialize as S -import qualified Data.Set as Set -import Data.Time.Clock.POSIX -import Data.Typeable - -import Network.Kademlia.Search -import Network.Kademlia.Routing as R -import Crypto.Tox (SecretKey,PublicKey) - -data DHT = forall nid ni. ( Show ni - , Read ni - , ToJSON ni - , FromJSON ni - , Ord ni - , Hashable ni - , Show nid - , Ord nid - , Hashable nid - , Typeable ni - , S.Serialize nid - ) => - DHT - { dhtBuckets :: TVar (BucketList ni) - , dhtSecretKey :: STM (Maybe SecretKey) - , dhtPing :: Map.Map String (DHTPing ni) - , dhtQuery :: Map.Map String (DHTQuery nid ni) - , dhtAnnouncables :: Map.Map String (DHTAnnouncable nid) - , dhtParseId :: String -> Either String nid - , dhtSearches :: TVar (Map.Map (String,nid) (DHTSearch nid ni)) - , dhtFallbackNodes :: IO [ni] - , dhtBootstrap :: [ni] -> [ni] -> IO () - } - -data DHTQuery nid ni = forall addr r tok. - ( Ord addr - , Typeable r - , Typeable tok - , Typeable ni - ) => DHTQuery - { qsearch :: Search nid addr tok ni r - , qhandler :: ni -> nid -> IO ([ni], [r], Maybe tok) -- ^ Invoked on local node, when there is no query destination. - , qshowR :: r -> String - , qshowTok :: tok -> Maybe String - } - -data DHTAnnouncable nid = forall dta tok ni r. - ( Show r - , Typeable dta -- information being announced - , Typeable tok -- token - , Typeable r -- search result - , Typeable ni -- node - ) => DHTAnnouncable - { announceParseData :: String -> Either String dta - , announceParseToken :: dta -> String -> Either String tok - , announceParseAddress :: String -> Either String ni - , announceSendData :: Either ( String {- search name -} - , String -> Either String r - , PublicKey {- me -} -> dta -> r -> IO ()) - (dta -> tok -> Maybe ni -> IO (Maybe r)) - , announceInterval :: POSIXTime - , announceTarget :: dta -> nid - } - -data DHTSearch nid ni = forall addr tok r. DHTSearch - { searchThread :: ThreadId - , searchState :: SearchState nid addr tok ni r - , searchShowTok :: tok -> Maybe String - , searchResults :: TVar (Set.Set String) - } - -data DHTPing ni = forall r. DHTPing - { pingQuery :: [String] -> ni -> IO (Maybe r) - , pingShowResult :: r -> String - } - diff --git a/src/Network/Kademlia/Persistence.hs b/src/Network/Kademlia/Persistence.hs deleted file mode 100644 index d7431671..00000000 --- a/src/Network/Kademlia/Persistence.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module Network.Kademlia.Persistence where - -import Network.Kademlia.CommonAPI -import Network.Kademlia.Routing as R - -import Control.Concurrent.STM -import qualified Data.Aeson as J - ;import Data.Aeson as J (FromJSON) -import qualified Data.ByteString.Lazy as L -import qualified Data.HashMap.Strict as HashMap -import Data.List -import qualified Data.Vector as V -import System.IO.Error - -saveNodes :: String -> DHT -> IO () -saveNodes netname DHT{dhtBuckets} = do - bkts <- atomically $ readTVar dhtBuckets - let ns = map fst $ concat $ R.toList bkts - bs = J.encode ns - fname = nodesFileName netname - L.writeFile fname bs - -loadNodes :: FromJSON ni => String -> IO [ni] -loadNodes netname = do - let fname = nodesFileName netname - attempt <- tryIOError $ do - J.decode <$> L.readFile fname - >>= maybe (ioError $ userError "Nothing") return - either (const $ fallbackLoad fname) return attempt - -nodesFileName :: String -> String -nodesFileName netname = netname ++ "-nodes.json" - -fallbackLoad :: FromJSON t => FilePath -> IO [t] -fallbackLoad fname = do - attempt <- tryIOError $ do - J.decode <$> L.readFile fname - >>= maybe (ioError $ userError "Nothing") return - let go r = do - let m = HashMap.lookup "nodes" (r :: J.Object) - ns0 = case m of Just (J.Array v) -> V.toList v - Nothing -> [] - ns1 = zip (map J.fromJSON ns0) ns0 - issuc (J.Error _,_) = False - issuc _ = True - (ss,fs) = partition issuc ns1 - ns = map (\(J.Success n,_) -> n) ss - mapM_ print (map snd fs) >> return ns - either (const $ return []) go attempt - diff --git a/src/Network/Kademlia/Routing.hs b/src/Network/Kademlia/Routing.hs deleted file mode 100644 index a52cca73..00000000 --- a/src/Network/Kademlia/Routing.hs +++ /dev/null @@ -1,808 +0,0 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- (c) Joe Crayne 2017 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Every node maintains a routing table of known good nodes. The --- nodes in the routing table are used as starting points for --- queries in the DHT. Nodes from the routing table are returned in --- response to queries from other nodes. --- --- For more info see: --- --- -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.Kademlia.Routing - {- - ( -- * BucketList - BucketList - , Info(..) - - -- * Attributes - , BucketCount - , defaultBucketCount - , BucketSize - , defaultBucketSize - , NodeCount - - -- * Query - , Network.Kademlia.Routing.null - , Network.Kademlia.Routing.full - , thisId - , shape - , Network.Kademlia.Routing.size - , Network.Kademlia.Routing.depth - , compatibleNodeId - - -- * Lookup - , K - , defaultK - , TableKey (..) - , kclosest - - -- * Construction - , Network.Kademlia.Routing.nullTable - , Event(..) - , CheckPing(..) - , Network.Kademlia.Routing.insert - - -- * Conversion - , Network.Kademlia.Routing.TableEntry - , Network.Kademlia.Routing.toList - - -- * Routing - , Timestamp - , getTimestamp - ) -} where - -import Control.Applicative as A -import Control.Arrow -import Control.Monad -import Data.Function -import Data.Functor.Contravariant -import Data.Functor.Identity -import Data.List as L hiding (insert) -import Data.Maybe -import Data.Monoid -import Data.Wrapper.PSQ as PSQ -import Data.Serialize as S hiding (Result, Done) -import qualified Data.Sequence as Seq -import Data.Time -import Data.Time.Clock.POSIX -import Data.Word -import GHC.Generics -import Text.PrettyPrint as PP hiding ((<>)) -import Text.PrettyPrint.HughesPJClass (pPrint,Pretty) -import qualified Data.ByteString as BS -import Data.Bits -import Data.Ord -import Data.Reflection -import Network.Address -import Data.Typeable -import Data.Coerce -import Data.Hashable - - --- | Last time the node was responding to our queries. --- --- Not all nodes that we learn about are equal. Some are \"good\" and --- some are not. Many nodes using the DHT are able to send queries --- and receive responses, but are not able to respond to queries --- from other nodes. It is important that each node's routing table --- must contain only known good nodes. A good node is a node has --- responded to one of our queries within the last 15 minutes. A --- node is also good if it has ever responded to one of our queries --- and has sent us a query within the last 15 minutes. After 15 --- minutes of inactivity, a node becomes questionable. Nodes become --- bad when they fail to respond to multiple queries in a row. Nodes --- that we know are good are given priority over nodes with unknown --- status. --- -type Timestamp = POSIXTime - -getTimestamp :: IO Timestamp -getTimestamp = do - utcTime <- getCurrentTime - return $ utcTimeToPOSIXSeconds utcTime - - - -{----------------------------------------------------------------------- - Bucket ------------------------------------------------------------------------} --- --- When a k-bucket is full and a new node is discovered for that --- k-bucket, the least recently seen node in the k-bucket is --- PINGed. If the node is found to be still alive, the new node is --- place in a secondary list, a replacement cache. The replacement --- cache is used only if a node in the k-bucket stops responding. In --- other words: new nodes are used only when older nodes disappear. - --- | Timestamp - last time this node is pinged. -type NodeEntry ni = Binding ni Timestamp - - --- | Maximum number of 'NodeInfo's stored in a bucket. Most clients --- use this value. -defaultBucketSize :: Int -defaultBucketSize = 8 - -data QueueMethods m elem fifo = QueueMethods - { pushBack :: elem -> fifo -> m fifo - , popFront :: fifo -> m (Maybe elem, fifo) - , emptyQueue :: m fifo - } - -{- -fromQ :: Functor m => - ( a -> b ) - -> ( b -> a ) - -> QueueMethods m elem a - -> QueueMethods m elem b -fromQ embed project QueueMethods{..} = - QueueMethods { pushBack = \e -> fmap embed . pushBack e . project - , popFront = fmap (second embed) . popFront . project - , emptyQueue = fmap embed emptyQueue - } --} - -seqQ :: QueueMethods Identity ni (Seq.Seq ni) -seqQ = QueueMethods - { pushBack = \e fifo -> pure (fifo Seq.|> e) - , popFront = \fifo -> case Seq.viewl fifo of - e Seq.:< fifo' -> pure (Just e, fifo') - Seq.EmptyL -> pure (Nothing, Seq.empty) - , emptyQueue = pure Seq.empty - } - -type BucketQueue ni = Seq.Seq ni - -bucketQ :: QueueMethods Identity ni (BucketQueue ni) -bucketQ = seqQ - - -data Compare a = Compare (a -> a -> Ordering) (Int -> a -> Int) - -contramapC :: (b -> a) -> Compare a -> Compare b -contramapC f (Compare cmp hsh) = Compare (\a b -> cmp (f a) (f b)) - (\s x -> hsh s (f x)) - -newtype Ordered' s a = Ordered a - deriving (Show) - --- | Hack to avoid UndecidableInstances -newtype Shrink a = Shrink a - deriving (Show) - -type Ordered s a = Ordered' s (Shrink a) - -instance Reifies s (Compare a) => Eq (Ordered' s (Shrink a)) where - a == b = (compare a b == EQ) - -instance Reifies s (Compare a) => Ord (Ordered' s (Shrink a)) where - compare a b = cmp (coerce a) (coerce b) - where Compare cmp _ = reflect (Proxy :: Proxy s) - -instance Reifies s (Compare a) => Hashable (Ordered' s (Shrink a)) where - hashWithSalt salt x = hash salt (coerce x) - where Compare _ hash = reflect (Proxy :: Proxy s) - --- | Bucket is also limited in its length — thus it's called k-bucket. --- When bucket becomes full, we should split it in two lists by --- current span bit. Span bit is defined by depth in the routing --- table tree. Size of the bucket should be choosen such that it's --- very unlikely that all nodes in bucket fail within an hour of --- each other. -data Bucket s ni = Bucket - { bktNodes :: !(PSQ (Ordered s ni) Timestamp) -- current routing nodes - , bktQ :: !(BucketQueue (Timestamp,ni)) -- replacements pending time-outs - } deriving (Generic) - -#define CAN_SHOW_BUCKET 0 - -#if CAN_SHOW_BUCKET -deriving instance Show ni => Show (Bucket s ni) -#endif - -bucketCompare :: forall p ni s. Reifies s (Compare ni) => p (Bucket s ni) -> Compare ni -bucketCompare _ = reflect (Proxy :: Proxy s) - -mapBucket :: ( Reifies s (Compare a) - , Reifies t (Compare ni) - ) => (a -> ni) -> Bucket s a -> Bucket t ni -mapBucket f (Bucket ns q) = Bucket (PSQ.fromList $ map (\(ni :-> tm) -> (f' ni :-> tm)) $ PSQ.toList ns) - (fmap (second f) q) - where f' = coerce . f . coerce - - -#if 0 - -{- -getGenericNode :: ( Serialize (NodeId) - , Serialize ip - , Serialize u - ) => Get (NodeInfo) -getGenericNode = do - nid <- get - naddr <- get - u <- get - return NodeInfo - { nodeId = nid - , nodeAddr = naddr - , nodeAnnotation = u - } - -putGenericNode :: ( Serialize (NodeId) - , Serialize ip - , Serialize u - ) => NodeInfo -> Put -putGenericNode (NodeInfo nid naddr u) = do - put nid - put naddr - put u - -instance (Eq ip, Ord (NodeId), Serialize (NodeId), Serialize ip, Serialize u) => Serialize (Bucket) where - get = Bucket . psqFromPairList <$> getListOf ( (,) <$> getGenericNode <*> get ) <*> pure (runIdentity $ emptyQueue bucketQ) - put = putListOf (\(ni,stamp) -> putGenericNode ni >> put stamp) . psqToPairList . bktNodes --} - -#endif - -psqFromPairList :: (Ord p, PSQKey k) => [(k, p)] -> PSQ k p -psqFromPairList xs = PSQ.fromList $ map (\(a,b) -> a :-> b) xs - -psqToPairList :: ( PSQKey t, Ord t1 ) => PSQ t t1 -> [(t, t1)] -psqToPairList psq = map (\(a :-> b) -> (a,b)) $ PSQ.toList psq - --- | Update interval, in seconds. -delta :: NominalDiffTime -delta = 15 * 60 - --- | Should maintain a set of stable long running nodes. --- --- Note: pings are triggerd only when a bucket is full. -updateBucketForInbound :: ( Coercible t1 t - , Alternative f - , Reifies s (Compare t1) - ) => NominalDiffTime -> t1 -> Bucket s t1 -> f ([t], Bucket s t1) -updateBucketForInbound curTime info bucket - -- Just update timestamp if a node is already in bucket. - -- - -- Note PingResult events should only occur for nodes we requested a ping for, - -- and those will always already be in the routing queue and will get their - -- timestamp updated here, since 'TryInsert' is called on every inbound packet, - -- including ping results. - | already_have - = pure ( [], map_ns $ PSQ.insertWith max (coerce info) curTime ) - -- bucket is good, but not full => we can insert a new node - | PSQ.size (bktNodes bucket) < defaultBucketSize - = pure ( [], map_ns $ PSQ.insert (coerce info) curTime ) - -- If there are any questionable nodes in the bucket have not been - -- seen in the last 15 minutes, the least recently seen node is - -- pinged. If any nodes in the bucket are known to have become bad, - -- then one is replaced by the new node in the next insertBucket - -- iteration. - | not (L.null stales) - = pure ( stales - , bucket { -- Update timestamps so that we don't redundantly ping. - bktNodes = updateStamps curTime (coerce stales) $ bktNodes bucket - -- Update queue with the pending NodeInfo in case of ping fail. - , bktQ = runIdentity $ pushBack bucketQ (curTime,info) $ bktQ bucket } ) - -- When the bucket is full of good nodes, the new node is simply discarded. - -- We must return 'A.empty' here to ensure that bucket splitting happens - -- inside 'modifyBucket'. - | otherwise = A.empty - where - -- We (take 1) to keep a 1-to-1 correspondence between pending pings and - -- waiting nodes in the bktQ. This way, we don't have to worry about what - -- to do with failed pings for which there is no ready replacements. - stales = -- One stale: - do (n :-> t) <- maybeToList $ PSQ.findMin (bktNodes bucket) - guard (t < curTime - delta) - return $ coerce n - -- All stale: - -- map key \$ PSQ.atMost (curTime - delta) $ bktNodes bucket - - already_have = maybe False (const True) $ PSQ.lookup (coerce info) (bktNodes bucket) - - map_ns f = bucket { bktNodes = f (bktNodes bucket) } - -- map_q f = bucket { bktQ = runIdentity \$ f (bktQ bucket) } - -updateBucketForPingResult :: (Applicative f, Reifies s (Compare a)) => - a -> Bool -> Bucket s a -> f ([(a, Maybe (Timestamp, a))], Bucket s a) -updateBucketForPingResult bad_node got_response bucket - = pure ( map (,Nothing) forgotten - ++ map (second Just) replacements - , Bucket (foldr replace - (bktNodes bucket) - replacements) - popped - ) - where - (top, popped) = runIdentity $ popFront bucketQ (bktQ bucket) - - -- Dropped from accepted, replaced by pending. - replacements | got_response = [] -- Timestamp was already updated by TryInsert. - | Just info <- top = do - -- Insert only if there's a removal. - _ <- maybeToList $ PSQ.lookup (coerce bad_node) (bktNodes bucket) - return (bad_node, info) - | otherwise = [] - - -- Dropped from the pending queue without replacing. - forgotten | got_response = maybeToList $ fmap snd top - | otherwise = [] - - - replace (bad_node, (tm, info)) = - PSQ.insert (coerce info) tm - . PSQ.delete (coerce bad_node) - - -updateStamps :: PSQKey ni => Timestamp -> [ni] -> PSQ ni Timestamp -> PSQ ni Timestamp -updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales - -type BitIx = Word - -partitionQ :: Monad f => QueueMethods f elem b -> (elem -> Bool) -> b -> f (b, b) -partitionQ imp test q0 = do - pass0 <- emptyQueue imp - fail0 <- emptyQueue imp - let flipfix a b f = fix f a b - flipfix q0 (pass0,fail0) $ \rec q qs -> do - (mb,q') <- popFront imp q - case mb of - Nothing -> return qs - Just e -> do qs' <- select (pushBack imp e) qs - rec q' qs' - where - select :: Functor f => (b -> f b) -> (b, b) -> f (b, b) - select f = if test e then \(a,b) -> flip (,) b <$> f a - else \(a,b) -> (,) a <$> f b - - - -split :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) => - forall ni s. ( Reifies s (Compare ni) ) => - (ni -> Word -> Bool) - -> BitIx -> Bucket s ni -> (Bucket s ni, Bucket s ni) -split testNodeIdBit i b = (Bucket ns qs, Bucket ms rs) - where - (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . coerce . key) . PSQ.toList $ bktNodes b - (qs,rs) = runIdentity $ partitionQ bucketQ (spanBit . snd) $ bktQ b - - spanBit :: ni -> Bool - spanBit entry = testNodeIdBit entry i - - -{----------------------------------------------------------------------- --- BucketList ------------------------------------------------------------------------} - -defaultBucketCount :: Int -defaultBucketCount = 20 - -defaultMaxBucketCount :: Word -defaultMaxBucketCount = 24 - -data Info ni nid = Info - { myBuckets :: BucketList ni - , myNodeId :: nid - , myAddress :: SockAddr - } - deriving Generic - -deriving instance (Eq ni, Eq nid) => Eq (Info ni nid) -deriving instance (Show ni, Show nid) => Show (Info ni nid) - --- instance (Eq ip, Serialize ip) => Serialize (Info ip) - --- | The routing table covers the entire 'NodeId' space from 0 to 2 ^ --- 160. The routing table is subdivided into 'Bucket's that each cover --- a portion of the space. An empty table has one bucket with an ID --- space range of @min = 0, max = 2 ^ 160@. When a node with ID \"N\" --- is inserted into the table, it is placed within the bucket that has --- @min <= N < max@. An empty table has only one bucket so any node --- must fit within it. Each bucket can only hold 'K' nodes, currently --- eight, before becoming 'Full'. When a bucket is full of known good --- nodes, no more nodes may be added unless our own 'NodeId' falls --- within the range of the 'Bucket'. In that case, the bucket is --- replaced by two new buckets each with half the range of the old --- bucket and the nodes from the old bucket are distributed among the --- two new ones. For a new table with only one bucket, the full bucket --- is always split into two new buckets covering the ranges @0..2 ^ --- 159@ and @2 ^ 159..2 ^ 160@. --- -data BucketList ni = forall s. Reifies s (Compare ni) => - BucketList { thisNode :: !ni - -- | Non-empty list of buckets. - , buckets :: [Bucket s ni] - } - -mapTable :: (b -> t) -> (t -> b) -> BucketList t -> BucketList b -mapTable g f tbl@(BucketList self bkts) = reify (contramapC g $ bucketCompare bkts) - $ \p -> BucketList - { thisNode = f self - , buckets = map (resolve p . mapBucket f) bkts - } - where - resolve :: Proxy s -> Bucket s ni -> Bucket s ni - resolve = const id - -instance (Eq ni) => Eq (BucketList ni) where - (==) = (==) `on` Network.Kademlia.Routing.toList - -#if 0 - -instance Serialize NominalDiffTime where - put = putWord32be . fromIntegral . fromEnum - get = (toEnum . fromIntegral) <$> getWord32be - -#endif - -#if CAN_SHOW_BUCKET -deriving instance (Show ni) => Show (BucketList ni) -#else -instance Show ni => Show (BucketList ni) where - showsPrec d (BucketList self bkts) = - mappend "BucketList " - . showsPrec (d+1) self - . mappend " (fromList " - . showsPrec (d+1) (L.map (L.map tableEntry . PSQ.toList . bktNodes) $ bkts) - . mappend ") " -#endif - -#if 0 - --- | Normally, routing table should be saved between invocations of --- the client software. Note that you don't need to store /this/ --- 'NodeId' since it is already included in routing table. -instance (Eq ip, Serialize ip, Ord (NodeId), Serialize (NodeId), Serialize u) => Serialize (BucketList) - -#endif - --- | Shape of the table. -instance Pretty (BucketList ni) where - pPrint t - | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss - | otherwise = brackets $ - PP.int (L.sum ss) <> " nodes, " <> - PP.int bucketCount <> " buckets" - where - bucketCount = L.length ss - ss = shape t - --- | Empty table with specified /spine/ node id. --- --- XXX: The comparison function argument is awkward here. -nullTable :: (ni -> ni -> Ordering) -> (Int -> ni -> Int) -> ni -> Int -> BucketList ni -nullTable cmp hsh ni n = - reify (Compare cmp hsh) - $ \p -> BucketList - ni - [Bucket (empty p) (runIdentity $ emptyQueue bucketQ)] - where - empty :: Reifies s (Compare ni) => Proxy s -> PSQ (Ordered s ni) Timestamp - empty = const $ PSQ.empty - -#if 0 - --- | Test if table is empty. In this case DHT should start --- bootstrapping process until table becomes 'full'. -null :: BucketList -> Bool -null (Tip _ _ b) = PSQ.null $ bktNodes b -null _ = False - --- | Test if table have maximum number of nodes. No more nodes can be --- 'insert'ed, except old ones becomes bad. -full :: BucketList -> Bool -full (Tip _ n _) = n == 0 -full (Zero t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t -full (One b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t - --- | Get the /spine/ node id. -thisId :: BucketList -> NodeId -thisId (Tip nid _ _) = nid -thisId (Zero table _) = thisId table -thisId (One _ table) = thisId table - --- | Number of nodes in a bucket or a table. -type NodeCount = Int - -#endif - --- | Internally, routing table is similar to list of buckets or a --- /matrix/ of nodes. This function returns the shape of the matrix. -shape :: BucketList ni -> [Int] -shape (BucketList _ tbl) = map (PSQ.size . bktNodes) tbl - -#if 0 - --- | Get number of nodes in the table. -size :: BucketList -> NodeCount -size = L.sum . shape - --- | Get number of buckets in the table. -depth :: BucketList -> BucketCount -depth = L.length . shape - -#endif - -lookupBucket :: forall ni nid x. - ( -- FiniteBits nid - Ord nid - ) => KademliaSpace nid ni -> nid -> (forall s. Reifies s (Compare ni) => [Bucket s ni] -> x) -> BucketList ni -> x -lookupBucket space nid kont (BucketList self bkts) = kont $ go 0 [] bkts - where - d = kademliaXor space nid (kademliaLocation space self) - - go :: Word -> [Bucket s ni] -> [Bucket s ni] -> [Bucket s ni] - go i bs (bucket : buckets) - | kademliaTestBit space d i = bucket : buckets ++ bs - | otherwise = go (succ i) (bucket:bs) buckets - go _ bs [] = bs - -bucketNumber :: forall ni nid. - KademliaSpace nid ni -> nid -> BucketList ni -> Int -bucketNumber space nid (BucketList self bkts) = fromIntegral $ go 0 bkts - where - d = kademliaXor space nid (kademliaLocation space self) - - go :: Word -> [Bucket s ni] -> Word - go i (bucket : buckets) - | kademliaTestBit space d i = i - | otherwise = go (succ i) buckets - go i [] = i - - -compatibleNodeId :: forall ni nid. - ( Serialize nid, FiniteBits nid) => - (ni -> nid) -> BucketList ni -> IO nid -compatibleNodeId nodeId tbl = genBucketSample prefix br - where - br = bucketRange (L.length (shape tbl) - 1) True - nodeIdSize = finiteBitSize (undefined :: nid) `div` 8 - bs = BS.pack $ take nodeIdSize $ tablePrefix (testIdBit . nodeId) tbl ++ repeat 0 - prefix = either error id $ S.decode bs - -tablePrefix :: (ni -> Word -> Bool) -> BucketList ni -> [Word8] -tablePrefix testbit = map (packByte . take 8 . (++repeat False)) - . chunksOf 8 - . tableBits testbit - where - packByte = foldl1' (.|.) . zipWith bitmask [7,6 .. 0] - bitmask ix True = bit ix - bitmask _ _ = 0 - -tableBits :: (ni -> Word -> Bool) -> BucketList ni -> [Bool] -tableBits testbit (BucketList self bkts) = - zipWith const (map (testbit self) [0..]) - bkts - -selfNode :: BucketList ni -> ni -selfNode (BucketList self _) = self - -chunksOf :: Int -> [e] -> [[e]] -chunksOf i ls = map (take i) (build (splitter ls)) where - splitter :: [e] -> ([e] -> a -> a) -> a -> a - splitter [] _ n = n - splitter l c n = l `c` splitter (drop i l) c n - -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build g = g (:) [] - - - --- | Count of closest nodes in find_node reply. -type K = Int - --- | Default 'K' is equal to 'defaultBucketSize'. -defaultK :: K -defaultK = 8 - -#if 0 -class TableKey dht k where - toNodeId :: k -> NodeId - -instance TableKey dht (NodeId) where - toNodeId = id - -#endif - --- | In Kademlia, the distance metric is XOR and the result is --- interpreted as an unsigned integer. -newtype NodeDistance nodeid = NodeDistance nodeid - deriving (Eq, Ord) - --- | distance(A,B) = |A xor B| Smaller values are closer. -distance :: Bits nid => nid -> nid -> NodeDistance nid -distance a b = NodeDistance $ xor a b - --- | Order by closeness: nearest nodes first. -rank :: ( Ord nid - ) => KademliaSpace nid ni -> nid -> [ni] -> [ni] -rank space nid = L.sortBy (comparing (kademliaXor space nid . kademliaLocation space)) - - --- | Get a list of /K/ closest nodes using XOR metric. Used in --- 'find_node' and 'get_peers' queries. -kclosest :: ( -- FiniteBits nid - Ord nid - ) => - KademliaSpace nid ni -> Int -> nid -> BucketList ni -> [ni] -kclosest space k nid tbl = take k $ rank space nid (L.concat bucket) - ++ rank space nid (L.concat everyone) - where - (bucket,everyone) = - L.splitAt 1 - . lookupBucket space nid (L.map (coerce . L.map PSQ.key . PSQ.toList . bktNodes)) - $ tbl - - - -{----------------------------------------------------------------------- --- Routing ------------------------------------------------------------------------} - -splitTip :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) => - ( Reifies s (Compare ni) ) => - (ni -> Word -> Bool) - -> ni -> BitIx -> Bucket s ni -> [ Bucket s ni ] -splitTip testNodeBit ni i bucket - | testNodeBit ni i = [zeros , ones ] - | otherwise = [ones , zeros ] - where - (ones, zeros) = split testNodeBit i bucket - --- | Used in each query. --- --- TODO: Kademlia non-empty subtrees should should split if they have less than --- k nodes in them. Which subtrees I mean is illustrated in Fig 1. of Kademlia --- paper. The rule requiring additional splits is in section 2.4. -modifyBucket - :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) => - forall ni nid xs. - KademliaSpace nid ni - -> nid -> (forall s. Reifies s (Compare ni) => Bucket s ni -> Maybe (xs, Bucket s ni)) -> BucketList ni -> Maybe (xs,BucketList ni) -modifyBucket space nid f (BucketList self bkts) - = second (BucketList self) <$> go (0 :: BitIx) bkts - where - d = kademliaXor space nid (kademliaLocation space self) - - -- go :: BitIx -> [Bucket s ni] -> Maybe (xs, [Bucket s ni]) - - go !i (bucket : buckets@(_:_)) - | kademliaTestBit space d i = second (: buckets) <$> f bucket - | otherwise = second (bucket :) <$> go (succ i) buckets - - go !i [bucket] = second (: []) <$> f bucket <|> gosplit - where - gosplit | i < defaultMaxBucketCount = go i (splitTip ( kademliaTestBit space - . kademliaLocation space ) - self - i - bucket) - | otherwise = Nothing -- Limit the number of buckets. - - -bktCount :: BucketList ni -> Int -bktCount (BucketList _ bkts) = L.length bkts - --- | Triggering event for atomic table update -data Event ni = TryInsert { foreignNode :: ni } - | PingResult { foreignNode :: ni , ponged :: Bool } - -#if 0 -deriving instance Eq (NodeId) => Eq (Event) -deriving instance ( Show ip - , Show (NodeId) - , Show u - ) => Show (Event) - -#endif - -eventId :: (ni -> nid) -> Event ni -> nid -eventId nodeId (TryInsert ni) = nodeId ni -eventId nodeId (PingResult ni _) = nodeId ni - - --- | Actions requested by atomic table update -data CheckPing ni = CheckPing [ni] - -#if 0 - -deriving instance Eq (NodeId) => Eq (CheckPing) -deriving instance ( Show ip - , Show (NodeId) - , Show u - ) => Show (CheckPing) - -#endif - - --- | Call on every inbound packet (including requested ping results). --- Returns a triple (was_inserted, to_ping, tbl') where --- --- [ /was_inserted/ ] True if the node was added to the routing table. --- --- [ /to_ping/ ] A list of nodes to ping and then run 'updateForPingResult'. --- This will be empty if /was_inserted/, but a non-inserted node --- may be added to a replacement queue and will be inserted if --- one of the items in this list time out. --- --- [ /tbl'/ ] The updated routing 'BucketList'. --- -updateForInbound :: - KademliaSpace nid ni - -> Timestamp -> ni -> BucketList ni -> (Bool, [ni], BucketList ni) -updateForInbound space tm ni tbl@(BucketList _ bkts) = - maybe (False, [],tbl) (\(ps,tbl') -> (True, ps, tbl')) - $ modifyBucket space - (kademliaLocation space ni) - (updateBucketForInbound tm ni) - tbl - --- | Update the routing table with the results of a ping. --- --- Each (a,(tm,b)) in the returned list indicates that the node /a/ was deleted from the --- routing table and the node /b/, with timestamp /tm/, has taken its place. -updateForPingResult :: - KademliaSpace nid ni - -> ni -- ^ The pinged node. - -> Bool -- ^ True if we got a reply, False if it timed out. - -> BucketList ni -- ^ The routing table. - -> ( [(ni,Maybe (Timestamp, ni))], BucketList ni ) -updateForPingResult space ni got_reply tbl = - fromMaybe ([],tbl) - $ modifyBucket space - (kademliaLocation space ni) - (updateBucketForPingResult ni got_reply) - tbl - - -{----------------------------------------------------------------------- --- Conversion ------------------------------------------------------------------------} - -type TableEntry ni = (ni, Timestamp) - -tableEntry :: NodeEntry ni -> TableEntry ni -tableEntry (a :-> b) = (a, b) - -toList :: BucketList ni -> [[TableEntry ni]] -toList (BucketList _ bkts) = coerce $ L.map (L.map tableEntry . PSQ.toList . bktNodes) bkts - -data KademliaSpace nid ni = KademliaSpace - { -- | Given a node record (probably including IP address), yields a - -- kademlia xor-metric location. - kademliaLocation :: ni -> nid - -- | Used when comparing locations. This is similar to - -- 'Data.Bits.testBit' except that the ordering of bits is reversed, so - -- that 0 is the most significant bit. - , kademliaTestBit :: nid -> Word -> Bool - -- | The Kademlia xor-metric. - , kademliaXor :: nid -> nid -> nid - - , kademliaSample :: forall m. Applicative m => (Int -> m BS.ByteString) -> nid -> (Int,Word8,Word8) -> m nid - } - -instance Contravariant (KademliaSpace nid) where - contramap f ks = ks - { kademliaLocation = kademliaLocation ks . f - } - diff --git a/src/Network/Kademlia/Search.hs b/src/Network/Kademlia/Search.hs deleted file mode 100644 index 1be1afc1..00000000 --- a/src/Network/Kademlia/Search.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -module Network.Kademlia.Search where - -import Control.Concurrent.Tasks -import Control.Concurrent.STM -import Control.Monad -import Data.Function -import Data.Maybe -import qualified Data.Set as Set - ;import Data.Set (Set) -import Data.Hashable (Hashable(..)) -- for type sigs -import System.IO.Error - -import qualified Data.MinMaxPSQ as MM - ;import Data.MinMaxPSQ (MinMaxPSQ, MinMaxPSQ') -import qualified Data.Wrapper.PSQ as PSQ - ;import Data.Wrapper.PSQ (pattern (:->), Binding, pattern Binding, Binding', PSQKey) -import Network.Kademlia.Routing as R -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -import GHC.Conc (labelThread) -#endif - -data Search nid addr tok ni r = Search - { searchSpace :: KademliaSpace nid ni - , searchNodeAddress :: ni -> addr - , searchQuery :: Either (nid -> ni -> IO (Maybe ([ni], [r], Maybe tok))) - (nid -> ni -> (Maybe ([ni],[r],Maybe tok) -> IO ()) -> IO ()) - , searchAlpha :: Int -- α = 8 - -- | 'searchK' should be larger than 'searchAlpha'. How much larger depends on - -- how fast the queries are. For Tox's much slower onion-routed queries, we - -- need to ensure that closer non-responding queries don't completely push out - -- farther away queries. - -- - -- For BitTorrent, setting them both 8 was not an issue, but that is no longer - -- supported because now the number of remembered informants is now the - -- difference between these two numbers. So, if searchK = 16 and searchAlpha = - -- 4, then the number of remembered query responses is 12. - , searchK :: Int -- K = 16 - } - -data SearchState nid addr tok ni r = SearchState - { -- | The number of pending queries. Incremented before any query is sent - -- and decremented when we get a reply. - searchPendingCount :: TVar Int - -- | Nodes scheduled to be queried (roughly at most K). - , searchQueued :: TVar (MinMaxPSQ ni nid) - -- | The nearest (K - α) nodes that issued a reply. - -- - -- α is the maximum number of simultaneous queries. - , searchInformant :: TVar (MinMaxPSQ' ni nid (Maybe tok)) - -- | This tracks already-queried addresses so we avoid bothering them - -- again. XXX: We could probably keep only the pending queries in this - -- set. It also can be a bounded 'MinMaxPSQ', although searchAlpha - -- should limit the number of outstanding queries. - , searchVisited :: TVar (Set addr) - , searchSpec :: Search nid addr tok ni r - } - - -newSearch :: ( Ord addr - , PSQKey nid - , PSQKey ni - ) => - {- - KademliaSpace nid ni - -> (ni -> addr) - -> (ni -> IO ([ni], [r])) -- the query action. - -> (r -> STM Bool) -- receives search results. - -> nid -- target of search - -} - Search nid addr tok ni r - -> nid - -> [ni] -- Initial nodes to query. - -> STM (SearchState nid addr tok ni r) -newSearch s@(Search space nAddr qry _ _) target ns = do - c <- newTVar 0 - q <- newTVar $ MM.fromList - $ map (\n -> n :-> kademliaXor space target (kademliaLocation space n)) - $ ns - i <- newTVar MM.empty - v <- newTVar Set.empty - return -- (Search space nAddr qry) , r , target - ( SearchState c q i v s ) - --- | Discard a value from a key-priority-value tuple. This is useful for --- swaping items from a "MinMaxPSQ'" to a "MinMaxPSQ". -stripValue :: Binding' k p v -> Binding k p -stripValue (Binding ni _ nid) = (ni :-> nid) - --- | Reset a 'SearchState' object to ready it for a repeated search. -reset :: (Ord ni, Ord nid, Hashable ni, Hashable nid) => - (nid -> STM [ni]) - -> Search nid addr1 tok1 ni r1 - -> nid - -> SearchState nid addr tok ni r - -> STM (SearchState nid addr tok ni r) -reset nearestNodes qsearch target st = do - searchIsFinished st >>= check -- Wait for a search to finish before resetting. - bktNodes <- map (\ni -> ni :-> kademliaLocation (searchSpace qsearch) ni) - <$> nearestNodes target - priorInformants <- map stripValue . MM.toList <$> readTVar (searchInformant st) - writeTVar (searchQueued st) $ MM.fromList $ priorInformants ++ bktNodes - writeTVar (searchInformant st) MM.empty - writeTVar (searchVisited st) Set.empty - writeTVar (searchPendingCount st) 0 - return st - -sendAsyncQuery :: forall addr nid tok ni r. - ( Ord addr - , PSQKey nid - , PSQKey ni - , Show nid - ) => - Search nid addr tok ni r - -> nid - -> (r -> STM Bool) -- ^ return False to terminate the search. - -> SearchState nid addr tok ni r - -> Binding ni nid - -> TaskGroup - -> IO () -sendAsyncQuery Search{..} searchTarget searchResult sch@SearchState{..} (ni :-> d) g = - case searchQuery of - Left blockingQuery -> - forkTask g "searchQuery" $ do - myThreadId >>= flip labelThread ("searchQuery." ++ show searchTarget) - reply <- blockingQuery searchTarget ni `catchIOError` const (return Nothing) - atomically $ do - modifyTVar searchPendingCount pred - maybe (return ()) go reply - Right nonblockingQuery -> do - nonblockingQuery searchTarget ni $ \reply -> - atomically $ do - modifyTVar searchPendingCount pred - maybe (return ()) go reply - where - go (ns,rs,tok) = do - vs <- readTVar searchVisited - -- We only queue a node if it is not yet visited - let insertFoundNode :: Int - -> ni - -> MinMaxPSQ ni nid - -> MinMaxPSQ ni nid - insertFoundNode k n q - | searchNodeAddress n `Set.member` vs - = q - | otherwise = MM.insertTake k n ( kademliaXor searchSpace searchTarget - $ kademliaLocation searchSpace n ) - q - - qsize0 <- MM.size <$> readTVar searchQueued - let qsize = if qsize0 < searchK then searchK else qsize0 -- Allow searchQueued to grow - -- only when there's fewer than - -- K elements. - modifyTVar searchQueued $ \q -> foldr (insertFoundNode qsize) q ns - modifyTVar searchInformant $ MM.insertTake' (searchK - searchAlpha) ni tok d - flip fix rs $ \loop -> \case - r:rs' -> do - wanting <- searchResult r - if wanting then loop rs' - else searchCancel sch - [] -> return () - - -searchIsFinished :: ( PSQKey nid - , PSQKey ni - ) => SearchState nid addr tok ni r -> STM Bool -searchIsFinished SearchState{..} = do - q <- readTVar searchQueued - cnt <- readTVar searchPendingCount - informants <- readTVar searchInformant - return $ cnt == 0 - && ( MM.null q - || ( MM.size informants >= (searchK searchSpec - searchAlpha searchSpec) - && ( PSQ.prio (fromJust $ MM.findMax informants) - <= PSQ.prio (fromJust $ MM.findMin q)))) - -searchCancel :: SearchState nid addr tok ni r -> STM () -searchCancel SearchState{..} = do - writeTVar searchPendingCount 0 - writeTVar searchQueued MM.empty - -search :: - ( Ord r - , Ord addr - , PSQKey nid - , PSQKey ni - , Show nid - ) => Search nid addr tok ni r -> R.BucketList ni -> nid -> (r -> STM Bool) -> IO (SearchState nid addr tok ni r) -search sch buckets target result = do - let ns = R.kclosest (searchSpace sch) (searchK sch) target buckets - st <- atomically $ newSearch sch target ns - forkIO $ searchLoop sch target result st - return st - -searchLoop :: ( Ord addr, Ord nid, Ord ni, Show nid, Hashable nid, Hashable ni ) - => Search nid addr tok ni r -- ^ Query and distance methods. - -> nid -- ^ The target we are searching for. - -> (r -> STM Bool) -- ^ Invoked on each result. Return False to quit searching. - -> SearchState nid addr tok ni r -- ^ Search-related state. - -> IO () -searchLoop sch@Search{..} target result s@SearchState{..} = do - myThreadId >>= flip labelThread ("search."++show target) - withTaskGroup ("search.g."++show target) searchAlpha $ \g -> fix $ \again -> do - join $ atomically $ do - cnt <- readTVar $ searchPendingCount - check (cnt <= 8) -- Only 8 pending queries at a time. - informants <- readTVar searchInformant - found <- MM.minView <$> readTVar searchQueued - case found of - Just (ni :-> d, q) - | -- If there's fewer than /k - α/ informants and there's any - -- node we haven't yet got a response from. - (MM.size informants < searchK - searchAlpha) && (cnt > 0 || not (MM.null q)) - -- Or there's no informants yet at all. - || MM.null informants - -- Or if the closest scheduled node is nearer than the - -- nearest /k/ informants. - || (d < PSQ.prio (fromJust $ MM.findMax informants)) - -> -- Then the search continues, send a query. - do writeTVar searchQueued q - modifyTVar searchVisited $ Set.insert (searchNodeAddress ni) - modifyTVar searchPendingCount succ - return $ do - sendAsyncQuery sch target result s (ni :-> d) g - again - _ -> -- Otherwise, we are finished. - do check (cnt == 0) - return $ return () diff --git a/src/Network/Lossless.hs b/src/Network/Lossless.hs deleted file mode 100644 index 861792ab..00000000 --- a/src/Network/Lossless.hs +++ /dev/null @@ -1,124 +0,0 @@ --- | This module uses 'Data.PacketBuffer' appropriately to implement a reliable --- transport over an underlying lossy one. --- --- It was written to be a helper to 'Network.Tox.Session' but it is --- representation-agnostic and so could potentially be used on an unrelated --- lossy transport. -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} -module Network.Lossless where - -import Control.Concurrent.STM.TChan -import Control.Monad -import Control.Monad.STM -import Data.Function -import Data.Word -import System.IO.Error - -import Data.PacketBuffer as PB -import DPut -import DebugTag -import Network.QueryResponse - -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -#endif - --- | Sequencing information for a packet. -data SequenceInfo = SequenceInfo - { sequenceNumber :: {-# UNPACK #-} !Word32 -- ^ Packets are ordered by their 'sequenceNumber'. - , sequenceAck :: {-# UNPACK #-} !Word32 -- ^ This is the sender's latest received in-order packet. - } - deriving (Eq,Ord,Show) - -data OutgoingInfo y = OutgoingInfo - { oIsLossy :: Bool -- ^ True if the packet is treated as lossy. - , oEncoded :: y -- ^ The packet. - , oHandleException :: Maybe (IOError -> IO ()) -- ^ Optionally handle send failure. - } - --- | Obtain a reliable transport form an unreliable one. -lossless :: Show addr => - (x -> addr -> IO (PacketInboundEvent (x',addr'))) -- ^ Used to classify newly arrived packets. - -> (SequenceInfo -> x' -> addr' -> IO (OutgoingInfo y)) -- ^ Used to encode and classify outbound packets. - -> addr -- ^ The remote address for this session. - -> TransportA String addr x y -- ^ An unreliable lossy transport. - - -> IO ( Transport String addr' x' -- ^ A reliable lossless transport. - , [Word32] -> IO () -- ^ Use this to request lost packets be re-sent. - , IO ([Word32],Word32) -- ^ Use this to discover missing packets to request. - ) -lossless isLossless encode saddr udp = do - pb <- atomically newPacketBuffer - oob <- atomically newTChan -- Out-of-band channel, these packets (or - -- errors) bypass the packet buffer to be - -- received immediately. - rloop <- forkIO $ do - -- This thread enqueues inbound packets or writes them to the oob - -- channel. - myThreadId >>= flip labelThread ("lossless."++show saddr) - fix $ \loop -> do - awaitMessage udp $ \m -> do - m' <- mapM (mapM $ uncurry isLossless) m - case m' of - Nothing -> do - atomically $ writeTChan oob Nothing - -- Quit thread here. - Just (Left e) -> do - atomically $ writeTChan oob (Just $ Left e) - loop - Just (Right event) -> do - atomically $ do - -- x' <- isLossless xaddr x - PB.grokInboundPacket pb event - case event of - PacketReceivedLossy {} -> writeTChan oob (Just $ Right $ peReceivedPayload event) - _ -> do - report <- pbReport "enqueued" pb - writeTChan oob (Just $ Left report) - loop - let tr = Transport - { awaitMessage = \kont -> do - join $ atomically $ orElse - (do x <- readTChan oob - return $ kont $! x) - (do x <- PB.awaitReadyPacket pb - report <- pbReport "dequeued" pb - return $ do - atomically $ writeTChan oob (Just $ Left report) - kont $! Just (Right x)) - , sendMessage = \a' x' -> do - seqno <- atomically $ do - seqno <- PB.nextToSendSequenceNumber pb - ack <- PB.expectingSequenceNumber pb - return $ SequenceInfo seqno ack - OutgoingInfo islossy x oops <- encode seqno x' a' - (isfull,nn) <- - if islossy - then do - dput XNetCrypto $ shows saddr $ " <-- Lossy packet " ++ show seqno - return (False,(0,0)) -- avoid updating seqno on lossy packets. - else do - dput XNetCrypto $ shows saddr $ " <-- Lossless packet " ++ show seqno - atomically $ PB.grokOutboundPacket pb (PacketSent (sequenceNumber seqno) x) - when isfull $ do - dput XNetCrypto $ shows saddr $ " <-- Outbound queue is full! Retrying... " ++ show (nn,seqno) - atomically $ do - (isfull,_) <- PB.grokOutboundPacket pb (PacketSent (sequenceNumber seqno) x) - when isfull retry - let sendit = sendMessage udp saddr x - maybe sendit (catchIOError sendit) oops - , closeTransport = do - atomically $ writeTChan oob Nothing -- quit rloop thread - closeTransport udp - } - resend ns = do - xs <- atomically $ retrieveForResend pb ns - dput XNetCrypto $ shows saddr $ " <-- Resending " ++ show (length xs) ++ " packets." - forM_ xs $ \x -> do - dput XNetCrypto $ shows saddr $ " <-- Resending packet." - sendMessage udp saddr . snd $ x - return (tr, resend, atomically $ PB.packetNumbersToRequest pb) diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs deleted file mode 100644 index c4ff50e3..00000000 --- a/src/Network/QueryResponse.hs +++ /dev/null @@ -1,638 +0,0 @@ --- | This module can implement any query\/response protocol. It was written --- with Kademlia implementations in mind. - -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -module Network.QueryResponse where - -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent -import GHC.Conc (labelThread) -#endif -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import qualified Data.ByteString as B - ;import Data.ByteString (ByteString) -import Data.Function -import Data.Functor.Contravariant -import qualified Data.IntMap.Strict as IntMap - ;import Data.IntMap.Strict (IntMap) -import qualified Data.Map.Strict as Map - ;import Data.Map.Strict (Map) -import Data.Time.Clock.POSIX -import qualified Data.Word64Map as W64Map - ;import Data.Word64Map (Word64Map) -import Data.Word -import Data.Maybe -import GHC.Event -import Network.Socket -import Network.Socket.ByteString as B -import System.Endian -import System.IO -import System.IO.Error -import System.Timeout -import DPut -import DebugTag -import Data.TableMethods - --- | Three methods are required to implement a datagram based query\/response protocol. -data TransportA err addr x y = Transport - { -- | Blocks until an inbound packet is available. Returns 'Nothing' when - -- no more packets are expected due to a shutdown or close event. - -- Otherwise, the packet will be parsed as type /x/ and an origin address - -- /addr/. Parse failure is indicated by the type 'err'. - awaitMessage :: forall a. (Maybe (Either err (x, addr)) -> IO a) -> IO a - -- | Send an /y/ packet to the given destination /addr/. - , sendMessage :: addr -> y -> IO () - -- | Shutdown and clean up any state related to this 'Transport'. - , closeTransport :: IO () - } - -type Transport err addr x = TransportA err addr x x - --- | This function modifies a 'Transport' to use higher-level addresses and --- packet representations. It could be used to change UDP 'ByteString's into --- bencoded syntax trees or to add an encryption layer in which addresses have --- associated public keys. -layerTransportM :: - (x -> addr -> IO (Either err (x', addr'))) - -- ^ Function that attempts to transform a low-level address/packet - -- pair into a higher level representation. - -> (y' -> addr' -> IO (y, addr)) - -- ^ Function to encode a high-level address/packet into a lower level - -- representation. - -> TransportA err addr x y - -- ^ The low-level transport to be transformed. - -> TransportA err addr' x' y' -layerTransportM parse encode tr = - tr { awaitMessage = \kont -> - awaitMessage tr $ \m -> mapM (mapM $ uncurry parse) m >>= kont . fmap join - , sendMessage = \addr' msg' -> do - (msg,addr) <- encode msg' addr' - sendMessage tr addr msg - } - - --- | This function modifies a 'Transport' to use higher-level addresses and --- packet representations. It could be used to change UDP 'ByteString's into --- bencoded syntax trees or to add an encryption layer in which addresses have --- associated public keys. -layerTransport :: - (x -> addr -> Either err (x', addr')) - -- ^ Function that attempts to transform a low-level address/packet - -- pair into a higher level representation. - -> (y' -> addr' -> (y, addr)) - -- ^ Function to encode a high-level address/packet into a lower level - -- representation. - -> TransportA err addr x y - -- ^ The low-level transport to be transformed. - -> TransportA err addr' x' y' -layerTransport parse encode tr = - layerTransportM (\x addr -> return $ parse x addr) - (\x' addr' -> return $ encode x' addr') - tr - --- | Paritions a 'Transport' into two higher-level transports. Note: An 'MVar' --- is used to share the same underlying socket, so be sure to fork a thread for --- both returned 'Transport's to avoid hanging. -partitionTransport :: ((b,a) -> Either (x,xaddr) (b,a)) - -> ((x,xaddr) -> Maybe (b,a)) - -> Transport err a b - -> IO (Transport err xaddr x, Transport err a b) -partitionTransport parse encodex tr = - partitionTransportM (return . parse) (return . encodex) tr - --- | Paritions a 'Transport' into two higher-level transports. Note: An 'MVar' --- is used to share the same underlying socket, so be sure to fork a thread for --- both returned 'Transport's to avoid hanging. -partitionTransportM :: ((b,a) -> IO (Either (x,xaddr) (b,a))) - -> ((x,xaddr) -> IO (Maybe (b,a))) - -> Transport err a b - -> IO (Transport err xaddr x, Transport err a b) -partitionTransportM parse encodex tr = do - mvar <- newEmptyMVar - let xtr = tr { awaitMessage = \kont -> fix $ \again -> do - awaitMessage tr $ \m -> case m of - Just (Right msg) -> parse msg >>= - either (kont . Just . Right) - (\y -> putMVar mvar y >> again) - Just (Left e) -> kont $ Just (Left e) - Nothing -> kont Nothing - , sendMessage = \addr' msg' -> do - msg_addr <- encodex (msg',addr') - mapM_ (uncurry . flip $ sendMessage tr) msg_addr - } - ytr = Transport - { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right - , sendMessage = sendMessage tr - , closeTransport = return () - } - return (xtr, ytr) - -partitionAndForkTransport :: - (dst -> msg -> IO ()) - -> ((b,a) -> IO (Either (x,xaddr) (b,a))) - -> ((x,xaddr) -> IO (Maybe (Either (msg,dst) (b,a)))) - -> Transport err a b - -> IO (Transport err xaddr x, Transport err a b) -partitionAndForkTransport forkedSend parse encodex tr = do - mvar <- newEmptyMVar - let xtr = tr { awaitMessage = \kont -> fix $ \again -> do - awaitMessage tr $ \m -> case m of - Just (Right msg) -> parse msg >>= - either (kont . Just . Right) - (\y -> putMVar mvar y >> again) - Just (Left e) -> kont $ Just (Left e) - Nothing -> kont Nothing - , sendMessage = \addr' msg' -> do - msg_addr <- encodex (msg',addr') - case msg_addr of - Just (Right (b,a)) -> sendMessage tr a b - Just (Left (msg,dst)) -> forkedSend dst msg - Nothing -> return () - } - ytr = Transport - { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right - , sendMessage = sendMessage tr - , closeTransport = return () - } - return (xtr, ytr) - --- | --- * f add x --> Nothing, consume x --- --> Just id, leave x to a different handler --- --> Just g, apply g to x and leave that to a different handler -addHandler :: (err -> IO ()) -> (addr -> x -> IO (Maybe (x -> x))) -> Transport err addr x -> Transport err addr x -addHandler onParseError f tr = tr - { awaitMessage = \kont -> fix $ \eat -> awaitMessage tr $ \m -> do - case m of - Just (Right (x, addr)) -> f addr x >>= maybe eat (kont . Just . Right . (, addr) . ($ x)) - Just (Left e ) -> onParseError e >> kont (Just $ Left e) - Nothing -> kont $ Nothing - } - --- | Modify a 'Transport' to invoke an action upon every received packet. -onInbound :: (addr -> x -> IO ()) -> Transport err addr x -> Transport err addr x -onInbound f tr = addHandler (const $ return ()) (\addr x -> f addr x >> return (Just id)) tr - --- * Using a query\/response client. - --- | Fork a thread that handles inbound packets. The returned action may be used --- to terminate the thread and clean up any related state. --- --- Example usage: --- --- > -- Start client. --- > quitServer <- forkListener "listener" (clientNet client) --- > -- Send a query q, recieve a response r. --- > r <- sendQuery client method q --- > -- Quit client. --- > quitServer -forkListener :: String -> Transport err addr x -> IO (IO ()) -forkListener name client = do - thread_id <- forkIO $ do - myThreadId >>= flip labelThread ("listener."++name) - fix $ awaitMessage client . const - dput XMisc $ "Listener died: " ++ name - return $ do - closeTransport client - killThread thread_id - -asyncQuery_ :: Client err meth tid addr x - -> MethodSerializer tid addr x meth a b - -> a - -> addr - -> (Maybe b -> IO ()) - -> IO (tid,POSIXTime,Int) -asyncQuery_ (Client net d err pending whoami _) meth q addr0 withResponse = do - now <- getPOSIXTime - (tid,addr,expiry) <- atomically $ do - tbl <- readTVar pending - ((tid,addr,expiry), tbl') <- dispatchRegister (tableMethods d) - (methodTimeout meth) - now - (withResponse . fmap (unwrapResponse meth)) - addr0 - tbl - -- (addr,expiry) <- methodTimeout meth tid addr0 - writeTVar pending tbl' - return (tid,addr,expiry) - self <- whoami (Just addr) - mres <- do sendMessage net addr (wrapQuery meth tid self addr q) - return $ Just () - `catchIOError` (\e -> return Nothing) - return (tid,now,expiry) - -asyncQuery :: Show meth => Client err meth tid addr x - -> MethodSerializer tid addr x meth a b - -> a - -> addr - -> (Maybe b -> IO ()) - -> IO () -asyncQuery client meth q addr withResponse0 = do - tm <- getSystemTimerManager - tidvar <- newEmptyMVar - timedout <- registerTimeout tm 1000000 $ do - dput XMisc $ "async TIMEDOUT " ++ show (method meth) - withResponse0 Nothing - tid <- takeMVar tidvar - dput XMisc $ "async TIMEDOUT mvar " ++ show (method meth) - case client of - Client { clientDispatcher = d, clientPending = pending } -> do - atomically $ readTVar pending >>= dispatchCancel (tableMethods d) tid >>= writeTVar pending - (tid,now,expiry) <- asyncQuery_ client meth q addr $ \x -> do - unregisterTimeout tm timedout - withResponse0 x - putMVar tidvar tid - updateTimeout tm timedout expiry - dput XMisc $ "FIN asyncQuery "++show (method meth)++" TIMEOUT="++show expiry - --- | Send a query to a remote peer. Note that this function will always time --- out if 'forkListener' was never invoked to spawn a thread to receive and --- dispatch the response. -sendQuery :: - forall err a b tbl x meth tid addr. - Client err meth tid addr x -- ^ A query/response implementation. - -> MethodSerializer tid addr x meth a b -- ^ Information for marshaling the query. - -> a -- ^ The outbound query. - -> addr -- ^ Destination address of query. - -> IO (Maybe b) -- ^ The response, or 'Nothing' if it timed out. -sendQuery c@(Client net d err pending whoami _) meth q addr0 = do - mvar <- newEmptyMVar - (tid,now,expiry) <- asyncQuery_ c meth q addr0 $ mapM_ (putMVar mvar) - mres <- timeout expiry $ takeMVar mvar - case mres of - Just b -> return $ Just b - Nothing -> do - atomically $ readTVar pending >>= dispatchCancel (tableMethods d) tid >>= writeTVar pending - return Nothing - --- * Implementing a query\/response 'Client'. - --- | All inputs required to implement a query\/response client. -data Client err meth tid addr x = forall tbl. Client - { -- | The 'Transport' used to dispatch and receive packets. - clientNet :: Transport err addr x - -- | Methods for handling inbound packets. - , clientDispatcher :: DispatchMethods tbl err meth tid addr x - -- | Methods for reporting various conditions. - , clientErrorReporter :: ErrorReporter addr x meth tid err - -- | State necessary for routing inbound responses and assigning unique - -- /tid/ values for outgoing queries. - , clientPending :: TVar tbl - -- | An action yielding this client\'s own address. It is invoked once - -- on each outbound and inbound packet. It is valid for this to always - -- return the same value. - -- - -- The argument, if supplied, is the remote address for the transaction. - -- This can be used to maintain consistent aliases for specific peers. - , clientAddress :: Maybe addr -> IO addr - -- | Transform a query /tid/ value to an appropriate response /tid/ - -- value. Normally, this would be the identity transformation, but if - -- /tid/ includes a unique cryptographic nonce, then it should be - -- generated here. - , clientResponseId :: tid -> IO tid - } - --- | An incoming message can be classified into three cases. -data MessageClass err meth tid addr x - = IsQuery meth tid -- ^ An unsolicited query is handled based on it's /meth/ value. Any response - -- should include the provided /tid/ value. - | IsResponse tid -- ^ A response to a outgoing query we associated with a /tid/ value. - | IsUnsolicited (addr -> addr -> IO (Maybe (x -> x))) -- ^ Transactionless informative packet. The io action will be invoked - -- with the source and destination address of a message. If it handles the - -- message, it should return Nothing. Otherwise, it should return a transform - -- (usually /id/) to apply before the next handler examines it. - | IsUnknown err -- ^ None of the above. - --- | Handler for an inbound query of type /x/ from an address of type _addr_. -data MethodHandler err tid addr x = forall a b. MethodHandler - { -- | Parse the query into a more specific type for this method. - methodParse :: x -> Either err a - -- | Serialize the response for transmission, given a context /ctx/ and the origin - -- and destination addresses. - , methodSerialize :: tid -> addr -> addr -> b -> x - -- | Fully typed action to perform upon the query. The remote origin - -- address of the query is provided to the handler. - , methodAction :: addr -> a -> IO b - } - -- | See also 'IsUnsolicited' which likely makes this constructor unnecessary. - | forall a. NoReply - { -- | Parse the query into a more specific type for this method. - methodParse :: x -> Either err a - -- | Fully typed action to perform upon the query. The remote origin - -- address of the query is provided to the handler. - , noreplyAction :: addr -> a -> IO () - } - -contramapAddr :: (a -> b) -> MethodHandler err tid b x -> MethodHandler err tid a x -contramapAddr f (MethodHandler p s a) - = MethodHandler - p - (\tid src dst result -> s tid (f src) (f dst) result) - (\addr arg -> a (f addr) arg) -contramapAddr f (NoReply p a) - = NoReply p (\addr arg -> a (f addr) arg) - - --- | Attempt to invoke a 'MethodHandler' upon a given inbound query. If the --- parse is successful, the returned IO action will construct our reply if --- there is one. Otherwise, a parse err is returned. -dispatchQuery :: MethodHandler err tid addr x -- ^ Handler to invoke. - -> tid -- ^ The transaction id for this query\/response session. - -> addr -- ^ Our own address, to which the query was sent. - -> x -- ^ The query packet. - -> addr -- ^ The origin address of the query. - -> Either err (IO (Maybe x)) -dispatchQuery (MethodHandler unwrapQ wrapR f) tid self x addr = - fmap (\a -> Just . wrapR tid self addr <$> f addr a) $ unwrapQ x -dispatchQuery (NoReply unwrapQ f) tid self x addr = - fmap (\a -> f addr a >> return Nothing) $ unwrapQ x - --- | These four parameters are required to implement an outgoing query. A --- peer-to-peer algorithm will define a 'MethodSerializer' for every 'MethodHandler' that --- might be returned by 'lookupHandler'. -data MethodSerializer tid addr x meth a b = MethodSerializer - { -- | Returns the microseconds to wait for a response to this query being - -- sent to the given address. The /addr/ may also be modified to add - -- routing information. - methodTimeout :: tid -> addr -> STM (addr,Int) - -- | A method identifier used for error reporting. This needn't be the - -- same as the /meth/ argument to 'MethodHandler', but it is suggested. - , method :: meth - -- | Serialize the outgoing query /a/ into a transmittable packet /x/. - -- The /addr/ arguments are, respectively, our own origin address and the - -- destination of the request. The /tid/ argument is useful for attaching - -- auxiliary notations on all outgoing packets. - , wrapQuery :: tid -> addr -> addr -> a -> x - -- | Parse an inbound packet /x/ into a response /b/ for this query. - , unwrapResponse :: x -> b - } - - --- | To dispatch responses to our outbound queries, we require three --- primitives. See the 'transactionMethods' function to create these --- primitives out of a lookup table and a generator for transaction ids. --- --- The type variable /d/ is used to represent the current state of the --- transaction generator and the table of pending transactions. -data TransactionMethods d tid addr x = TransactionMethods - { - -- | Before a query is sent, this function stores an 'MVar' to which the - -- response will be written too. The returned /tid/ is a transaction id - -- that can be used to forget the 'MVar' if the remote peer is not - -- responding. - dispatchRegister :: (tid -> addr -> STM (addr,Int)) -> POSIXTime -> (Maybe x -> IO ()) -> addr -> d -> STM ((tid,addr,Int), d) - -- | This method is invoked when an incoming packet /x/ indicates it is - -- a response to the transaction with id /tid/. The returned IO action - -- will write the packet to the correct 'MVar' thus completing the - -- dispatch. - , dispatchResponse :: tid -> x -> d -> STM (d, IO ()) - -- | When a timeout interval elapses, this method is called to remove the - -- transaction from the table. - , dispatchCancel :: tid -> d -> STM d - } - --- | Construct 'TransactionMethods' methods out of 3 lookup table primitives and a --- function for generating unique transaction ids. -transactionMethods :: - TableMethods t tid -- ^ Table methods to lookup values by /tid/. - -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/. - -> TransactionMethods (g,t (Maybe x -> IO ())) tid addr x -transactionMethods methods generate = transactionMethods' id id methods generate - -microsecondsDiff :: Int -> POSIXTime -microsecondsDiff us = fromIntegral us / 1000000 - --- | Like 'transactionMethods' but allows extra information to be stored in the --- table of pending transactions. This also enables multiple 'Client's to --- share a single transaction table. -transactionMethods' :: - ((Maybe x -> IO ()) -> a) -- ^ store MVar into table entry - -> (a -> Maybe x -> IO void) -- ^ load MVar from table entry - -> TableMethods t tid -- ^ Table methods to lookup values by /tid/. - -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/. - -> TransactionMethods (g,t a) tid addr x -transactionMethods' store load (TableMethods insert delete lookup) generate = TransactionMethods - { dispatchCancel = \tid (g,t) -> return (g, delete tid t) - , dispatchRegister = \getTimeout now v a0 (g,t) -> do - let (tid,g') = generate g - (a,expiry) <- getTimeout tid a0 - let t' = insert tid (store v) (now + microsecondsDiff expiry) t - return ( (tid,a,expiry), (g',t') ) - , dispatchResponse = \tid x (g,t) -> - case lookup tid t of - Just v -> let t' = delete tid t - in return ((g,t'),void $ load v $ Just x) - Nothing -> return ((g,t), return ()) - } - --- | A set of methods necessary for dispatching incoming packets. -data DispatchMethods tbl err meth tid addr x = DispatchMethods - { -- | Classify an inbound packet as a query or response. - classifyInbound :: x -> MessageClass err meth tid addr x - -- | Lookup the handler for a inbound query. - , lookupHandler :: meth -> Maybe (MethodHandler err tid addr x) - -- | Methods for handling incoming responses. - , tableMethods :: TransactionMethods tbl tid addr x - } - --- | These methods indicate what should be done upon various conditions. Write --- to a log file, make debug prints, or simply ignore them. --- --- [ /addr/ ] Address of remote peer. --- --- [ /x/ ] Incoming or outgoing packet. --- --- [ /meth/ ] Method id of incoming or outgoing request. --- --- [ /tid/ ] Transaction id for outgoing packet. --- --- [ /err/ ] Error information, typically a 'String'. -data ErrorReporter addr x meth tid err = ErrorReporter - { -- | Incoming: failed to parse packet. - reportParseError :: err -> IO () - -- | Incoming: no handler for request. - , reportMissingHandler :: meth -> addr -> x -> IO () - -- | Incoming: unable to identify request. - , reportUnknown :: addr -> x -> err -> IO () - } - -ignoreErrors :: ErrorReporter addr x meth tid err -ignoreErrors = ErrorReporter - { reportParseError = \_ -> return () - , reportMissingHandler = \_ _ _ -> return () - , reportUnknown = \_ _ _ -> return () - } - -logErrors :: ( Show addr - , Show meth - ) => ErrorReporter addr x meth tid String -logErrors = ErrorReporter - { reportParseError = \err -> dput XMisc err - , reportMissingHandler = \meth addr x -> dput XMisc $ show addr ++ " --> Missing handler ("++show meth++")" - , reportUnknown = \addr x err -> dput XMisc $ show addr ++ " --> " ++ err - } - -printErrors :: ( Show addr - , Show meth - ) => Handle -> ErrorReporter addr x meth tid String -printErrors h = ErrorReporter - { reportParseError = \err -> hPutStrLn h err - , reportMissingHandler = \meth addr x -> hPutStrLn h $ show addr ++ " --> Missing handler ("++show meth++")" - , reportUnknown = \addr x err -> hPutStrLn h $ show addr ++ " --> " ++ err - } - --- Change the /err/ type for an 'ErrorReporter'. -instance Contravariant (ErrorReporter addr x meth tid) where - -- contramap :: (t5 -> t4) -> ErrorReporter t3 t2 t1 t t4 -> ErrorReporter t3 t2 t1 t t5 - contramap f (ErrorReporter pe mh unk) - = ErrorReporter (\e -> pe (f e)) - mh - (\addr x e -> unk addr x (f e)) - --- | Handle a single inbound packet and then invoke the given continuation. --- The 'forkListener' function is implemented by passing this function to 'fix' --- in a forked thread that loops until 'awaitMessage' returns 'Nothing' or --- throws an exception. -handleMessage :: - Client err meth tid addr x - -> addr - -> x - -> IO (Maybe (x -> x)) -handleMessage (Client net d err pending whoami responseID) addr plain = do - -- Just (Left e) -> do reportParseError err e - -- return $! Just id - -- Just (Right (plain, addr)) -> do - case classifyInbound d plain of - IsQuery meth tid -> case lookupHandler d meth of - Nothing -> do reportMissingHandler err meth addr plain - return $! Just id - Just m -> do - self <- whoami (Just addr) - tid' <- responseID tid - either (\e -> do reportParseError err e - return $! Just id) - (>>= \m -> do mapM_ (sendMessage net addr) m - return $! Nothing) - (dispatchQuery m tid' self plain addr) - IsUnsolicited action -> do - self <- whoami (Just addr) - action self addr - return Nothing - IsResponse tid -> do - action <- atomically $ do - ts0 <- readTVar pending - (ts, action) <- dispatchResponse (tableMethods d) tid plain ts0 - writeTVar pending ts - return action - action - return $! Nothing - IsUnknown e -> do reportUnknown err addr plain e - return $! Just id - -- Nothing -> return $! id - --- * UDP Datagrams. - --- | Access the address family of a given 'SockAddr'. This convenient accessor --- is missing from 'Network.Socket', so I implemented it here. -sockAddrFamily :: SockAddr -> Family -sockAddrFamily (SockAddrInet _ _ ) = AF_INET -sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 -sockAddrFamily (SockAddrUnix _ ) = AF_UNIX -sockAddrFamily _ = AF_CAN -- SockAddrCan constructor deprecated - --- | Packets with an empty payload may trigger EOF exception. --- 'udpTransport' uses this function to avoid throwing in that --- case. -ignoreEOF :: a -> IOError -> IO a -ignoreEOF def e | isEOFError e = pure def - | otherwise = throwIO e - --- | Hard-coded maximum packet size for incoming UDP Packets received via --- 'udpTransport'. -udpBufferSize :: Int -udpBufferSize = 65536 - --- | Wrapper around 'B.sendTo' that silently ignores DoesNotExistError. -saferSendTo :: Socket -> ByteString -> SockAddr -> IO () -saferSendTo sock bs saddr = void (B.sendTo sock bs saddr) - `catch` \e -> - -- sendTo: does not exist (Network is unreachable) - -- Occurs when IPv6 or IPv4 network is not available. - -- Currently, we require -threaded to prevent a forever-hang in this case. - if isDoesNotExistError e - then return () - else throw e - --- | A 'udpTransport' uses a UDP socket to send and receive 'ByteString's. The --- argument is the listen-address for incoming packets. This is a useful --- low-level 'Transport' that can be transformed for higher-level protocols --- using 'layerTransport'. -udpTransport :: SockAddr -> IO (Transport err SockAddr ByteString) -udpTransport bind_address = fst <$> udpTransport' bind_address - --- | Like 'udpTransport' except also returns the raw socket (for broadcast use). -udpTransport' :: SockAddr -> IO (Transport err SockAddr ByteString, Socket) -udpTransport' bind_address = do - let family = sockAddrFamily bind_address - sock <- socket family Datagram defaultProtocol - when (family == AF_INET6) $ do - setSocketOption sock IPv6Only 0 - setSocketOption sock Broadcast 1 - bind sock bind_address - let tr = Transport { - awaitMessage = \kont -> do - r <- handle (ignoreEOF $ Just $ Right (B.empty, SockAddrInet 0 0)) $ do - Just . Right <$!> B.recvFrom sock udpBufferSize - kont $! r - , sendMessage = case family of - AF_INET6 -> \case - (SockAddrInet port addr) -> \bs -> - -- Change IPv4 to 4mapped6 address. - saferSendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0 - addr6 -> \bs -> saferSendTo sock bs addr6 - AF_INET -> \case - (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do - let host4 = toBE32 raw4 - -- Change 4mapped6 to ordinary IPv4. - -- dput XMisc $ "4mapped6 -> "++show (SockAddrInet port host4) - saferSendTo sock bs (SockAddrInet port host4) - addr@(SockAddrInet6 {}) -> \bs -> dput XMisc ("Discarding packet to "++show addr) - addr4 -> \bs -> saferSendTo sock bs addr4 - _ -> \addr bs -> saferSendTo sock bs addr - , closeTransport = close sock - } - return (tr, sock) - -chanTransport :: (addr -> TChan (x, addr)) -> addr -> TChan (x, addr) -> TVar Bool -> Transport err addr x -chanTransport chanFromAddr self achan aclosed = Transport - { awaitMessage = \kont -> do - x <- atomically $ (Just <$> readTChan achan) - `orElse` - (readTVar aclosed >>= check >> return Nothing) - kont $ Right <$> x - , sendMessage = \them bs -> do - atomically $ writeTChan (chanFromAddr them) (bs,self) - , closeTransport = atomically $ writeTVar aclosed True - } - --- | Returns a pair of transports linked together to simulate two computers talking to each other. -testPairTransport :: IO (Transport err SockAddr ByteString, Transport err SockAddr ByteString) -testPairTransport = do - achan <- atomically newTChan - bchan <- atomically newTChan - aclosed <- atomically $ newTVar False - bclosed <- atomically $ newTVar False - let a = SockAddrInet 1 1 - b = SockAddrInet 2 2 - return ( chanTransport (const bchan) a achan aclosed - , chanTransport (const achan) b bchan bclosed ) diff --git a/src/Network/QueryResponse/TCP.hs b/src/Network/QueryResponse/TCP.hs deleted file mode 100644 index bad61727..00000000 --- a/src/Network/QueryResponse/TCP.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -module Network.QueryResponse.TCP where - -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -import GHC.Conc (labelThread) -#endif - -import Control.Arrow -import Control.Concurrent.STM -import Control.Monad -import Data.ByteString (ByteString,hPut) -import Data.Function -import Data.Hashable -import Data.Maybe -import Data.Ord -import Data.Time.Clock.POSIX -import Data.Word -import Network.BSD -import Network.Socket -import System.Timeout -import System.IO -import System.IO.Error - -import DebugTag -import DPut -import Connection.Tcp (socketFamily) -import qualified Data.MinMaxPSQ as MM -import Network.QueryResponse - -data TCPSession st - = PendingTCPSession - | TCPSession - { tcpHandle :: Handle - , tcpState :: st - , tcpThread :: ThreadId - } - -newtype TCPAddress = TCPAddress SockAddr - deriving (Eq,Ord,Show) - -instance Hashable TCPAddress where - hashWithSalt salt (TCPAddress x) = case x of - SockAddrInet port addr -> hashWithSalt salt (fromIntegral port :: Word16,addr) - SockAddrInet6 port b c d -> hashWithSalt salt (fromIntegral port :: Word16,b,c,d) - _ -> 0 - -data TCPCache st = TCPCache - { lru :: TVar (MM.MinMaxPSQ' TCPAddress (Down POSIXTime) (TCPSession st)) - , tcpMax :: Int - } - -data SessionProtocol x y = SessionProtocol - { streamGoodbye :: IO () -- ^ "Goodbye" protocol upon termination. - , streamDecode :: IO (Maybe x) -- ^ Parse inbound messages. - , streamEncode :: y -> IO () -- ^ Serialize outbound messages. - } - -data StreamHandshake addr x y = StreamHandshake - { streamHello :: addr -> Handle -> IO (SessionProtocol x y) -- ^ "Hello" protocol upon fresh connection. - , streamAddr :: addr -> SockAddr - } - -killSession :: TCPSession st -> IO () -killSession PendingTCPSession = return () -killSession TCPSession{tcpThread=t} = killThread t - -showStat r = case r of PendingTCPSession -> "pending." - TCPSession {} -> "established." - -acquireConnection :: MVar (Maybe (Either a (x, addr))) - -> TCPCache (SessionProtocol x y) - -> StreamHandshake addr x y - -> addr - -> Bool - -> IO (Maybe (y -> IO ())) -acquireConnection mvar tcpcache stream addr bDoCon = do - now <- getPOSIXTime - -- dput XTCP $ "acquireConnection 0 " ++ show (streamAddr stream addr) - entry <- atomically $ do - c <- readTVar (lru tcpcache) - let v = MM.lookup' (TCPAddress $ streamAddr stream addr) c - case v of - Nothing | bDoCon -> writeTVar (lru tcpcache) - $ MM.insert' (TCPAddress $ streamAddr stream addr) PendingTCPSession (Down now) c - | otherwise -> return () - Just (tm, v) -> modifyTVar' (lru tcpcache) $ MM.insert' (TCPAddress $ streamAddr stream addr) v (Down now) - return v - -- dput XTCP $ "acquireConnection 1 " ++ show (streamAddr stream addr, fmap (second showStat) entry) - case entry of - Nothing -> fmap join $ forM (guard bDoCon) $ \() -> do - proto <- getProtocolNumber "tcp" - mh <- catchIOError (do h <- timeout 10000000 $ do - sock <- socket (socketFamily $ streamAddr stream addr) Stream proto - connect sock (streamAddr stream addr) `catchIOError` (\e -> close sock) - h <- socketToHandle sock ReadWriteMode - hSetBuffering h NoBuffering - return h - return h) - $ \e -> return Nothing - ret <- fmap join $ forM mh $ \h -> do - st <- streamHello stream addr h - dput XTCP $ "TCP Connected! " ++ show (streamAddr stream addr) - signal <- newTVarIO False - rthread <- forkIO $ do - atomically (readTVar signal >>= check) - fix $ \loop -> do - x <- streamDecode st - dput XTCP $ "TCP streamDecode " ++ show (streamAddr stream addr) ++ " --> " ++ maybe "Nothing" (const "got") x - case x of - Just u -> do - m <- timeout (1000000) $ putMVar mvar $ Just $ Right (u, addr) - when (isNothing m) $ do - dput XTCP $ "TCP "++show (streamAddr stream addr) ++ " dropped packet." - tryTakeMVar mvar - return () - loop - Nothing -> do - dput XTCP $ "TCP disconnected: " ++ show (streamAddr stream addr) - do atomically $ modifyTVar' (lru tcpcache) - $ MM.delete (TCPAddress $ streamAddr stream addr) - c <- atomically $ readTVar (lru tcpcache) - now <- getPOSIXTime - forM_ (zip [1..] $ MM.toList c) $ \(i,MM.Binding (TCPAddress addr) r (Down tm)) -> do - dput XTCP $ unwords [show i ++ ".", "Still connected:", show addr, show (now - tm), showStat r] - hClose h - let showAddr a = show (streamAddr stream a) - labelThread rthread ("tcp:"++showAddr addr) - let v = TCPSession - { tcpHandle = h - , tcpState = st - , tcpThread = rthread - } - t <- getPOSIXTime - retires <- atomically $ do - c <- readTVar (lru tcpcache) - let (rs,c') = MM.takeView (tcpMax tcpcache) - $ MM.insert' (TCPAddress $ streamAddr stream addr) v (Down t) c - writeTVar (lru tcpcache) c' - writeTVar signal True - return rs - forM_ retires $ \(MM.Binding (TCPAddress k) r _) -> void $ forkIO $ do - myThreadId >>= flip labelThread ("tcp-close:"++show k) - dput XTCP $ "TCP dropped: " ++ show k - killSession r - case r of TCPSession {tcpState=st,tcpHandle=h} -> do - streamGoodbye st - hClose h - _ -> return () - - return $ Just $ streamEncode st - when (isNothing ret) $ do - atomically $ modifyTVar' (lru tcpcache) $ MM.delete (TCPAddress $ streamAddr stream addr) - return ret - Just (tm, PendingTCPSession) - | not bDoCon -> return Nothing - | otherwise -> fmap join $ timeout 10000000 $ atomically $ do - c <- readTVar (lru tcpcache) - let v = MM.lookup' (TCPAddress $ streamAddr stream addr) c - case v of - Just (_,TCPSession{tcpState=st}) -> return $ Just $ streamEncode st - Nothing -> return Nothing - _ -> retry - Just (tm, v@TCPSession {tcpState=st}) -> return $ Just $ streamEncode st - -closeAll :: TCPCache (SessionProtocol x y) -> StreamHandshake addr x y -> IO () -closeAll tcpcache stream = do - cache <- atomically $ swapTVar (lru tcpcache) MM.empty - forM_ (MM.toList cache) $ \(MM.Binding (TCPAddress addr) r tm) -> do - killSession r - case r of TCPSession{tcpState=st,tcpHandle=h} -> streamGoodbye st >> hClose h - _ -> return () - -tcpTransport :: Int -- ^ maximum number of TCP links to maintain. - -> StreamHandshake addr x y - -> IO (TCPCache (SessionProtocol x y), TransportA err addr x (Bool,y)) -tcpTransport maxcon stream = do - msgvar <- newEmptyMVar - tcpcache <- atomically $ (`TCPCache` maxcon) <$> newTVar (MM.empty) - return $ (,) tcpcache Transport - { awaitMessage = \f -> takeMVar msgvar >>= \x -> f x `catchIOError` (\e -> dput XTCP ("TCP transport stopped. " ++ show e) >> f Nothing) - , sendMessage = \addr (bDoCon,y) -> do - t <- forkIO $ do - msock <- acquireConnection msgvar tcpcache stream addr bDoCon - mapM_ ($ y) msock - `catchIOError` \e -> dput XTCP $ "TCP-send: " ++ show e - labelThread t "tcp-send" - , closeTransport = closeAll tcpcache stream - } diff --git a/src/Network/SessionTransports.hs b/src/Network/SessionTransports.hs deleted file mode 100644 index e9daf6c1..00000000 --- a/src/Network/SessionTransports.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -module Network.SessionTransports - ( Sessions - , initSessions - , newSession - , sessionHandler - ) where - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import qualified Data.IntMap.Strict as IntMap - ;import Data.IntMap.Strict (IntMap) -import qualified Data.Map.Strict as Map - ;import Data.Map.Strict (Map) - -import Network.Address (SockAddr,either4or6) -import Network.QueryResponse -import qualified Data.IntervalSet as S - ;import Data.IntervalSet (IntSet) - -data Sessions x = Sessions - { sessionsByAddr :: TVar (Map SockAddr (IntMap (x -> IO Bool))) - , sessionsById :: TVar (IntMap SockAddr) - , sessionIds :: TVar IntSet - , sessionsSendRaw :: SockAddr -> x -> IO () - } - -initSessions :: (SockAddr -> x -> IO ()) -> IO (Sessions x) -initSessions send = atomically $ do - byaddr <- newTVar Map.empty - byid <- newTVar IntMap.empty - idset <- newTVar S.empty - return Sessions { sessionsByAddr = byaddr - , sessionsById = byid - , sessionIds = idset - , sessionsSendRaw = send - } - - - -rmSession :: Int -> (Maybe (IntMap x)) -> (Maybe (IntMap x)) -rmSession sid Nothing = Nothing -rmSession sid (Just m) = case IntMap.delete sid m of - m' | IntMap.null m' -> Nothing - | otherwise -> Just m' - -newSession :: Sessions raw - -> (addr -> y -> IO raw) - -> (SockAddr -> raw -> IO (Maybe (x, addr))) - -> SockAddr - -> IO (Maybe (Int,TransportA err addr x y)) -newSession Sessions{sessionsByAddr,sessionsById,sessionIds,sessionsSendRaw} unwrap wrap addr0 = do - mvar <- newEmptyMVar - let saddr = -- Canonical in case of 6-mapped-4 addresses. - either id id $ either4or6 addr0 - handlePacket x = do - m <- wrap saddr x - case m of - Nothing -> return False - Just x' -> do putMVar mvar $! Just $! x' - return True - msid <- atomically $ do - msid <- S.nearestOutsider 0 <$> readTVar sessionIds - forM msid $ \sid -> do - modifyTVar' sessionIds $ S.insert sid - modifyTVar' sessionsById $ IntMap.insert sid saddr - modifyTVar' sessionsByAddr $ Map.insertWith IntMap.union saddr - $ IntMap.singleton sid handlePacket - return sid - forM msid $ \sid -> do - let tr = Transport - { awaitMessage = \kont -> do - x <- takeMVar mvar - kont $! Right <$> x - , sendMessage = \addr x -> do - x' <- unwrap addr x - sessionsSendRaw saddr x' - , closeTransport = do - tryTakeMVar mvar - putMVar mvar Nothing - atomically $ do - modifyTVar' sessionIds $ S.delete sid - modifyTVar' sessionsById $ IntMap.delete sid - modifyTVar' sessionsByAddr $ Map.alter (rmSession sid) saddr - } - return (sid,tr) - -sessionHandler :: Sessions x -> (SockAddr -> x -> IO (Maybe (x -> x))) -sessionHandler Sessions{sessionsByAddr} = \addr0 x -> do - let addr = -- Canonical in case of 6-mapped-4 addresses. - either id id $ either4or6 addr0 - dispatch [] = return () - dispatch (f:fs) = do b <- f x - when (not b) $ dispatch fs - fs <- atomically $ Map.lookup addr <$> readTVar sessionsByAddr - mapM_ (dispatch . IntMap.elems) fs - return Nothing -- consume all packets. diff --git a/src/Network/SocketLike.hs b/src/Network/SocketLike.hs deleted file mode 100644 index d533dd7f..00000000 --- a/src/Network/SocketLike.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | --- --- A socket could be used indirectly via a 'System.IO.Handle' or a conduit from --- Michael Snoyman's conduit package. But doing so presents an encapsulation --- problem. Do we allow access to the underlying socket and trust that it wont --- be used in an unsafe way? Or do we protect it at the higher level and deny --- access to various state information? --- --- The 'SocketLike' class enables the approach that provides a safe wrapper to --- the underlying socket and gives access to various state information without --- enabling direct reads or writes. -module Network.SocketLike - ( SocketLike(..) - , RestrictedSocket - , restrictSocket - , restrictHandleSocket - -- * Re-exports - -- - -- | To make the 'SocketLike' methods less awkward to use, the types - -- 'CUInt', 'SockAddr', and 'PortNumber' are re-exported. - , CUInt - , PortNumber - , SockAddr(..) - ) where - -import Network.Socket - ( PortNumber - , SockAddr - ) -import Foreign.C.Types ( CUInt ) - -import qualified Network.Socket as NS -import System.IO (Handle,hClose,hIsOpen) - --- | A safe (mostly read-only) interface to a 'NS.Socket'. Note that despite --- how this class is named, it provides no access to typical 'NS.Socket' uses --- like sending or receiving network packets. -class SocketLike sock where - -- | See 'NS.getSocketName' - getSocketName :: sock -> IO SockAddr - -- | See 'NS.getPeerName' - getPeerName :: sock -> IO SockAddr - -- | See 'NS.getPeerCred' - getPeerCred :: sock -> IO (CUInt, CUInt, CUInt) - -- | See 'NS.socketPort' - socketPort :: sock -> IO PortNumber - -- | See 'NS.sIsConnected' - -- - -- __Warning__: Don't rely on this method if it's possible the socket was - -- converted into a 'Handle'. - sIsConnected :: sock -> IO Bool - -- | See 'NS.sIsBound' - sIsBound :: sock -> IO Bool - -- | See 'NS.sIsListening' - sIsListening :: sock -> IO Bool - -- | See 'NS.sIsReadable' - sIsReadable :: sock -> IO Bool - -- | See 'NS.sIsWritable' - sIsWritable :: sock -> IO Bool - - -- | This is the only exposed write-access method to the - -- underlying state. Usually implemented by 'NS.close' - sClose :: sock -> IO () - -instance SocketLike NS.Socket where - getSocketName = NS.getSocketName - getPeerName = NS.getPeerName - getPeerCred = NS.getPeerCred - socketPort = NS.socketPort -#if MIN_VERSION_network(2,4,0) - sIsConnected = NS.isConnected -- warning: this is always False if the socket - -- was converted to a Handle - sIsBound = NS.isBound - sIsListening = NS.isListening - sIsReadable = NS.isReadable - sIsWritable = NS.isWritable - sClose = NS.close -#else - sIsConnected = NS.sIsConnected -- warning: this is always False if the socket - -- was converted to a Handle - sIsBound = NS.sIsBound - sIsListening = NS.sIsListening - sIsReadable = NS.sIsReadable - sIsWritable = NS.sIsWritable - sClose = NS.sClose -#endif - - --- | An encapsulated socket. Data reads and writes are not possible. -data RestrictedSocket = Restricted (Maybe Handle) NS.Socket deriving Show - -instance SocketLike RestrictedSocket where - getSocketName (Restricted mb sock) = NS.getSocketName sock - getPeerName (Restricted mb sock) = NS.getPeerName sock - getPeerCred (Restricted mb sock) = NS.getPeerCred sock - socketPort (Restricted mb sock) = NS.socketPort sock -#if MIN_VERSION_network(2,4,0) - sIsConnected (Restricted mb sock) = maybe (NS.isConnected sock) (hIsOpen) mb - sIsBound (Restricted mb sock) = NS.isBound sock - sIsListening (Restricted mb sock) = NS.isListening sock - sIsReadable (Restricted mb sock) = NS.isReadable sock - sIsWritable (Restricted mb sock) = NS.isWritable sock - sClose (Restricted mb sock) = maybe (NS.close sock) (\h -> hClose h >> NS.close sock) mb -#else - sIsConnected (Restricted mb sock) = maybe (NS.sIsConnected sock) (hIsOpen) mb - sIsBound (Restricted mb sock) = NS.sIsBound sock - sIsListening (Restricted mb sock) = NS.sIsListening sock - sIsReadable (Restricted mb sock) = NS.sIsReadable sock - sIsWritable (Restricted mb sock) = NS.sIsWritable sock - sClose (Restricted mb sock) = maybe (NS.sClose sock) (\h -> hClose h >> NS.sClose sock) mb -#endif - --- | Create a 'RestrictedSocket' that explicitly disallows sending or --- receiving data. -restrictSocket :: NS.Socket -> RestrictedSocket -restrictSocket socket = Restricted Nothing socket - --- | Build a 'RestrictedSocket' for which 'sClose' will close the given --- 'Handle'. It is intended that this 'Handle' was obtained via --- 'NS.socketToHandle'. -restrictHandleSocket :: Handle -> NS.Socket -> RestrictedSocket -restrictHandleSocket h socket = Restricted (Just h) socket diff --git a/src/Network/StreamServer.hs b/src/Network/StreamServer.hs deleted file mode 100644 index 80ed4ee2..00000000 --- a/src/Network/StreamServer.hs +++ /dev/null @@ -1,154 +0,0 @@ --- | This module implements a bare-bones TCP or Unix socket server. -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -module Network.StreamServer - ( streamServer - , ServerHandle - , ServerConfig(..) - , withSession - , quitListening - , dummyServerHandle - , listenSocket - ) where - -import Data.Monoid -import Network.Socket as Socket -import System.Directory (removeFile) -import System.IO - ( IOMode(..) - , stderr - , hFlush - ) -import Control.Monad -import Control.Monad.Fix (fix) -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument - ( forkIO, threadDelay, ThreadId, mkWeakThreadId, labelThread, myThreadId - , killThread ) -#else -import GHC.Conc (labelThread) -import Control.Concurrent - ( forkIO, threadDelay, ThreadId, mkWeakThreadId, myThreadId - , killThread ) -#endif -import Control.Exception (handle,finally) -import System.IO.Error (tryIOError) -import System.Mem.Weak -import System.IO.Error - --- import Data.Conduit -import System.IO (Handle) -import Control.Concurrent.MVar (newMVar) - -import Network.SocketLike -import DPut -import DebugTag - -data ServerHandle = ServerHandle Socket (Weak ThreadId) - -listenSocket :: ServerHandle -> RestrictedSocket -listenSocket (ServerHandle sock _) = restrictSocket sock - --- | Create a useless do-nothing 'ServerHandle'. -dummyServerHandle :: IO ServerHandle -dummyServerHandle = do - mvar <- newMVar Closed - let sock = MkSocket 0 AF_UNSPEC NoSocketType 0 mvar - thread <- mkWeakThreadId <=< forkIO $ return () - return (ServerHandle sock thread) - -removeSocketFile :: SockAddr -> IO () -removeSocketFile (SockAddrUnix fname) = removeFile fname -removeSocketFile _ = return () - --- | Terminate the server accept-loop. Call this to shut down the server. -quitListening :: ServerHandle -> IO () -quitListening (ServerHandle socket acceptThread) = - finally (Socket.getSocketName socket >>= removeSocketFile) - (do mapM_ killThread =<< deRefWeak acceptThread - Socket.close socket) - - --- | It's 'bshow' instead of 'show' to enable swapping in a 'ByteString' --- variation. (This is not exported.) -bshow :: Show a => a -> String -bshow e = show e - --- | Send a string to stderr. Not exported. Default 'serverWarn' when --- 'withSession' is used to configure the server. -warnStderr :: String -> IO () -warnStderr str = dput XMisc str >> hFlush stderr - -data ServerConfig = ServerConfig - { serverWarn :: String -> IO () - -- ^ Action to report warnings and errors. - , serverSession :: RestrictedSocket -> Int -> Handle -> IO () - -- ^ Action to handle interaction with a client - } - --- | Initialize a 'ServerConfig' using the provided session handler. -withSession :: (RestrictedSocket -> Int -> Handle -> IO ()) -> ServerConfig -withSession session = ServerConfig warnStderr session - --- | Launch a thread to listen at the given bind address and dispatch --- to session handler threads on every incoming connection. Supports --- IPv4 and IPv6, TCP and unix sockets. --- --- The returned handle can be used with 'quitListening' to terminate the --- thread and prevent any new sessions from starting. Currently active --- session threads will not be terminated or signaled in any way. -streamServer :: ServerConfig -> [SockAddr] -> IO ServerHandle -streamServer cfg addrs = do - let warn = serverWarn cfg - family = case addrs of - SockAddrInet {}:_ -> AF_INET - SockAddrInet6 {}:_ -> AF_INET6 - SockAddrUnix {}:_ -> AF_UNIX - [] -> AF_INET6 - sock <- socket family Stream 0 - setSocketOption sock ReuseAddr 1 - let tryBind addr next _ = do - tryIOError (removeSocketFile addr) - bind sock addr - `catchIOError` \e -> next (Just e) - fix $ \loop -> let again mbe = do - forM_ mbe $ \e -> warn $ "bind-error: " <> bshow addrs <> " " <> bshow e - threadDelay 5000000 - loop - in foldr tryBind again addrs Nothing - listen sock maxListenQueue - thread <- mkWeakThreadId <=< forkIO $ do - myThreadId >>= flip labelThread "StreamServer.acceptLoop" - acceptLoop cfg sock 0 - return (ServerHandle sock thread) - --- | Not exported. This, combined with 'acceptException' form a mutually --- recursive loop that handles incoming connections. To quit the loop, the --- socket must be closed by 'quitListening'. -acceptLoop :: ServerConfig -> Socket -> Int -> IO () -acceptLoop cfg sock n = handle (acceptException cfg n sock) $ do - con <- accept sock - let conkey = n + 1 - h <- socketToHandle (fst con) ReadWriteMode - forkIO $ do - myThreadId >>= flip labelThread "StreamServer.session" - serverSession cfg (restrictHandleSocket h (fst con)) conkey h - acceptLoop cfg sock (n + 1) - -acceptException :: ServerConfig -> Int -> Socket -> IOError -> IO () -acceptException cfg n sock ioerror = do - Socket.close sock - case show (ioeGetErrorType ioerror) of - "resource exhausted" -> do -- try again - serverWarn cfg $ ("acceptLoop: resource exhasted") - threadDelay 500000 - acceptLoop cfg sock (n + 1) - "invalid argument" -> do -- quit on closed socket - return () - message -> do -- unexpected exception - serverWarn cfg $ ("acceptLoop: "<>bshow message) - return () - diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs deleted file mode 100644 index 98c03b80..00000000 --- a/src/Network/Tox.hs +++ /dev/null @@ -1,456 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -module Network.Tox where - -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -#endif -import Control.Concurrent.STM -import Control.Exception (throwIO) -import Control.Monad -import Crypto.PubKey.Curve25519 -import Crypto.Random -import Data.Bits.ByteString () -import qualified Data.ByteString as B - ;import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as C8 -import Data.Data -import Data.Functor.Identity -import Data.Functor.Contravariant -import Data.Maybe -import qualified Data.MinMaxPSQ as MinMaxPSQ -import qualified Data.Serialize as S -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Word -import Network.Socket -import System.Endian -import System.IO.Error - -import Data.TableMethods -import qualified Data.Word64Map -import Network.BitTorrent.DHT.Token as Token -import qualified Data.Wrapper.PSQ as PSQ -import System.Global6 -import Network.Address (WantIP (..),IP,getBindAddress) -import qualified Network.Kademlia.Routing as R -import Network.QueryResponse -import Crypto.Tox -import Data.Word64Map (fitsInInt) -import qualified Data.Word64Map (empty) -import Network.Kademlia.Bootstrap (forkPollForRefresh, bootstrap) -import Network.Tox.Crypto.Transport (Handshake(..),CryptoPacket) -import qualified Network.Tox.DHT.Handlers as DHT -import qualified Network.Tox.DHT.Transport as DHT -import Network.Tox.NodeId -import qualified Network.Tox.Onion.Handlers as Onion -import qualified Network.Tox.Onion.Transport as Onion -import Network.Tox.Transport -import Network.Tox.TCP (tcpClient) -import OnionRouter -import Network.Tox.ContactInfo -import Text.XXD -import DPut -import DebugTag -import TCPProber -import Network.Tox.Avahi -import Network.Tox.Session -import qualified Data.Tox.Relay as TCP -import Network.Tox.Relay -import Network.SessionTransports -import Network.Kademlia.Search -import HandshakeCache - -updateIP :: TVar (R.BucketList NodeInfo) -> SockAddr -> STM () -updateIP tblvar a = do - bkts <- readTVar tblvar - case nodeInfo (nodeId (R.thisNode bkts)) a of - Right ni -> writeTVar tblvar (bkts { R.thisNode = ni }) - Left _ -> return () - -genNonce24 :: DRG g => - TVar (g, pending) -> DHT.TransactionId -> IO DHT.TransactionId -genNonce24 var (DHT.TransactionId nonce8 _) = atomically $ do - (g,pending) <- readTVar var - let (bs, g') = randomBytesGenerate 24 g - writeTVar var (g',pending) - return $ DHT.TransactionId nonce8 (Nonce24 bs) - - -gen :: forall gen. DRG gen => gen -> (DHT.TransactionId, gen) -gen g = let (bs, g') = randomBytesGenerate 24 g - (ws, g'') = randomBytesGenerate 8 g' - Right w = S.runGet S.getWord64be ws - in ( DHT.TransactionId (Nonce8 w) (Nonce24 bs), g'' ) - -intKey :: DHT.TransactionId -> Int -intKey (DHT.TransactionId (Nonce8 w) _) = fromIntegral w - -w64Key :: DHT.TransactionId -> Word64 -w64Key (DHT.TransactionId (Nonce8 w) _) = w - -nonceKey :: DHT.TransactionId -> Nonce8 -nonceKey (DHT.TransactionId n _) = n - --- | Return my own address. -myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets - -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets - -> Maybe NodeInfo -- ^ Interested remote address - -> IO NodeInfo -myAddr routing4 routing6 maddr = atomically $ do - let var = case flip DHT.prefer4or6 Nothing <$> maddr of - Just Want_IP6 -> routing4 - _ -> routing6 - a <- readTVar var - return $ R.thisNode a - -newClient :: (DRG g, Show addr, Show meth) => - g -> Transport String addr x - -> (Client String meth DHT.TransactionId addr x - -> x - -> MessageClass String meth DHT.TransactionId addr x) - -> (Maybe addr -> IO addr) - -> (Client String meth DHT.TransactionId addr x - -> meth - -> Maybe (MethodHandler String DHT.TransactionId addr x)) - -> (forall d. TransactionMethods d DHT.TransactionId addr x - -> TransactionMethods d DHT.TransactionId addr x) - -> (Client String meth DHT.TransactionId addr x - -> Transport String addr x -> Transport String addr x) - -> IO (Client String meth DHT.TransactionId addr x) -newClient drg net classify selfAddr handlers modifytbl modifynet = do - -- If we have 8-byte keys for IntMap, then use it for transaction lookups. - -- Otherwise, use ordinary Map. The details of which will be hidden by an - -- existential closure (see mkclient below). - -- - tblvar <- - if fitsInInt (Proxy :: Proxy Word64) - then do - let intmapT = transactionMethods (contramap intKey intMapMethods) gen - intmap_var <- atomically $ newTVar (drg, mempty) - return $ Right (intmapT,intmap_var) - else do - let word64mapT = transactionMethods (contramap w64Key w64MapMethods) gen - map_var <- atomically $ newTVar (drg, Data.Word64Map.empty) - return $ Left (word64mapT,map_var) - let dispatch tbl var handlers client = DispatchMethods - { classifyInbound = classify client - , lookupHandler = handlers -- var - , tableMethods = modifytbl tbl - } - eprinter = logErrors -- printErrors stderr - mkclient (tbl,var) handlers = - let client = Client - { clientNet = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net - , clientDispatcher = dispatch tbl var (handlers client) client - , clientErrorReporter = eprinter - , clientPending = var - , clientAddress = selfAddr - , clientResponseId = genNonce24 var - } - in client - return $ either mkclient mkclient tblvar handlers - -data Tox extra = Tox - { toxDHT :: DHT.Client - , toxOnion :: Onion.Client RouteId - , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData) - , toxCrypto :: Transport String SockAddr (CryptoPacket Encrypted) - , toxHandshakes :: Transport String SockAddr (Handshake Encrypted) - , toxHandshakeCache :: HandshakeCache - , toxCryptoKeys :: TransportCrypto - , toxRouting :: DHT.Routing - , toxTokens :: TVar SessionTokens - , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys - , toxOnionRoutes :: OnionRouter - , toxContactInfo :: ContactInfo extra - , toxAnnounceToLan :: IO () - , toxBindAddress :: SockAddr - } - - - --- | Create a DHTPublicKey packet to send to a remote contact. -getContactInfo :: Tox extra -> IO DHT.DHTPublicKey -getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do - r4 <- readTVar $ DHT.routing4 toxRouting - r6 <- readTVar $ DHT.routing6 toxRouting - nonce <- transportNewNonce toxCryptoKeys - let self = nodeId n4 - n4 = R.thisNode r4 - n6 = R.thisNode r6 - n4s = R.kclosest DHT.toxSpace 4 self r4 - n6s = R.kclosest DHT.toxSpace 4 self r6 - ns = filter (DHT.isGlobal . nodeIP) [n4,n6] - ++ concat (zipWith (\a b -> [a,b]) n4s n6s) - return $ do - timestamp <- round . (* 1000000) <$> getPOSIXTime - return DHT.DHTPublicKey - { dhtpkNonce = timestamp - , dhtpk = id2key self - , dhtpkNodes = DHT.SendNodes $ take 4 ns - } - -isLocalHost :: SockAddr -> Bool -isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001) -isLocalHost _ = False - -addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString -addVerbosity tr = - tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do - forM_ m $ mapM_ $ \(msg,addr) -> do - when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do - mapM_ (\x -> dput XMisc ( (show addr) ++ " --> " ++ x)) - $ xxd 0 msg - kont m - , sendMessage = \addr msg -> do - when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do - mapM_ (\x -> dput XMisc ( (show addr) ++ " <-- " ++ x)) - $ xxd 0 msg - sendMessage tr addr msg - } - -newKeysDatabase :: IO (TVar Onion.AnnouncedKeys) -newKeysDatabase = - atomically $ newTVar $ Onion.AnnouncedKeys PSQ.empty MinMaxPSQ.empty - - -getOnionAlias :: TransportCrypto -> STM NodeInfo -> Maybe (Onion.OnionDestination r) -> IO (Onion.OnionDestination r) -getOnionAlias crypto dhtself remoteNode = atomically $ do - ni <- dhtself - let alias = case remoteNode of - Just (Onion.OnionDestination (Onion.AnnouncingAlias _ uk) _ _) - -> ni { nodeId = key2id uk } - _ -> ni { nodeId = key2id (onionAliasPublic crypto) } - return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing - -newOnionClient :: DRG g => - TransportCrypto - -> Transport String (Onion.OnionDestination RouteId) Onion.Message - -> DHT.Routing - -> TVar SessionTokens - -> TVar Onion.AnnouncedKeys - -> OnionRouter - -> TVar (g, Data.Word64Map.Word64Map a) - -> ((Maybe Onion.Message -> IO ()) -> a) - -> (a -> Maybe Onion.Message -> IO void) - -> Client String - DHT.PacketKind - DHT.TransactionId - (Onion.OnionDestination RouteId) - Onion.Message -newOnionClient crypto net r toks keydb orouter map_var store load = c - where - eprinter = logErrors - c = Client - { clientNet = addHandler (reportParseError eprinter) (handleMessage c) net - , clientDispatcher = DispatchMethods - { classifyInbound = Onion.classify - , lookupHandler = Onion.handlers net r toks keydb - , tableMethods = hookQueries orouter DHT.transactionKey - $ transactionMethods' store load (contramap w64Key w64MapMethods) gen - } - , clientErrorReporter = eprinter - , clientPending = map_var - , clientAddress = getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 r) - , clientResponseId = genNonce24 map_var - } - -newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for. - -> [String] -- ^ Bind-address to listen on. Must provide at least one. - -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) - -> Maybe SecretKey -- ^ Optional DHT secret key to use. - -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. - -> IO (Tox extra) -newTox keydb bindspecs onsess suppliedDHTKey tcp = do - addrs <- mapM (`getBindAddress` True) bindspecs - let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just) - failedBind mbe = do - forM_ mbe $ \e -> do - dput XDHT $ "tox udp bind error: " ++ show addrs ++ " " ++ show e - throwIO e - throwIO $ userError "Tox UDP listen port?" - (udp,sock) <- foldr tryBind failedBind addrs Nothing - addr <- getSocketName sock - (relay,sendTCP) <- tcpRelay addr (\a x -> sendMessage udp a $ S.runPut $ Onion.putRequest x) - tox <- newToxOverTransport keydb addr onsess suppliedDHTKey udp sendTCP - return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) } - --- | This version of 'newTox' is useful for automated tests using 'testPairTransport'. -newToxOverTransport :: TVar Onion.AnnouncedKeys - -> SockAddr - -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) - -> Maybe SecretKey - -> Onion.UDPTransport - -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. - -> IO (Tox extra) -newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do - roster <- newContactInfo - crypto0 <- newCrypto - let -- patch in supplied DHT key - crypto1 = fromMaybe crypto0 $do - k <- suppliedDHTKey - return crypto0 - { transportSecret = k - , transportPublic = toPublic k - } - -- patch in newly allocated roster state. - crypto = crypto1 { userKeys = myKeyPairs roster } - forM_ suppliedDHTKey $ \k -> do - maybe (dput XMisc "failed to encode suppliedDHTKey") - (dputB XMisc . C8.append "Using suppliedDHTKey: ") - $ encodeSecret k - - drg <- drgNew - let lookupClose _ = return Nothing - - mkrouting <- DHT.newRouting addr crypto updateIP updateIP - (orouter,otbl) <- newOnionRouter crypto (dput XRoutes) - (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) - <- toxTransport crypto orouter lookupClose udp - (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x)) - tcp - sessions <- initSessions (sendMessage cryptonet) - - let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt - tbl4 = DHT.routing4 $ mkrouting (error "missing client") - tbl6 = DHT.routing6 $ mkrouting (error "missing client") - updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr - dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id - (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net) - - hscache <- newHandshakeCache crypto (sendMessage handshakes) - let sparams = SessionParams - { spCrypto = crypto - , spSessions = sessions - , spGetSentHandshake = getSentHandshake hscache - , spOnNewSession = onNewSession roster addr - } - - -- TODO: Refactor so that these threads are forked when 'forkTox' is invoked. - -- This function should only initialize state. - orouter' <- forkRouteBuilder orouter - $ \nid ni -> fmap (\(_,ns,_)->ns) - <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid ni - - toks <- do - nil <- nullSessionTokens - atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids. - let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt - let onionclient = newOnionClient crypto onionnet (mkrouting dhtclient) toks keydb orouter' otbl - Right $ \case - Right v -> v - Left v -> \_ -> - dput XUnexpected "TCP-sent onion query got response over UDP?" - - return Tox - { toxDHT = dhtclient - , toxOnion = onionclient - , toxToRoute = onInbound (updateContactInfo roster) dtacrypt - , toxCrypto = addHandler (dput XMisc) (sessionHandler sessions) cryptonet - , toxHandshakes = addHandler (dput XMisc) (handshakeH sparams) handshakes - , toxHandshakeCache = hscache - , toxCryptoKeys = crypto - , toxRouting = mkrouting dhtclient - , toxTokens = toks - , toxAnnouncedKeys = keydb - , toxOnionRoutes = orouter' -- TODO: see above - , toxContactInfo = roster - , toxAnnounceToLan = return () - , toxBindAddress = addr - } - -onionTimeout :: Tox extra -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int) -onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od - -routing4nodeInfo :: DHT.Routing -> IO NodeInfo -routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv - -dnssdAnnounce :: Tox extra -> IO () -dnssdAnnounce tox = do - ni <- routing4nodeInfo (toxRouting tox) - keys <- fmap (key2id . snd) <$> atomically (userKeys $ toxCryptoKeys tox) - announceToxService (nodePort ni) (nodeId ni) (listToMaybe keys) - -dnssdDiscover :: Tox extra -> NodeInfo -> (Maybe NodeId) -> IO () -dnssdDiscover tox ni toxid = do - acts <- atomically $ readTVar $ accounts $ toxContactInfo tox - now <- getPOSIXTime - forM toxid $ \tid -> - forM acts $ \act -> - atomically $ setContactAddr now (id2key tid) ni act - - void $ DHT.ping (toxDHT tox) ni - --- | Returns: --- --- * action to shutdown this node, terminating all threads. --- --- * action to bootstrap an IPv4 Kademlia table. --- --- * action to bootstrap an IPv6 Kademlia table. -forkTox :: Tox extra -> Bool -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ()) -forkTox tox with_avahi = do - quitHs <- forkListener "toxHandshakes" (toxHandshakes tox) - quitToRoute <- forkListener "toxToRoute" (toxToRoute tox) - quitOnion <- forkListener "toxOnion" (clientNet $ toxOnion tox) - quitDHT <- forkListener "toxDHT" (clientNet $ toxDHT tox) - quitNC <- forkListener "toxCrypto" (toxCrypto tox) - quitTCP <- forkListener "relay-client" (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox) - quitAvahi <- if with_avahi then do - forkPollForRefresh (DHT.refresher4 $ toxRouting tox) - forkPollForRefresh (DHT.refresher6 $ toxRouting tox) - dnssdIn <- forkIO $ queryToxService (dnssdDiscover tox) - dnssdOut <- forkIO $ dnssdAnnounce tox - labelThread dnssdIn "tox-avahi-monitor" - labelThread dnssdOut "tox-avahi-publish" - return $ forM_ [dnssdIn,dnssdOut] killThread - else return $ return () - keygc <- Onion.forkAnnouncedKeysGC (toxAnnouncedKeys tox) - return ( do quitAvahi - killThread keygc - quitNC - quitDHT - quitOnion - quitTCP - quitRouteBuilder (toxOnionRoutes tox) - quitToRoute - quitHs - , bootstrap (DHT.refresher4 $ toxRouting tox) - , bootstrap (DHT.refresher6 $ toxRouting tox) - ) - --- TODO: Don't export this. The exported interface is 'toxAnnounceToLan'. -announceToLan :: Socket -> NodeId -> IO () -announceToLan sock nid = do - addrs <- broadcastAddrs - forM_ addrs $ \addr -> do - (broadcast_info:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }) - (Just addr) - (Just "33445") - let broadcast = addrAddress broadcast_info - bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid) - dput XLan $ show broadcast ++ " <-- LanAnnounce " ++ show nid - saferSendTo sock bs broadcast - - -toxQSearch :: Tox extra -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Onion.Rendezvous -toxQSearch tox = Onion.toxidSearch (onionTimeout tox) (toxCryptoKeys tox) (toxOnion 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 - - - diff --git a/src/Network/UPNP.hs b/src/Network/UPNP.hs deleted file mode 100644 index 01d222bf..00000000 --- a/src/Network/UPNP.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Network.UPNP where - -import Data.Maybe -import Network.Address (sockAddrPort) -import Network.Socket -import System.Directory -import System.Process as Process -import DPut -import DebugTag - -protocols :: SocketType -> [String] -protocols Stream = ["tcp"] -protocols Datagram = ["udp"] -protocols _ = ["udp","tcp"] - -upnpc :: FilePath -upnpc = "/usr/bin/upnpc" - --- | Invokes the miniupnpc command line program to request ports from a UPNP --- wifi router. Returns the process handle on success. -requestPorts :: String -- ^ Description stored on router. - -> [(SocketType, SockAddr)] -- ^ Protocol-port pairs to request. - -> IO (Maybe ProcessHandle) -requestPorts description binds = do - let requests = do - (stype,saddr) <- binds - proto <- protocols stype - port <- maybeToList (sockAddrPort saddr) - [ show port, proto ] - bail = return Nothing - case requests of - [] -> bail - _ -> do - gotMiniUPNPC <- doesFileExist upnpc - if gotMiniUPNPC then do - phandle <- spawnProcess upnpc $ "-e": description : "-r" : requests - return $ Just phandle - else do - dput XMisc $ "Warning: unable to find miniupnpc client at "++upnpc++"." - bail -- cgit v1.2.3