diff options
Diffstat (limited to 'dht/src/Network')
27 files changed, 8381 insertions, 0 deletions
diff --git a/dht/src/Network/BitTorrent/DHT/ContactInfo.hs b/dht/src/Network/BitTorrent/DHT/ContactInfo.hs new file mode 100644 index 00000000..ec7e6658 --- /dev/null +++ b/dht/src/Network/BitTorrent/DHT/ContactInfo.hs | |||
@@ -0,0 +1,254 @@ | |||
1 | {-# LANGUAGE BangPatterns #-} | ||
2 | module Network.BitTorrent.DHT.ContactInfo | ||
3 | ( PeerStore | ||
4 | , PeerAddr(..) | ||
5 | , Network.BitTorrent.DHT.ContactInfo.lookup | ||
6 | , Network.BitTorrent.DHT.ContactInfo.freshPeers | ||
7 | , Network.BitTorrent.DHT.ContactInfo.insertPeer | ||
8 | , deleteOlderThan | ||
9 | , knownSwarms | ||
10 | ) where | ||
11 | |||
12 | import Control.Applicative | ||
13 | import Data.Default | ||
14 | import Data.List as L | ||
15 | import Data.Maybe | ||
16 | import Data.HashMap.Strict as HM | ||
17 | import Data.Serialize | ||
18 | import Data.Semigroup | ||
19 | import Data.Wrapper.PSQ as PSQ | ||
20 | import Data.Time.Clock.POSIX | ||
21 | import Data.ByteString (ByteString) | ||
22 | import Data.Word | ||
23 | |||
24 | import Data.Torrent | ||
25 | import Network.Address | ||
26 | |||
27 | -- {- | ||
28 | -- import Data.HashMap.Strict as HM | ||
29 | -- | ||
30 | -- import Data.Torrent.InfoHash | ||
31 | -- import Network.Address | ||
32 | -- | ||
33 | -- -- increase prefix when table is too large | ||
34 | -- -- decrease prefix when table is too small | ||
35 | -- -- filter outdated peers | ||
36 | -- | ||
37 | -- {----------------------------------------------------------------------- | ||
38 | -- -- PeerSet | ||
39 | -- -----------------------------------------------------------------------} | ||
40 | -- | ||
41 | -- type PeerSet a = [(PeerAddr, NodeInfo a, Timestamp)] | ||
42 | -- | ||
43 | -- -- compare PSQueue vs Ordered list | ||
44 | -- | ||
45 | -- takeNewest :: PeerSet a -> [PeerAddr] | ||
46 | -- takeNewest = undefined | ||
47 | -- | ||
48 | -- dropOld :: Timestamp -> PeerSet a -> PeerSet a | ||
49 | -- dropOld = undefined | ||
50 | -- | ||
51 | -- insert :: PeerAddr -> Timestamp -> PeerSet a -> PeerSet a | ||
52 | -- insert = undefined | ||
53 | -- | ||
54 | -- type Mask = Int | ||
55 | -- type Size = Int | ||
56 | -- type Timestamp = Int | ||
57 | -- | ||
58 | -- {----------------------------------------------------------------------- | ||
59 | -- -- InfoHashMap | ||
60 | -- -----------------------------------------------------------------------} | ||
61 | -- | ||
62 | -- -- compare handwritten prefix tree versus IntMap | ||
63 | -- | ||
64 | -- data Tree a | ||
65 | -- = Nil | ||
66 | -- | Tip !InfoHash !(PeerSet a) | ||
67 | -- | Bin !InfoHash !Mask !Size !Timestamp (Tree a) (Tree a) | ||
68 | -- | ||
69 | -- insertTree :: InfoHash -> a -> Tree a -> Tree a | ||
70 | -- insertTree = undefined | ||
71 | -- | ||
72 | -- type Prio = Int | ||
73 | -- | ||
74 | -- --shrink :: ContactInfo ip -> Int | ||
75 | -- shrink Nil = Nil | ||
76 | -- shrink (Tip _ _) = undefined | ||
77 | -- shrink (Bin _ _) = undefined | ||
78 | -- | ||
79 | -- {----------------------------------------------------------------------- | ||
80 | -- -- InfoHashMap | ||
81 | -- -----------------------------------------------------------------------} | ||
82 | -- | ||
83 | -- -- compare new design versus HashMap | ||
84 | -- | ||
85 | -- data IntMap k p a | ||
86 | -- type ContactInfo = Map InfoHash Timestamp (Set (PeerAddr IP) Timestamp) | ||
87 | -- | ||
88 | -- data ContactInfo ip = PeerStore | ||
89 | -- { maxSize :: Int | ||
90 | -- , prefixSize :: Int | ||
91 | -- , thisNodeId :: NodeId | ||
92 | -- | ||
93 | -- , count :: Int -- ^ Cached size of the 'peerSet' | ||
94 | -- , peerSet :: HashMap InfoHash [PeerAddr ip] | ||
95 | -- } | ||
96 | -- | ||
97 | -- size :: ContactInfo ip -> Int | ||
98 | -- size = undefined | ||
99 | -- | ||
100 | -- prefixSize :: ContactInfo ip -> Int | ||
101 | -- prefixSize = undefined | ||
102 | -- | ||
103 | -- lookup :: InfoHash -> ContactInfo ip -> [PeerAddr ip] | ||
104 | -- lookup = undefined | ||
105 | -- | ||
106 | -- insert :: InfoHash -> PeerAddr ip -> ContactInfo ip -> ContactInfo ip | ||
107 | -- insert = undefined | ||
108 | -- | ||
109 | -- -- | Limit in size. | ||
110 | -- prune :: NodeId -> Int -> ContactInfo ip -> ContactInfo ip | ||
111 | -- prune pref targetSize Nil = Nil | ||
112 | -- prune pref targetSize (Tip _ _) = undefined | ||
113 | -- | ||
114 | -- -- | Remove expired entries. | ||
115 | -- splitGT :: Timestamp -> ContactInfo ip -> ContactInfo ip | ||
116 | -- splitGT = undefined | ||
117 | -- -} | ||
118 | |||
119 | -- | Storage used to keep track a set of known peers in client, | ||
120 | -- tracker or DHT sessions. | ||
121 | newtype PeerStore = PeerStore (HashMap InfoHash SwarmData) | ||
122 | |||
123 | type Timestamp = POSIXTime | ||
124 | |||
125 | data SwarmData = SwarmData | ||
126 | { peers :: !(PSQ PeerAddr Timestamp) | ||
127 | , name :: !(Maybe ByteString) | ||
128 | } | ||
129 | |||
130 | -- | This wrapper will serialize an ip address with a '4' or '6' prefix byte | ||
131 | -- to indicate whether it is IPv4 or IPv6. | ||
132 | -- | ||
133 | -- Note: it does not serialize port numbers. | ||
134 | newtype SerializeAddress a = SerializeAddress { unserializeAddress :: a } | ||
135 | |||
136 | instance Address a => Serialize (SerializeAddress a) where | ||
137 | get = SerializeAddress <$> do | ||
138 | c <- get | ||
139 | case (c::Word8) of | ||
140 | 0x34 -> do ip4 <- get | ||
141 | return $ fromJust $ fromAddr (ip4::IPv4) | ||
142 | 0x36 -> do ip6 <- get | ||
143 | return $ fromJust $ fromAddr (ip6::IPv6) | ||
144 | _ -> return $ error "cannot deserialize non-IP SerializeAddress" | ||
145 | put (SerializeAddress a) | ||
146 | | Just ip4 <- fromAddr a | ||
147 | = put (0x34::Word8) >> put (ip4::IPv4) | ||
148 | | Just ip6 <- fromAddr a | ||
149 | = put (0x36::Word8) >> put (ip6::IPv6) | ||
150 | | otherwise = return $ error "cannot serialize non-IP SerializeAddress" | ||
151 | |||
152 | |||
153 | instance Serialize SwarmData where | ||
154 | get = flip SwarmData <$> get | ||
155 | <*> ( PSQ.fromList . L.map parseAddr <$> get ) | ||
156 | where | ||
157 | parseAddr (pid,addr,port) = PeerAddr { peerId = pid | ||
158 | , peerHost = unserializeAddress addr | ||
159 | , peerPort = port | ||
160 | } | ||
161 | :-> 0 | ||
162 | |||
163 | put SwarmData{..} = do | ||
164 | put name | ||
165 | put $ L.map (\(addr :-> _) -> (peerId addr, SerializeAddress addr, peerPort addr)) | ||
166 | -- XXX: should we serialize the timestamp? | ||
167 | $ PSQ.toList peers | ||
168 | |||
169 | knownSwarms :: PeerStore -> [ (InfoHash, Int, Maybe ByteString) ] | ||
170 | knownSwarms (PeerStore m) = L.map (\(ih,SwarmData q n) -> (ih,PSQ.size q,n)) $ HM.toList m | ||
171 | |||
172 | swarmSingleton :: PeerAddr -> SwarmData | ||
173 | swarmSingleton a = SwarmData | ||
174 | { peers = PSQ.singleton a 0 | ||
175 | , name = Nothing } | ||
176 | |||
177 | swarmInsert :: SwarmData -> SwarmData -> SwarmData | ||
178 | swarmInsert new old = SwarmData | ||
179 | { peers = L.foldl' (\q (a :-> t) -> PSQ.insertWith newerTimeStamp a t q) (peers old) (PSQ.toList $ peers new) | ||
180 | , name = name new <|> name old -- TODO: decodeUtf8' check | ||
181 | } | ||
182 | where | ||
183 | newerTimeStamp newtime oldtime = if newtime > oldtime then newtime else oldtime | ||
184 | |||
185 | isSwarmOccupied :: SwarmData -> Bool | ||
186 | isSwarmOccupied SwarmData{..} = not $ PSQ.null peers | ||
187 | |||
188 | -- | Empty store. | ||
189 | instance Default (PeerStore) where | ||
190 | def = PeerStore HM.empty | ||
191 | {-# INLINE def #-} | ||
192 | |||
193 | instance Semigroup PeerStore where | ||
194 | PeerStore a <> PeerStore b = | ||
195 | PeerStore (HM.unionWith swarmInsert a b) | ||
196 | {-# INLINE (<>) #-} | ||
197 | |||
198 | -- | Monoid under union operation. | ||
199 | instance Monoid PeerStore where | ||
200 | mempty = def | ||
201 | {-# INLINE mempty #-} | ||
202 | |||
203 | mappend (PeerStore a) (PeerStore b) = | ||
204 | PeerStore (HM.unionWith swarmInsert a b) | ||
205 | {-# INLINE mappend #-} | ||
206 | |||
207 | -- | Can be used to store peers between invocations of the client | ||
208 | -- software. | ||
209 | instance Serialize PeerStore where | ||
210 | get = PeerStore . HM.fromList <$> get | ||
211 | put (PeerStore m) = put (L.filter (isSwarmOccupied . snd) $ HM.toList m) | ||
212 | |||
213 | -- | Returns all peers associated with a given info hash. | ||
214 | lookup :: InfoHash -> PeerStore -> [PeerAddr] | ||
215 | lookup ih (PeerStore m) = maybe [] (PSQ.keys . peers) $ HM.lookup ih m | ||
216 | |||
217 | batchSize :: Int | ||
218 | batchSize = 64 | ||
219 | |||
220 | -- | Used in 'get_peers' DHT queries. | ||
221 | freshPeers :: InfoHash -> Timestamp -> PeerStore -> ([PeerAddr], PeerStore) | ||
222 | freshPeers ih tm (PeerStore m) = fromMaybe ([],PeerStore m) $ do | ||
223 | swarm <- HM.lookup ih m | ||
224 | let ps0 = take batchSize $ unfoldr (incomp minView) (peers swarm) | ||
225 | peers' = case reverse ps0 of | ||
226 | (_,psq):_ -> psq | ||
227 | _ -> peers swarm | ||
228 | ps = L.map (key . fst) ps0 | ||
229 | m' = HM.insert ih swarm { peers = L.foldl' (\q p -> PSQ.insert p tm q) peers' ps } m | ||
230 | return $! m' `seq` (ps,PeerStore m') | ||
231 | |||
232 | incomp :: (x -> Maybe (r,x)) -> x -> Maybe ((r,x),x) | ||
233 | incomp !f !x = do | ||
234 | (result,x') <- f x | ||
235 | pure $! ( (result,x'), x' ) | ||
236 | |||
237 | -- | Used in 'announce_peer' DHT queries. | ||
238 | insertPeer :: InfoHash -> Maybe ByteString -> PeerAddr -> PeerStore -> PeerStore | ||
239 | insertPeer !ih !name !a !(PeerStore m) = seq a' $ PeerStore (HM.insertWith swarmInsert ih a' m) | ||
240 | where | ||
241 | a' = SwarmData { peers = PSQ.singleton a 0 | ||
242 | , name = name } | ||
243 | |||
244 | deleteOlderThan :: POSIXTime -> PeerStore -> PeerStore | ||
245 | deleteOlderThan cutoff (PeerStore m) = PeerStore $ HM.mapMaybe gc m | ||
246 | where | ||
247 | gc :: SwarmData -> Maybe SwarmData | ||
248 | gc swarms = fmap (\ps -> swarms { peers = ps }) $ gcPSQ (peers swarms) | ||
249 | |||
250 | gcPSQ :: PSQKey a => PSQ a Timestamp -> Maybe (PSQ a Timestamp) | ||
251 | gcPSQ ps = case minView ps of | ||
252 | Nothing -> Nothing | ||
253 | Just (_ :-> tm, ps') | tm < cutoff -> gcPSQ ps' | ||
254 | Just _ -> Just ps | ||
diff --git a/dht/src/Network/BitTorrent/DHT/Readme.md b/dht/src/Network/BitTorrent/DHT/Readme.md new file mode 100644 index 00000000..e2352f10 --- /dev/null +++ b/dht/src/Network/BitTorrent/DHT/Readme.md | |||
@@ -0,0 +1,13 @@ | |||
1 | References | ||
2 | ========== | ||
3 | |||
4 | Some good references excluding BEPs: | ||
5 | |||
6 | * [Kademlia wiki page][kademlia-wiki] | ||
7 | * [Kademlia: A Peer-to-peer Information System Based on the XOR Metric][kademlia-paper] | ||
8 | * [BitTorrent Mainline DHT Measurement][mldht] | ||
9 | * Profiling a Million User DHT. (paper) | ||
10 | |||
11 | [kademlia-wiki]: http://en.wikipedia.org/wiki/Kademlia | ||
12 | [kademlia-paper]: http://pdos.csail.mit.edu/~petar/papers/maymounkov-kademlia-lncs.pdf | ||
13 | [mldht]: http://www.cs.helsinki.fi/u/jakangas/MLDHT/ | ||
diff --git a/dht/src/Network/BitTorrent/DHT/Token.hs b/dht/src/Network/BitTorrent/DHT/Token.hs new file mode 100644 index 00000000..171cc8be --- /dev/null +++ b/dht/src/Network/BitTorrent/DHT/Token.hs | |||
@@ -0,0 +1,201 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- The return value for a query for peers includes an opaque value | ||
9 | -- known as the 'Token'. For a node to announce that its controlling | ||
10 | -- peer is downloading a torrent, it must present the token received | ||
11 | -- from the same queried node in a recent query for peers. When a node | ||
12 | -- attempts to \"announce\" a torrent, the queried node checks the | ||
13 | -- token against the querying node's 'IP' address. This is to prevent | ||
14 | -- malicious hosts from signing up other hosts for torrents. Since the | ||
15 | -- token is merely returned by the querying node to the same node it | ||
16 | -- received the token from, the implementation is not defined. Tokens | ||
17 | -- must be accepted for a reasonable amount of time after they have | ||
18 | -- been distributed. | ||
19 | -- | ||
20 | {-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-} | ||
21 | module Network.BitTorrent.DHT.Token | ||
22 | ( -- * Token | ||
23 | Token | ||
24 | , maxInterval | ||
25 | , toPaddedByteString | ||
26 | , fromPaddedByteString | ||
27 | |||
28 | -- * Session tokens | ||
29 | , TokenMap | ||
30 | , SessionTokens | ||
31 | , nullSessionTokens | ||
32 | , checkToken | ||
33 | , grantToken | ||
34 | |||
35 | -- ** Construction | ||
36 | , Network.BitTorrent.DHT.Token.tokens | ||
37 | |||
38 | -- ** Query | ||
39 | , Network.BitTorrent.DHT.Token.lookup | ||
40 | , Network.BitTorrent.DHT.Token.member | ||
41 | |||
42 | -- ** Modification | ||
43 | , Network.BitTorrent.DHT.Token.defaultUpdateInterval | ||
44 | , Network.BitTorrent.DHT.Token.update | ||
45 | ) where | ||
46 | |||
47 | import Control.Arrow | ||
48 | import Control.Monad.State | ||
49 | #ifdef VERSION_bencoding | ||
50 | import Data.BEncode (BEncode) | ||
51 | #endif | ||
52 | import Data.ByteString as BS | ||
53 | import Data.ByteString.Char8 as B8 | ||
54 | import Data.ByteString.Lazy as BL | ||
55 | import Data.ByteString.Lazy.Builder as BS | ||
56 | import qualified Data.ByteString.Base16 as Base16 | ||
57 | import Data.Default | ||
58 | import Data.List as L | ||
59 | import Data.Hashable | ||
60 | import Data.String | ||
61 | import Data.Time | ||
62 | import System.Random | ||
63 | import Control.Concurrent.STM | ||
64 | |||
65 | -- TODO use ShortByteString | ||
66 | |||
67 | -- | An opaque value. | ||
68 | newtype Token = Token BS.ByteString | ||
69 | deriving ( Eq, IsString | ||
70 | #ifdef VERSION_bencoding | ||
71 | , BEncode | ||
72 | #endif | ||
73 | ) | ||
74 | |||
75 | instance Show Token where | ||
76 | show (Token bs) = B8.unpack $ Base16.encode bs | ||
77 | |||
78 | instance Read Token where | ||
79 | readsPrec i s = pure $ (Token *** B8.unpack) $ Base16.decode (B8.pack s) | ||
80 | |||
81 | -- | Meaningless token, for testing purposes only. | ||
82 | instance Default Token where | ||
83 | def = makeToken (0::Int) 0 | ||
84 | |||
85 | -- | Prepend token with 0x20 bytes to fill the available width. | ||
86 | -- | ||
87 | -- If n > 8, then this will also guarantee a nonzero token, which is useful for | ||
88 | -- Tox ping-id values for announce responses. | ||
89 | toPaddedByteString :: Int -> Token -> BS.ByteString | ||
90 | toPaddedByteString n (Token bs) = BS.append (BS.replicate (n - BS.length bs) 0x20) bs | ||
91 | |||
92 | fromPaddedByteString :: Int -> BS.ByteString -> Token | ||
93 | fromPaddedByteString n bs = Token $ BS.drop (n - len) bs | ||
94 | where | ||
95 | len = BS.length tok where Token tok = def | ||
96 | |||
97 | -- | The secret value used as salt. | ||
98 | type Secret = Int | ||
99 | |||
100 | -- The BitTorrent implementation uses the SHA1 hash of the IP address | ||
101 | -- concatenated onto a secret, we use hashable instead. | ||
102 | makeToken :: Hashable a => a -> Secret -> Token | ||
103 | makeToken n s = Token $ toBS $ hashWithSalt s n | ||
104 | where | ||
105 | toBS = toStrict . toLazyByteString . int64BE . fromIntegral | ||
106 | {-# INLINE makeToken #-} | ||
107 | |||
108 | -- | Constant space 'Node' to 'Token' map based on the secret value. | ||
109 | data TokenMap = TokenMap | ||
110 | { prevSecret :: {-# UNPACK #-} !Secret | ||
111 | , curSecret :: {-# UNPACK #-} !Secret | ||
112 | , generator :: {-# UNPACK #-} !StdGen | ||
113 | } deriving Show | ||
114 | |||
115 | -- | A new token map based on the specified seed value. Returned token | ||
116 | -- map should be periodicatically 'update'd. | ||
117 | -- | ||
118 | -- Normally, the seed value should vary between invocations of the | ||
119 | -- client software. | ||
120 | tokens :: Int -> TokenMap | ||
121 | tokens seed = (`evalState` mkStdGen seed) $ | ||
122 | TokenMap <$> state next | ||
123 | <*> state next | ||
124 | <*> get | ||
125 | |||
126 | -- | Get token for the given node. A token becomes invalid after 2 | ||
127 | -- 'update's. | ||
128 | -- | ||
129 | -- Typically used to handle find_peers query. | ||
130 | lookup :: Hashable a => a -> TokenMap -> Token | ||
131 | lookup addr TokenMap {..} = makeToken addr curSecret | ||
132 | |||
133 | -- | Check if token is valid. | ||
134 | -- | ||
135 | -- Typically used to handle 'Network.DHT.Mainline.Announce' | ||
136 | -- query. If token is invalid the 'Network.KRPC.ProtocolError' should | ||
137 | -- be sent back to the malicious node. | ||
138 | member :: Hashable a => a -> Token -> TokenMap -> Bool | ||
139 | member addr token TokenMap {..} = token `L.elem` valid | ||
140 | where valid = makeToken addr <$> [curSecret, prevSecret] | ||
141 | |||
142 | -- | Secret changes every five minutes and tokens up to ten minutes old | ||
143 | -- are accepted. | ||
144 | defaultUpdateInterval :: NominalDiffTime | ||
145 | defaultUpdateInterval = 5 * 60 | ||
146 | |||
147 | -- | Update current tokens. | ||
148 | update :: TokenMap -> TokenMap | ||
149 | update TokenMap {..} = TokenMap | ||
150 | { prevSecret = curSecret | ||
151 | , curSecret = newSecret | ||
152 | , generator = newGen | ||
153 | } | ||
154 | where | ||
155 | (newSecret, newGen) = next generator | ||
156 | |||
157 | data SessionTokens = SessionTokens | ||
158 | { tokenMap :: !TokenMap | ||
159 | , lastUpdate :: !UTCTime | ||
160 | , maxInterval :: !NominalDiffTime | ||
161 | } | ||
162 | |||
163 | nullSessionTokens :: IO SessionTokens | ||
164 | nullSessionTokens = SessionTokens | ||
165 | <$> (tokens <$> randomIO) | ||
166 | <*> getCurrentTime | ||
167 | <*> pure defaultUpdateInterval | ||
168 | |||
169 | -- TODO invalidate *twice* if needed | ||
170 | invalidateTokens :: UTCTime -> SessionTokens -> SessionTokens | ||
171 | invalidateTokens curTime ts @ SessionTokens {..} | ||
172 | | curTime `diffUTCTime` lastUpdate > maxInterval = SessionTokens | ||
173 | { tokenMap = update tokenMap | ||
174 | , lastUpdate = curTime | ||
175 | , maxInterval = maxInterval | ||
176 | } | ||
177 | | otherwise = ts | ||
178 | |||
179 | {----------------------------------------------------------------------- | ||
180 | -- Tokens | ||
181 | -----------------------------------------------------------------------} | ||
182 | |||
183 | tryUpdateSecret :: TVar SessionTokens -> IO () | ||
184 | tryUpdateSecret toks = do | ||
185 | curTime <- getCurrentTime | ||
186 | atomically $ modifyTVar' toks (invalidateTokens curTime) | ||
187 | |||
188 | grantToken :: Hashable addr => TVar SessionTokens -> addr -> IO Token | ||
189 | grantToken sessionTokens addr = do | ||
190 | tryUpdateSecret sessionTokens | ||
191 | toks <- readTVarIO sessionTokens | ||
192 | return $ Network.BitTorrent.DHT.Token.lookup addr $ tokenMap toks | ||
193 | |||
194 | -- | Throws 'HandlerError' if the token is invalid or already | ||
195 | -- expired. See 'TokenMap' for details. | ||
196 | checkToken :: Hashable addr => TVar SessionTokens -> addr -> Token -> IO Bool | ||
197 | checkToken sessionTokens addr questionableToken = do | ||
198 | tryUpdateSecret sessionTokens | ||
199 | toks <- readTVarIO sessionTokens | ||
200 | return $ member addr questionableToken (tokenMap toks) | ||
201 | |||
diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs new file mode 100644 index 00000000..89851e88 --- /dev/null +++ b/dht/src/Network/BitTorrent/MainlineDHT.hs | |||
@@ -0,0 +1,1169 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE DeriveDataTypeable #-} | ||
3 | {-# LANGUAGE DeriveFoldable #-} | ||
4 | {-# LANGUAGE DeriveFunctor #-} | ||
5 | {-# LANGUAGE DeriveTraversable #-} | ||
6 | {-# LANGUAGE FlexibleInstances #-} | ||
7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
8 | {-# LANGUAGE LambdaCase #-} | ||
9 | {-# LANGUAGE NamedFieldPuns #-} | ||
10 | {-# LANGUAGE PatternSynonyms #-} | ||
11 | {-# LANGUAGE StandaloneDeriving #-} | ||
12 | {-# LANGUAGE TupleSections #-} | ||
13 | module Network.BitTorrent.MainlineDHT where | ||
14 | |||
15 | import Control.Applicative | ||
16 | import Control.Arrow | ||
17 | import Control.Concurrent.STM | ||
18 | import Control.Monad | ||
19 | import Crypto.Random | ||
20 | import Data.BEncode as BE | ||
21 | import qualified Data.BEncode.BDict as BE | ||
22 | ;import Data.BEncode.BDict (BKey) | ||
23 | import Data.BEncode.Pretty | ||
24 | import Data.BEncode.Types (BDict) | ||
25 | import Data.Bits | ||
26 | import Data.Bits.ByteString () | ||
27 | import Data.Bool | ||
28 | import Data.ByteArray (ByteArrayAccess) | ||
29 | import qualified Data.ByteString as B | ||
30 | ;import Data.ByteString (ByteString) | ||
31 | import qualified Data.ByteString.Base16 as Base16 | ||
32 | import qualified Data.ByteString.Char8 as C8 | ||
33 | import Data.ByteString.Lazy (toStrict) | ||
34 | import qualified Data.ByteString.Lazy.Char8 as L8 | ||
35 | import Data.Char | ||
36 | import Data.Coerce | ||
37 | import Data.Data | ||
38 | import Data.Default | ||
39 | import Data.Digest.CRC32C | ||
40 | import Data.Function (fix) | ||
41 | import Data.Hashable | ||
42 | #if MIN_VERSION_iproute(1,7,4) | ||
43 | import Data.IP hiding (fromSockAddr) | ||
44 | #else | ||
45 | import Data.IP | ||
46 | #endif | ||
47 | import Data.Maybe | ||
48 | import Data.Monoid | ||
49 | import Data.Ord | ||
50 | import qualified Data.Serialize as S | ||
51 | import Data.Set (Set) | ||
52 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) | ||
53 | import Data.Torrent | ||
54 | import Data.Word | ||
55 | import qualified Data.Wrapper.PSQInt as Int | ||
56 | import Debug.Trace | ||
57 | import Network.BitTorrent.MainlineDHT.Symbols | ||
58 | import Network.Kademlia | ||
59 | import Network.Kademlia.Bootstrap | ||
60 | import Network.Address (fromSockAddr, | ||
61 | setPort, sockAddrPort, testIdBit, | ||
62 | toSockAddr, genBucketSample', WantIP(..), | ||
63 | un4map,either4or6,ipFamily) | ||
64 | import Network.BitTorrent.DHT.ContactInfo as Peers | ||
65 | import Network.Kademlia.Search (Search (..)) | ||
66 | import Network.BitTorrent.DHT.Token as Token | ||
67 | import qualified Network.Kademlia.Routing as R | ||
68 | ;import Network.Kademlia.Routing (getTimestamp) | ||
69 | import Network.QueryResponse | ||
70 | import Network.Socket | ||
71 | import System.IO.Error | ||
72 | import System.IO.Unsafe (unsafeInterleaveIO) | ||
73 | import qualified Text.ParserCombinators.ReadP as RP | ||
74 | #ifdef THREAD_DEBUG | ||
75 | import Control.Concurrent.Lifted.Instrument | ||
76 | #else | ||
77 | import Control.Concurrent.Lifted | ||
78 | import GHC.Conc (labelThread) | ||
79 | #endif | ||
80 | import qualified Data.Aeson as JSON | ||
81 | ;import Data.Aeson (FromJSON, ToJSON, (.=)) | ||
82 | import Text.Read | ||
83 | import System.Global6 | ||
84 | import Control.TriadCommittee | ||
85 | import Data.TableMethods | ||
86 | import DPut | ||
87 | import DebugTag | ||
88 | |||
89 | newtype NodeId = NodeId ByteString | ||
90 | deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable) | ||
91 | |||
92 | instance BEncode NodeId where | ||
93 | fromBEncode bval = do | ||
94 | bs <- fromBEncode bval | ||
95 | if B.length bs /= 20 | ||
96 | then Left "Invalid length node id." | ||
97 | else Right $ NodeId bs | ||
98 | |||
99 | toBEncode (NodeId bs) = toBEncode bs | ||
100 | |||
101 | instance Show NodeId where | ||
102 | show (NodeId bs) = C8.unpack $ Base16.encode bs | ||
103 | |||
104 | instance S.Serialize NodeId where | ||
105 | get = NodeId <$> S.getBytes 20 | ||
106 | put (NodeId bs) = S.putByteString bs | ||
107 | |||
108 | instance FiniteBits NodeId where | ||
109 | finiteBitSize _ = 160 | ||
110 | |||
111 | instance Read NodeId where | ||
112 | readsPrec _ str | ||
113 | | (bs, xs) <- Base16.decode $ C8.pack str | ||
114 | , B.length bs == 20 | ||
115 | = [ (NodeId bs, drop 40 str) ] | ||
116 | | otherwise = [] | ||
117 | |||
118 | zeroID :: NodeId | ||
119 | zeroID = NodeId $ B.replicate 20 0 | ||
120 | |||
121 | data NodeInfo = NodeInfo | ||
122 | { nodeId :: NodeId | ||
123 | , nodeIP :: IP | ||
124 | , nodePort :: PortNumber | ||
125 | } | ||
126 | deriving (Eq,Ord) | ||
127 | |||
128 | instance ToJSON NodeInfo where | ||
129 | toJSON (NodeInfo nid (IPv4 ip) port) | ||
130 | = JSON.object [ "node-id" .= show nid | ||
131 | , "ipv4" .= show ip | ||
132 | , "port" .= (fromIntegral port :: Int) | ||
133 | ] | ||
134 | toJSON (NodeInfo nid (IPv6 ip6) port) | ||
135 | | Just ip <- un4map ip6 | ||
136 | = JSON.object [ "node-id" .= show nid | ||
137 | , "ipv4" .= show ip | ||
138 | , "port" .= (fromIntegral port :: Int) | ||
139 | ] | ||
140 | | otherwise | ||
141 | = JSON.object [ "node-id" .= show nid | ||
142 | , "ipv6" .= show ip6 | ||
143 | , "port" .= (fromIntegral port :: Int) | ||
144 | ] | ||
145 | instance FromJSON NodeInfo where | ||
146 | parseJSON (JSON.Object v) = do | ||
147 | nidstr <- v JSON..: "node-id" | ||
148 | ip6str <- v JSON..:? "ipv6" | ||
149 | ip4str <- v JSON..:? "ipv4" | ||
150 | portnum <- v JSON..: "port" | ||
151 | ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) | ||
152 | <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) | ||
153 | let (bs,_) = Base16.decode (C8.pack nidstr) | ||
154 | guard (B.length bs == 20) | ||
155 | return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16)) | ||
156 | |||
157 | hexdigit :: Char -> Bool | ||
158 | hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') | ||
159 | |||
160 | instance Read NodeInfo where | ||
161 | readsPrec i = RP.readP_to_S $ do | ||
162 | RP.skipSpaces | ||
163 | let n = 40 -- characters in node id. | ||
164 | parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) | ||
165 | RP.+++ RP.munch (not . isSpace) | ||
166 | nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit) | ||
167 | RP.char '@' RP.+++ RP.satisfy isSpace | ||
168 | addrstr <- parseAddr | ||
169 | nid <- case Base16.decode $ C8.pack hexhash of | ||
170 | (bs,_) | B.length bs==20 -> return (NodeId bs) | ||
171 | _ -> fail "Bad node id." | ||
172 | return (nid,addrstr) | ||
173 | (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) | ||
174 | let raddr = do | ||
175 | ip <- RP.between (RP.char '[') (RP.char ']') | ||
176 | (IPv6 <$> RP.readS_to_P (readsPrec i)) | ||
177 | RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) | ||
178 | _ <- RP.char ':' | ||
179 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
180 | return (ip, port) | ||
181 | |||
182 | (ip,port) <- case RP.readP_to_S raddr addrstr of | ||
183 | [] -> fail "Bad address." | ||
184 | ((ip,port),_):_ -> return (ip,port) | ||
185 | return $ NodeInfo nid ip port | ||
186 | |||
187 | |||
188 | |||
189 | -- The Hashable instance depends only on the IP address and port number. It is | ||
190 | -- used to compute the announce token. | ||
191 | instance Hashable NodeInfo where | ||
192 | hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) | ||
193 | {-# INLINE hashWithSalt #-} | ||
194 | |||
195 | |||
196 | instance Show NodeInfo where | ||
197 | showsPrec _ (NodeInfo nid ip port) = | ||
198 | shows nid . ('@' :) . showsip . (':' :) . shows port | ||
199 | where | ||
200 | showsip | ||
201 | | IPv4 ip4 <- ip = shows ip4 | ||
202 | | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 | ||
203 | | otherwise = ('[' :) . shows ip . (']' :) | ||
204 | |||
205 | {- | ||
206 | |||
207 | -- | KRPC 'compact list' compatible encoding: contact information for | ||
208 | -- nodes is encoded as a 26-byte string. Also known as "Compact node | ||
209 | -- info" the 20-byte Node ID in network byte order has the compact | ||
210 | -- IP-address/port info concatenated to the end. | ||
211 | get = NodeInfo <$> (NodeId <$> S.getBytes 20 ) <*> S.get <*> S.get | ||
212 | -} | ||
213 | |||
214 | getNodeInfo4 :: S.Get NodeInfo | ||
215 | getNodeInfo4 = NodeInfo <$> (NodeId <$> S.getBytes 20) | ||
216 | <*> (IPv4 <$> S.get) | ||
217 | <*> S.get | ||
218 | |||
219 | putNodeInfo4 :: NodeInfo -> S.Put | ||
220 | putNodeInfo4 (NodeInfo (NodeId nid) ip port) | ||
221 | | IPv4 ip4 <- ip = put4 ip4 | ||
222 | | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = put4 ip4 | ||
223 | | otherwise = return () | ||
224 | where | ||
225 | put4 ip4 = S.putByteString nid >> S.put ip4 >> S.put port | ||
226 | |||
227 | getNodeInfo6 :: S.Get NodeInfo | ||
228 | getNodeInfo6 = NodeInfo <$> (NodeId <$> S.getBytes 20) | ||
229 | <*> (IPv6 <$> S.get) | ||
230 | <*> S.get | ||
231 | |||
232 | putNodeInfo6 :: NodeInfo -> S.Put | ||
233 | putNodeInfo6 (NodeInfo (NodeId nid) (IPv6 ip) port) | ||
234 | = S.putByteString nid >> S.put ip >> S.put port | ||
235 | putNodeInfo6 _ = return () | ||
236 | |||
237 | |||
238 | -- | TODO: This should depend on the bind address to support IPv4-only. For | ||
239 | -- now, in order to support dual-stack listen, we're going to assume IPv6 is | ||
240 | -- wanted and map IPv4 addresses accordingly. | ||
241 | nodeAddr :: NodeInfo -> SockAddr | ||
242 | nodeAddr (NodeInfo _ ip port) = | ||
243 | case ip of | ||
244 | IPv4 ip4 -> setPort port $ toSockAddr (ipv4ToIPv6 ip4) | ||
245 | IPv6 ip6 -> setPort port $ toSockAddr ip6 | ||
246 | |||
247 | nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo | ||
248 | nodeInfo nid saddr | ||
249 | | Just ip <- fromSockAddr saddr | ||
250 | , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port | ||
251 | | otherwise = Left "Address family not supported." | ||
252 | |||
253 | -- | Types of RPC errors. | ||
254 | data ErrorCode | ||
255 | -- | Some error doesn't fit in any other category. | ||
256 | = GenericError | ||
257 | |||
258 | -- | Occurs when server fail to process procedure call. | ||
259 | | ServerError | ||
260 | |||
261 | -- | Malformed packet, invalid arguments or bad token. | ||
262 | | ProtocolError | ||
263 | |||
264 | -- | Occurs when client trying to call method server don't know. | ||
265 | | MethodUnknown | ||
266 | deriving (Show, Read, Eq, Ord, Bounded, Typeable, Data) | ||
267 | |||
268 | -- | According to the table: | ||
269 | -- <http://bittorrent.org/beps/bep_0005.html#errors> | ||
270 | instance Enum ErrorCode where | ||
271 | fromEnum GenericError = 201 | ||
272 | fromEnum ServerError = 202 | ||
273 | fromEnum ProtocolError = 203 | ||
274 | fromEnum MethodUnknown = 204 | ||
275 | {-# INLINE fromEnum #-} | ||
276 | toEnum 201 = GenericError | ||
277 | toEnum 202 = ServerError | ||
278 | toEnum 203 = ProtocolError | ||
279 | toEnum 204 = MethodUnknown | ||
280 | toEnum _ = GenericError | ||
281 | {-# INLINE toEnum #-} | ||
282 | |||
283 | instance BEncode ErrorCode where | ||
284 | toBEncode = toBEncode . fromEnum | ||
285 | {-# INLINE toBEncode #-} | ||
286 | fromBEncode b = toEnum <$> fromBEncode b | ||
287 | {-# INLINE fromBEncode #-} | ||
288 | |||
289 | data Error = Error | ||
290 | { errorCode :: !ErrorCode -- ^ The type of error. | ||
291 | , errorMessage :: !ByteString -- ^ Human-readable text message. | ||
292 | } deriving ( Show, Eq, Ord, Typeable, Data, Read ) | ||
293 | |||
294 | newtype TransactionId = TransactionId ByteString | ||
295 | deriving (Eq, Ord, Show, BEncode) | ||
296 | |||
297 | newtype Method = Method ByteString | ||
298 | deriving (Eq, Ord, Show, BEncode) | ||
299 | |||
300 | data Message a = Q { msgOrigin :: NodeId | ||
301 | , msgID :: TransactionId | ||
302 | , qryPayload :: a | ||
303 | , qryMethod :: Method | ||
304 | , qryReadOnly :: Bool } | ||
305 | |||
306 | | R { msgOrigin :: NodeId | ||
307 | , msgID :: TransactionId | ||
308 | , rspPayload :: Either Error a | ||
309 | , rspReflectedIP :: Maybe SockAddr } | ||
310 | |||
311 | showBE :: BValue -> String | ||
312 | showBE bval = L8.unpack (showBEncode bval) | ||
313 | |||
314 | instance BE.BEncode (Message BValue) where | ||
315 | toBEncode m = encodeMessage m | ||
316 | {- | ||
317 | in case m of | ||
318 | Q {} -> trace ("encoded(query): "++showBE r) r | ||
319 | R {} -> trace ("encoded(response): "++showBE r) r -} | ||
320 | fromBEncode bval = decodeMessage bval | ||
321 | {- | ||
322 | in case r of | ||
323 | Left e -> trace (show e) r | ||
324 | Right (Q {}) -> trace ("decoded(query): "++showBE bval) r | ||
325 | Right (R {}) -> trace ("decoded(response): "++showBE bval) r -} | ||
326 | |||
327 | decodeMessage :: BValue -> Either String (Message BValue) | ||
328 | decodeMessage = fromDict $ do | ||
329 | key <- lookAhead (field (req "y")) | ||
330 | let _ = key :: BKey | ||
331 | f <- case key of | ||
332 | "q" -> do a <- field (req "a") | ||
333 | g <- either fail return $ flip fromDict a $ do | ||
334 | who <- field (req "id") | ||
335 | ro <- fromMaybe False <$> optional (field (req "ro")) | ||
336 | return $ \meth tid -> Q who tid a meth ro | ||
337 | meth <- field (req "q") | ||
338 | return $ g meth | ||
339 | "r" -> do ip <- do | ||
340 | ipstr <- optional (field (req "ip")) | ||
341 | mapM (either fail return . decodeAddr) ipstr | ||
342 | vals <- field (req "r") | ||
343 | either fail return $ flip fromDict vals $ do | ||
344 | who <- field (req "id") | ||
345 | return $ \tid -> R who tid (Right vals) ip | ||
346 | "e" -> do (ecode,emsg) <- field (req "e") | ||
347 | ip <- do | ||
348 | ipstr <- optional (field (req "ip")) | ||
349 | mapM (either fail return . decodeAddr) ipstr | ||
350 | -- FIXME:Spec does not give us the NodeId of the sender. | ||
351 | -- Using 'zeroID' as place holder. | ||
352 | -- We should ignore the msgOrigin for errors in 'updateRouting'. | ||
353 | -- We should consider making msgOrigin a Maybe value. | ||
354 | return $ \tid -> R zeroID tid (Left (Error ecode emsg)) ip | ||
355 | _ -> fail $ "Mainline message is not a query, response, or an error: " | ||
356 | ++ show key | ||
357 | tid <- field (req "t") | ||
358 | return $ f (tid :: TransactionId) | ||
359 | |||
360 | |||
361 | encodeMessage :: Message BValue -> BValue | ||
362 | encodeMessage (Q origin tid a meth ro) | ||
363 | = case a of | ||
364 | BDict args -> encodeQuery tid meth (BDict $ genericArgs origin ro `BE.union` args) | ||
365 | _ -> encodeQuery tid meth a -- XXX: Not really a valid query. | ||
366 | encodeMessage (R origin tid v ip) | ||
367 | = case v of | ||
368 | Right (BDict vals) -> encodeResponse tid (BDict $ genericArgs origin False `BE.union` vals) ip | ||
369 | Left err -> encodeError tid err | ||
370 | |||
371 | |||
372 | encodeAddr :: SockAddr -> ByteString | ||
373 | encodeAddr = either encode4 encode6 . either4or6 | ||
374 | where | ||
375 | encode4 (SockAddrInet port addr) | ||
376 | = S.runPut (S.putWord32host addr >> S.putWord16be (fromIntegral port)) | ||
377 | |||
378 | encode6 (SockAddrInet6 port _ addr _) | ||
379 | = S.runPut (S.put addr >> S.putWord16be (fromIntegral port)) | ||
380 | encode6 _ = B.empty | ||
381 | |||
382 | decodeAddr :: ByteString -> Either String SockAddr | ||
383 | decodeAddr bs = S.runGet g bs | ||
384 | where | ||
385 | g | (B.length bs == 6) = flip SockAddrInet <$> S.getWord32host <*> (fromIntegral <$> S.getWord16be) | ||
386 | | otherwise = do host <- S.get -- TODO: Is this right? | ||
387 | port <- fromIntegral <$> S.getWord16be | ||
388 | return $ SockAddrInet6 port 0 host 0 | ||
389 | |||
390 | genericArgs :: BEncode a => a -> Bool -> BDict | ||
391 | genericArgs nodeid ro = | ||
392 | "id" .=! nodeid | ||
393 | .: "ro" .=? bool Nothing (Just (1 :: Int)) ro | ||
394 | .: endDict | ||
395 | |||
396 | encodeError :: BEncode a => a -> Error -> BValue | ||
397 | encodeError tid (Error ecode emsg) = encodeAny tid "e" (ecode,emsg) id | ||
398 | |||
399 | encodeResponse :: (BEncode tid, BEncode vals) => | ||
400 | tid -> vals -> Maybe SockAddr -> BValue | ||
401 | encodeResponse tid rvals rip = | ||
402 | encodeAny tid "r" rvals ("ip" .=? (BString . encodeAddr <$> rip) .:) | ||
403 | |||
404 | encodeQuery :: (BEncode args, BEncode tid, BEncode method) => | ||
405 | tid -> method -> args -> BValue | ||
406 | encodeQuery tid qmeth qargs = encodeAny tid "q" qmeth ("a" .=! qargs .:) | ||
407 | |||
408 | encodeAny :: | ||
409 | (BEncode tid, BEncode a) => | ||
410 | tid -> BKey -> a -> (BDict -> BDict) -> BValue | ||
411 | encodeAny tid key val aux = toDict $ | ||
412 | aux $ key .=! val | ||
413 | .: "t" .=! tid | ||
414 | .: "y" .=! key | ||
415 | .: endDict | ||
416 | |||
417 | |||
418 | showPacket :: ([L8.ByteString] -> [L8.ByteString]) -> SockAddr -> L8.ByteString -> ByteString -> String | ||
419 | showPacket f addr flow bs = L8.unpack $ L8.unlines es | ||
420 | where | ||
421 | es = map (L8.append prefix) (f $ L8.lines pp) | ||
422 | |||
423 | prefix = L8.pack (either show show $ either4or6 addr) <> flow | ||
424 | |||
425 | pp = either L8.pack showBEncode $ BE.decode bs | ||
426 | |||
427 | -- Add detailed printouts for every packet. | ||
428 | addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString | ||
429 | addVerbosity tr = | ||
430 | tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do | ||
431 | forM_ m $ mapM_ $ \(msg,addr) -> do | ||
432 | dput XBitTorrent (showPacket id addr " --> " msg) | ||
433 | kont m | ||
434 | , sendMessage = \addr msg -> do | ||
435 | dput XBitTorrent (showPacket id addr " <-- " msg) | ||
436 | sendMessage tr addr msg | ||
437 | } | ||
438 | |||
439 | |||
440 | showParseError :: ByteString -> SockAddr -> String -> String | ||
441 | showParseError bs addr err = showPacket (L8.pack err :) addr " --> " bs | ||
442 | |||
443 | parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo) | ||
444 | parsePacket bs addr = left (showParseError bs addr) $ do | ||
445 | pkt <- BE.decode bs | ||
446 | -- TODO: Error packets do not include a valid msgOrigin. | ||
447 | -- The BE.decode method is using 'zeroID' as a placeholder. | ||
448 | ni <- nodeInfo (msgOrigin pkt) addr | ||
449 | return (pkt, ni) | ||
450 | |||
451 | encodePacket :: Message BValue -> NodeInfo -> (ByteString, SockAddr) | ||
452 | encodePacket msg ni = ( toStrict $ BE.encode msg | ||
453 | , nodeAddr ni ) | ||
454 | |||
455 | classify :: Message BValue -> MessageClass String Method TransactionId NodeInfo (Message BValue) | ||
456 | classify (Q { msgID = tid, qryMethod = meth }) = IsQuery meth tid | ||
457 | classify (R { msgID = tid }) = IsResponse tid | ||
458 | |||
459 | encodeResponsePayload :: BEncode a => TransactionId -> NodeInfo -> NodeInfo -> a -> Message BValue | ||
460 | encodeResponsePayload tid self dest b = R (nodeId self) tid (Right $ BE.toBEncode b) (Just $ nodeAddr dest) | ||
461 | |||
462 | encodeQueryPayload :: BEncode a => | ||
463 | Method -> Bool -> TransactionId -> NodeInfo -> NodeInfo -> a -> Message BValue | ||
464 | encodeQueryPayload meth isReadonly tid self dest b = Q (nodeId self) tid (BE.toBEncode b) meth isReadonly | ||
465 | |||
466 | errorPayload :: TransactionId -> NodeInfo -> NodeInfo -> Error -> Message a | ||
467 | errorPayload tid self dest e = R (nodeId self) tid (Left e) (Just $ nodeAddr dest) | ||
468 | |||
469 | decodePayload :: BEncode a => Message BValue -> Either String a | ||
470 | decodePayload msg = BE.fromBEncode $ qryPayload msg | ||
471 | |||
472 | type Handler = MethodHandler String TransactionId NodeInfo (Message BValue) | ||
473 | |||
474 | handler :: ( BEncode a | ||
475 | , BEncode b | ||
476 | ) => | ||
477 | (NodeInfo -> a -> IO b) -> Maybe Handler | ||
478 | handler f = Just $ MethodHandler decodePayload encodeResponsePayload f | ||
479 | |||
480 | |||
481 | handlerE :: ( BEncode a | ||
482 | , BEncode b | ||
483 | ) => | ||
484 | (NodeInfo -> a -> IO (Either Error b)) -> Maybe Handler | ||
485 | handlerE f = Just $ MethodHandler decodePayload enc f | ||
486 | where | ||
487 | enc tid self dest (Left e) = errorPayload tid self dest e | ||
488 | enc tid self dest (Right b) = encodeResponsePayload tid self dest b | ||
489 | |||
490 | type AnnounceSet = Set (InfoHash, PortNumber) | ||
491 | |||
492 | data SwarmsDatabase = SwarmsDatabase | ||
493 | { contactInfo :: !( TVar PeerStore ) -- ^ Published by other nodes. | ||
494 | , sessionTokens :: !( TVar SessionTokens ) -- ^ Query session IDs. | ||
495 | , announceInfo :: !( TVar AnnounceSet ) -- ^ To publish by this node. | ||
496 | } | ||
497 | |||
498 | newSwarmsDatabase :: IO SwarmsDatabase | ||
499 | newSwarmsDatabase = do | ||
500 | toks <- nullSessionTokens | ||
501 | atomically | ||
502 | $ SwarmsDatabase <$> newTVar def | ||
503 | <*> newTVar toks | ||
504 | <*> newTVar def | ||
505 | |||
506 | data Routing = Routing | ||
507 | { tentativeId :: NodeInfo | ||
508 | , committee4 :: TriadCommittee NodeId SockAddr | ||
509 | , committee6 :: TriadCommittee NodeId SockAddr | ||
510 | , refresher4 :: BucketRefresher NodeId NodeInfo | ||
511 | , refresher6 :: BucketRefresher NodeId NodeInfo | ||
512 | } | ||
513 | |||
514 | sched4 :: Routing -> TVar (Int.PSQ POSIXTime) | ||
515 | sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue | ||
516 | |||
517 | sched6 :: Routing -> TVar (Int.PSQ POSIXTime) | ||
518 | sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue | ||
519 | |||
520 | routing4 :: Routing -> TVar (R.BucketList NodeInfo) | ||
521 | routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets | ||
522 | |||
523 | routing6 :: Routing -> TVar (R.BucketList NodeInfo) | ||
524 | routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets | ||
525 | |||
526 | traced :: Show tid => TableMethods t tid -> TableMethods t tid | ||
527 | traced (TableMethods ins del lkup) | ||
528 | = TableMethods (\tid mvar t -> trace ("insert "++show tid) $ ins tid mvar t) | ||
529 | (\tid t -> trace ("del "++show tid) $ del tid t) | ||
530 | (\tid t -> trace ("lookup "++show tid) $ lkup tid t) | ||
531 | |||
532 | |||
533 | type MainlineClient = Client String Method TransactionId NodeInfo (Message BValue) | ||
534 | |||
535 | -- | Like 'nodeInfo' but falls back to 'iNADDR_ANY' for nodeIP' and 'nodePort'. | ||
536 | mkNodeInfo :: NodeId -> SockAddr -> NodeInfo | ||
537 | mkNodeInfo nid addr = NodeInfo | ||
538 | { nodeId = nid | ||
539 | , nodeIP = fromMaybe (toEnum 0) $ fromSockAddr addr | ||
540 | , nodePort = fromMaybe 0 $ sockAddrPort addr | ||
541 | } | ||
542 | |||
543 | newClient :: SwarmsDatabase -> SockAddr | ||
544 | -> IO ( MainlineClient | ||
545 | , Routing | ||
546 | , [NodeInfo] -> [NodeInfo] -> IO () | ||
547 | , [NodeInfo] -> [NodeInfo] -> IO () | ||
548 | ) | ||
549 | newClient swarms addr = do | ||
550 | udp <- udpTransport addr | ||
551 | nid <- NodeId <$> getRandomBytes 20 | ||
552 | let tentative_info = mkNodeInfo nid addr | ||
553 | tentative_info6 <- | ||
554 | maybe tentative_info | ||
555 | (\ip6 -> tentative_info { nodeId = fromMaybe (nodeId tentative_info) | ||
556 | $ bep42 (toSockAddr ip6) (nodeId tentative_info) | ||
557 | , nodeIP = IPv6 ip6 | ||
558 | }) | ||
559 | <$> global6 | ||
560 | addr4 <- atomically $ newTChan | ||
561 | addr6 <- atomically $ newTChan | ||
562 | mkrouting <- atomically $ do | ||
563 | -- We defer initializing the refreshSearch and refreshPing until we | ||
564 | -- have a client to send queries with. | ||
565 | let nullPing = const $ return False | ||
566 | nullSearch = mainlineSearch $ Left $ \_ _ -> return Nothing | ||
567 | tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info R.defaultBucketCount | ||
568 | refresher4 <- newBucketRefresher tbl4 nullSearch nullPing | ||
569 | tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount | ||
570 | refresher6 <- newBucketRefresher tbl6 nullSearch nullPing | ||
571 | let updateIPVote tblvar addrvar a = do | ||
572 | bkts <- readTVar tblvar | ||
573 | case bep42 a (nodeId $ R.thisNode bkts) of | ||
574 | Just nid -> do | ||
575 | let tbl = R.nullTable (comparing nodeId) | ||
576 | (\s -> hashWithSalt s . nodeId) | ||
577 | (mkNodeInfo nid a) | ||
578 | (R.defaultBucketCount) | ||
579 | writeTVar tblvar tbl | ||
580 | writeTChan addrvar (a,map fst $ concat $ R.toList bkts) | ||
581 | Nothing -> return () | ||
582 | committee4 <- newTriadCommittee $ updateIPVote tbl4 addr4 | ||
583 | committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6 | ||
584 | return $ \client -> | ||
585 | -- Now we have a client, so tell the BucketRefresher how to search and ping. | ||
586 | let updIO r = updateRefresherIO (nodeSearch client) (ping client) r | ||
587 | in Routing tentative_info committee4 committee6 (updIO refresher4) (updIO refresher6) | ||
588 | map_var <- atomically $ newTVar (0, mempty) | ||
589 | |||
590 | let routing = mkrouting outgoingClient | ||
591 | |||
592 | net = onInbound (updateRouting outgoingClient routing) | ||
593 | $ layerTransport parsePacket encodePacket | ||
594 | $ udp | ||
595 | |||
596 | -- Paranoid: It's safe to define /net/ and /client/ to be mutually | ||
597 | -- recursive since 'updateRouting' does not invoke 'awaitMessage' which | ||
598 | -- which was modified by 'onInbound'. However, I'm going to avoid the | ||
599 | -- mutual reference just to be safe. | ||
600 | outgoingClient = client { clientNet = net { awaitMessage = ($ Nothing) } } | ||
601 | |||
602 | dispatch = DispatchMethods | ||
603 | { classifyInbound = classify -- :: x -> MessageClass err meth tid addr x | ||
604 | , lookupHandler = handlers -- :: meth -> Maybe (MethodHandler err tid addr x) | ||
605 | , tableMethods = mapT -- :: TransactionMethods tbl tid x | ||
606 | } | ||
607 | |||
608 | handlers :: Method -> Maybe Handler | ||
609 | handlers ( Method "ping" ) = handler pingH | ||
610 | handlers ( Method "find_node" ) = handler $ findNodeH routing | ||
611 | handlers ( Method "get_peers" ) = handler $ getPeersH routing swarms | ||
612 | handlers ( Method "announce_peer" ) = handlerE $ announceH swarms | ||
613 | handlers ( Method meth ) = Just $ defaultHandler meth | ||
614 | |||
615 | mapT = transactionMethods mapMethods gen | ||
616 | |||
617 | gen :: Word16 -> (TransactionId, Word16) | ||
618 | gen cnt = (TransactionId $ S.encode cnt, cnt+1) | ||
619 | |||
620 | ignoreParseError :: String -> IO () | ||
621 | ignoreParseError _ = return () | ||
622 | |||
623 | client = Client | ||
624 | { clientNet = addHandler ignoreParseError (handleMessage client) net | ||
625 | , clientDispatcher = dispatch | ||
626 | , clientErrorReporter = ignoreErrors -- printErrors stderr | ||
627 | , clientPending = map_var | ||
628 | , clientAddress = \maddr -> atomically $ do | ||
629 | let var = case flip prefer4or6 Nothing <$> maddr of | ||
630 | Just Want_IP6 -> routing6 routing | ||
631 | _ -> routing4 routing | ||
632 | R.thisNode <$> readTVar var | ||
633 | , clientResponseId = return | ||
634 | } | ||
635 | |||
636 | -- TODO: Provide some means of shutting down these five auxillary threads: | ||
637 | |||
638 | fork $ fix $ \again -> do | ||
639 | myThreadId >>= flip labelThread "addr4" | ||
640 | (addr, ns) <- atomically $ readTChan addr4 | ||
641 | dput XBitTorrent $ "External IPv4: "++show (addr, length ns) | ||
642 | forM_ ns $ \n -> do | ||
643 | dput XBitTorrent $ "Change IP, ping: "++show n | ||
644 | ping outgoingClient n | ||
645 | -- TODO: trigger bootstrap ipv4 | ||
646 | again | ||
647 | fork $ fix $ \again -> do | ||
648 | myThreadId >>= flip labelThread "addr6" | ||
649 | (addr,ns) <- atomically $ readTChan addr6 | ||
650 | dput XBitTorrent $ "External IPv6: "++show (addr, length ns) | ||
651 | forM_ ns $ \n -> do | ||
652 | dput XBitTorrent $ "Change IP, ping: "++show n | ||
653 | ping outgoingClient n | ||
654 | -- TODO: trigger bootstrap ipv6 | ||
655 | again | ||
656 | |||
657 | |||
658 | refresh_thread4 <- forkPollForRefresh $ refresher4 routing | ||
659 | refresh_thread6 <- forkPollForRefresh $ refresher6 routing | ||
660 | |||
661 | forkAnnouncedInfohashesGC (contactInfo swarms) | ||
662 | |||
663 | return (client, routing, bootstrap (refresher4 routing), bootstrap (refresher6 routing)) | ||
664 | |||
665 | -- Note that you should call .put() every hour for content that you want to | ||
666 | -- keep alive, since nodes may discard data nodes older than 2 hours. (source: | ||
667 | -- https://www.npmjs.com/package/bittorrent-dht) | ||
668 | -- | ||
669 | -- This function will discard records between 3 and 6 hours old. | ||
670 | forkAnnouncedInfohashesGC :: TVar PeerStore -> IO ThreadId | ||
671 | forkAnnouncedInfohashesGC vpeers = fork $ do | ||
672 | myThreadId >>= flip labelThread "gc:bt-peers" | ||
673 | fix $ \loop -> do | ||
674 | cutoff <- getPOSIXTime | ||
675 | threadDelay 10800000000 -- 3 hours | ||
676 | atomically $ modifyTVar' vpeers $ deleteOlderThan cutoff | ||
677 | loop | ||
678 | |||
679 | -- | Modifies a purely random 'NodeId' to one that is related to a given | ||
680 | -- routable address in accordance with BEP 42. | ||
681 | -- | ||
682 | -- Test vectors from the spec: | ||
683 | -- | ||
684 | -- IP rand example node ID | ||
685 | -- ============ ===== ========================================== | ||
686 | -- 124.31.75.21 1 5fbfbf f10c5d6a4ec8a88e4c6ab4c28b95eee4 01 | ||
687 | -- 21.75.31.124 86 5a3ce9 c14e7a08645677bbd1cfe7d8f956d532 56 | ||
688 | -- 65.23.51.170 22 a5d432 20bc8f112a3d426c84764f8c2a1150e6 16 | ||
689 | -- 84.124.73.14 65 1b0321 dd1bb1fe518101ceef99462b947a01ff 41 | ||
690 | -- 43.213.53.83 90 e56f6c bf5b7c4be0237986d5243b87aa6d5130 5a | ||
691 | bep42 :: SockAddr -> NodeId -> Maybe NodeId | ||
692 | bep42 addr0 (NodeId r) | ||
693 | | let addr = either id id $ either4or6 addr0 -- unmap 4mapped SockAddrs | ||
694 | , Just ip <- fmap S.encode (fromSockAddr addr :: Maybe IPv4) | ||
695 | <|> fmap S.encode (fromSockAddr addr :: Maybe IPv6) | ||
696 | = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0) | ||
697 | | otherwise | ||
698 | = Nothing | ||
699 | where | ||
700 | ip4mask = "\x03\x0f\x3f\xff" :: ByteString | ||
701 | ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString | ||
702 | nbhood_select = B.last r .&. 7 | ||
703 | retr n = pure $ B.drop (B.length r - n) r | ||
704 | crc = S.encode . crc32c . B.pack | ||
705 | applyMask ip = case B.zipWith (.&.) msk ip of | ||
706 | (b:bs) -> (b .|. shiftL nbhood_select 5) : bs | ||
707 | bs -> bs | ||
708 | where msk | B.length ip == 4 = ip4mask | ||
709 | | otherwise = ip6mask | ||
710 | |||
711 | |||
712 | |||
713 | defaultHandler :: ByteString -> Handler | ||
714 | defaultHandler meth = MethodHandler decodePayload errorPayload returnError | ||
715 | where | ||
716 | returnError :: NodeInfo -> BValue -> IO Error | ||
717 | returnError _ _ = return $ Error MethodUnknown ("Unknown method " <> meth) | ||
718 | |||
719 | mainlineKademlia :: MainlineClient | ||
720 | -> TriadCommittee NodeId SockAddr | ||
721 | -> BucketRefresher NodeId NodeInfo | ||
722 | -> Kademlia NodeId NodeInfo | ||
723 | mainlineKademlia client committee refresher | ||
724 | = Kademlia quietInsertions | ||
725 | mainlineSpace | ||
726 | (vanillaIO (refreshBuckets refresher) $ ping client) | ||
727 | { tblTransition = \tr -> do | ||
728 | io1 <- transitionCommittee committee tr | ||
729 | io2 <- touchBucket refresher tr | ||
730 | return $ do | ||
731 | io1 >> io2 | ||
732 | {- noisy (timestamp updates are currently reported as transitions to Accepted) | ||
733 | dput XBitTorrent $ unwords | ||
734 | [ show (transitionedTo tr) | ||
735 | , show (transitioningNode tr) | ||
736 | ] -} | ||
737 | } | ||
738 | |||
739 | |||
740 | mainlineSpace :: R.KademliaSpace NodeId NodeInfo | ||
741 | mainlineSpace = R.KademliaSpace | ||
742 | { R.kademliaLocation = nodeId | ||
743 | , R.kademliaTestBit = testIdBit | ||
744 | , R.kademliaXor = xor | ||
745 | , R.kademliaSample = genBucketSample' | ||
746 | } | ||
747 | |||
748 | transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ()) | ||
749 | transitionCommittee committee (RoutingTransition ni Stranger) = do | ||
750 | delVote committee (nodeId ni) | ||
751 | return $ do | ||
752 | dput XBitTorrent $ "delVote "++show (nodeId ni) | ||
753 | transitionCommittee committee _ = return $ return () | ||
754 | |||
755 | updateRouting :: MainlineClient -> Routing -> NodeInfo -> Message BValue -> IO () | ||
756 | updateRouting client routing naddr msg = do | ||
757 | case prefer4or6 naddr Nothing of | ||
758 | Want_IP4 -> go (committee4 routing) (refresher4 routing) | ||
759 | Want_IP6 -> go (committee6 routing) (refresher6 routing) | ||
760 | where | ||
761 | go committee refresher = do | ||
762 | self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher) | ||
763 | when (nodeIP self /= nodeIP naddr) $ do | ||
764 | case msg of | ||
765 | R { rspReflectedIP = Just sockaddr } | ||
766 | -> do | ||
767 | -- dput XBitTorrent $ "External: "++show (nodeId naddr,sockaddr) | ||
768 | atomically $ addVote committee (nodeId naddr) sockaddr | ||
769 | _ -> return () | ||
770 | insertNode (mainlineKademlia client committee refresher) naddr | ||
771 | |||
772 | data Ping = Ping deriving Show | ||
773 | |||
774 | -- Pong is the same as Ping. | ||
775 | type Pong = Ping | ||
776 | pattern Pong = Ping | ||
777 | |||
778 | instance BEncode Ping where | ||
779 | toBEncode Ping = toDict endDict | ||
780 | fromBEncode _ = pure Ping | ||
781 | |||
782 | wantList :: WantIP -> [ByteString] | ||
783 | wantList Want_IP4 = ["ip4"] | ||
784 | wantList Want_IP6 = ["ip6"] | ||
785 | wantList Want_Both = ["ip4","ip6"] | ||
786 | |||
787 | instance BEncode WantIP where | ||
788 | toBEncode w = toBEncode $ wantList w | ||
789 | fromBEncode bval = do | ||
790 | wants <- fromBEncode bval | ||
791 | let _ = wants :: [ByteString] | ||
792 | case (elem "ip4" wants, elem "ip6" wants) of | ||
793 | (True,True) -> Right Want_Both | ||
794 | (True,False) -> Right Want_IP4 | ||
795 | (False,True) -> Right Want_IP6 | ||
796 | _ -> Left "Unrecognized IP type." | ||
797 | |||
798 | data FindNode = FindNode NodeId (Maybe WantIP) | ||
799 | |||
800 | instance BEncode FindNode where | ||
801 | toBEncode (FindNode nid iptyp) = toDict $ target_key .=! nid | ||
802 | .: want_key .=? iptyp | ||
803 | .: endDict | ||
804 | fromBEncode = fromDict $ FindNode <$>! target_key | ||
805 | <*>? want_key | ||
806 | |||
807 | data NodeFound = NodeFound | ||
808 | { nodes4 :: [NodeInfo] | ||
809 | , nodes6 :: [NodeInfo] | ||
810 | } | ||
811 | |||
812 | instance BEncode NodeFound where | ||
813 | toBEncode (NodeFound ns ns6) = toDict $ | ||
814 | nodes_key .=? | ||
815 | (if Prelude.null ns then Nothing | ||
816 | else Just (S.runPut (mapM_ putNodeInfo4 ns))) | ||
817 | .: nodes6_key .=? | ||
818 | (if Prelude.null ns6 then Nothing | ||
819 | else Just (S.runPut (mapM_ putNodeInfo6 ns6))) | ||
820 | .: endDict | ||
821 | |||
822 | fromBEncode bval = NodeFound <$> ns4 <*> ns6 | ||
823 | where | ||
824 | opt ns = fromMaybe [] <$> optional ns | ||
825 | ns4 = opt $ fromDict (binary getNodeInfo4 nodes_key) bval | ||
826 | ns6 = opt $ fromDict (binary getNodeInfo6 nodes6_key) bval | ||
827 | |||
828 | binary :: S.Get a -> BKey -> BE.Get [a] | ||
829 | binary get k = field (req k) >>= either (fail . format) return . | ||
830 | S.runGet (many get) | ||
831 | where | ||
832 | format str = "fail to deserialize " ++ show k ++ " field: " ++ str | ||
833 | |||
834 | pingH :: NodeInfo -> Ping -> IO Pong | ||
835 | pingH _ Ping = return Pong | ||
836 | |||
837 | prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP | ||
838 | prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp | ||
839 | |||
840 | findNodeH :: Routing -> NodeInfo -> FindNode -> IO NodeFound | ||
841 | findNodeH routing addr (FindNode node iptyp) = do | ||
842 | let preferred = prefer4or6 addr iptyp | ||
843 | |||
844 | (append4,append6) <- atomically $ do | ||
845 | ni4 <- R.thisNode <$> readTVar (routing4 routing) | ||
846 | ni6 <- R.thisNode <$> readTVar (routing6 routing) | ||
847 | return $ case ipFamily (nodeIP addr) of | ||
848 | Want_IP4 -> (id, (++ [ni6])) | ||
849 | Want_IP6 -> ((++ [ni4]), id) | ||
850 | ks <- bool (return []) (go append4 $ routing4 routing) (preferred /= Want_IP6) | ||
851 | ks6 <- bool (return []) (go append6 $ routing6 routing) (preferred /= Want_IP4) | ||
852 | return $ NodeFound ks ks6 | ||
853 | where | ||
854 | go f var = f . R.kclosest mainlineSpace k node <$> atomically (readTVar var) | ||
855 | |||
856 | k = R.defaultK | ||
857 | |||
858 | |||
859 | data GetPeers = GetPeers InfoHash (Maybe WantIP) | ||
860 | |||
861 | instance BEncode GetPeers where | ||
862 | toBEncode (GetPeers ih iptyp) | ||
863 | = toDict $ info_hash_key .=! ih | ||
864 | .: want_key .=? iptyp | ||
865 | .: endDict | ||
866 | fromBEncode = fromDict $ GetPeers <$>! info_hash_key <*>? want_key | ||
867 | |||
868 | |||
869 | data GotPeers = GotPeers | ||
870 | { -- | If the queried node has no peers for the infohash, returned | ||
871 | -- the K nodes in the queried nodes routing table closest to the | ||
872 | -- infohash supplied in the query. | ||
873 | peers :: [PeerAddr] | ||
874 | |||
875 | , nodes :: NodeFound | ||
876 | |||
877 | -- | The token value is a required argument for a future | ||
878 | -- announce_peer query. | ||
879 | , grantedToken :: Token | ||
880 | } -- deriving (Show, Eq, Typeable) | ||
881 | |||
882 | nodeIsIPv6 :: NodeInfo -> Bool | ||
883 | nodeIsIPv6 (NodeInfo _ (IPv6 _) _) = True | ||
884 | nodeIsIPv6 _ = False | ||
885 | |||
886 | instance BEncode GotPeers where | ||
887 | toBEncode GotPeers { nodes = NodeFound ns4 ns6, ..} = toDict $ | ||
888 | nodes_key .=? (if null ns4 then Nothing | ||
889 | else Just $ S.runPut (mapM_ putNodeInfo4 ns4)) | ||
890 | .: nodes6_key .=? (if null ns6 then Nothing | ||
891 | else Just $ S.runPut (mapM_ putNodeInfo4 ns6)) | ||
892 | .: token_key .=! grantedToken | ||
893 | .: peers_key .=! map S.encode peers | ||
894 | .: endDict | ||
895 | |||
896 | fromBEncode = fromDict $ do | ||
897 | ns4 <- fromMaybe [] <$> optional (binary getNodeInfo4 nodes_key) -- "nodes" | ||
898 | ns6 <- fromMaybe [] <$> optional (binary getNodeInfo6 nodes6_key) -- "nodes6" | ||
899 | -- TODO: BEP 42... | ||
900 | -- | ||
901 | -- Once enforced, responses to get_peers requests whose node ID does not | ||
902 | -- match its external IP should be considered to not contain a token and | ||
903 | -- thus not be eligible as storage target. Implementations should take | ||
904 | -- care that they find the closest set of nodes which return a token and | ||
905 | -- whose IDs matches their IPs before sending a store request to those | ||
906 | -- nodes. | ||
907 | -- | ||
908 | -- Sounds like something to take care of at peer-search time, so I'll | ||
909 | -- ignore it for now. | ||
910 | tok <- field (req token_key) -- "token" | ||
911 | ps <- fromMaybe [] <$> optional (field (req peers_key) >>= decodePeers) -- "values" | ||
912 | pure $ GotPeers ps (NodeFound ns4 ns6) tok | ||
913 | where | ||
914 | decodePeers = either fail pure . mapM S.decode | ||
915 | |||
916 | getPeersH :: Routing -> SwarmsDatabase -> NodeInfo -> GetPeers -> IO GotPeers | ||
917 | getPeersH routing (SwarmsDatabase peers toks _) naddr (GetPeers ih iptyp) = do | ||
918 | ps <- do | ||
919 | tm <- getTimestamp | ||
920 | atomically $ do | ||
921 | (ps,store') <- Peers.freshPeers ih tm <$> readTVar peers | ||
922 | writeTVar peers store' | ||
923 | return ps | ||
924 | -- Filter peer results to only a single address family, IPv4 or IPv6, as | ||
925 | -- per BEP 32. | ||
926 | let notboth = iptyp >>= \case Want_Both -> Nothing | ||
927 | specific -> Just specific | ||
928 | selected = prefer4or6 naddr notboth | ||
929 | ps' = filter ( (== selected) . ipFamily . peerHost ) ps | ||
930 | tok <- grantToken toks naddr | ||
931 | ns <- findNodeH routing naddr (FindNode (coerce ih) iptyp) | ||
932 | return $ GotPeers ps' ns tok | ||
933 | |||
934 | -- | Announce that the peer, controlling the querying node, is | ||
935 | -- downloading a torrent on a port. | ||
936 | data Announce = Announce | ||
937 | { -- | If set, the 'port' field should be ignored and the source | ||
938 | -- port of the UDP packet should be used as the peer's port | ||
939 | -- instead. This is useful for peers behind a NAT that may not | ||
940 | -- know their external port, and supporting uTP, they accept | ||
941 | -- incoming connections on the same port as the DHT port. | ||
942 | impliedPort :: Bool | ||
943 | |||
944 | -- | infohash of the torrent; | ||
945 | , topic :: InfoHash | ||
946 | |||
947 | -- | some clients announce the friendly name of the torrent here. | ||
948 | , announcedName :: Maybe ByteString | ||
949 | |||
950 | -- | the port /this/ peer is listening; | ||
951 | , port :: PortNumber | ||
952 | |||
953 | -- TODO: optional boolean "seed" key | ||
954 | |||
955 | -- | received in response to a previous get_peers query. | ||
956 | , sessionToken :: Token | ||
957 | |||
958 | } deriving (Show, Eq, Typeable) | ||
959 | |||
960 | mkAnnounce :: PortNumber -> InfoHash -> Token -> Announce | ||
961 | mkAnnounce portnum info token = Announce | ||
962 | { topic = info | ||
963 | , port = portnum | ||
964 | , sessionToken = token | ||
965 | , announcedName = Nothing | ||
966 | , impliedPort = False | ||
967 | } | ||
968 | |||
969 | |||
970 | instance BEncode Announce where | ||
971 | toBEncode Announce {..} = toDict $ | ||
972 | implied_port_key .=? flagField impliedPort | ||
973 | .: info_hash_key .=! topic | ||
974 | .: name_key .=? announcedName | ||
975 | .: port_key .=! port | ||
976 | .: token_key .=! sessionToken | ||
977 | .: endDict | ||
978 | where | ||
979 | flagField flag = if flag then Just (1 :: Int) else Nothing | ||
980 | |||
981 | fromBEncode = fromDict $ do | ||
982 | Announce <$> (boolField <$> optional (field (req implied_port_key))) | ||
983 | <*>! info_hash_key | ||
984 | <*>? name_key | ||
985 | <*>! port_key | ||
986 | <*>! token_key | ||
987 | where | ||
988 | boolField = maybe False (/= (0 :: Int)) | ||
989 | |||
990 | |||
991 | |||
992 | -- | The queried node must verify that the token was previously sent | ||
993 | -- to the same IP address as the querying node. Then the queried node | ||
994 | -- should store the IP address of the querying node and the supplied | ||
995 | -- port number under the infohash in its store of peer contact | ||
996 | -- information. | ||
997 | data Announced = Announced | ||
998 | deriving (Show, Eq, Typeable) | ||
999 | |||
1000 | instance BEncode Announced where | ||
1001 | toBEncode _ = toBEncode Ping | ||
1002 | fromBEncode _ = pure Announced | ||
1003 | |||
1004 | announceH :: SwarmsDatabase -> NodeInfo -> Announce -> IO (Either Error Announced) | ||
1005 | announceH (SwarmsDatabase peers toks _) naddr announcement = do | ||
1006 | checkToken toks naddr (sessionToken announcement) | ||
1007 | >>= bool (Left <$> return (Error ProtocolError "invalid parameter: token")) | ||
1008 | (Right <$> go) | ||
1009 | where | ||
1010 | go = atomically $ do | ||
1011 | modifyTVar' peers | ||
1012 | $ insertPeer (topic announcement) (announcedName announcement) | ||
1013 | $ PeerAddr | ||
1014 | { peerId = Nothing | ||
1015 | -- Avoid storing IPv4-mapped addresses. | ||
1016 | , peerHost = case nodeIP naddr of | ||
1017 | IPv6 ip6 | Just ip4 <- un4map ip6 -> IPv4 ip4 | ||
1018 | a -> a | ||
1019 | , peerPort = if impliedPort announcement | ||
1020 | then nodePort naddr | ||
1021 | else port announcement | ||
1022 | } | ||
1023 | return Announced | ||
1024 | |||
1025 | isReadonlyClient :: MainlineClient -> Bool | ||
1026 | isReadonlyClient client = False -- TODO | ||
1027 | |||
1028 | mainlineSend :: ( BEncode a | ||
1029 | , BEncode a2 | ||
1030 | ) => Method | ||
1031 | -> (a2 -> b) | ||
1032 | -> (t -> a) | ||
1033 | -> MainlineClient | ||
1034 | -> t | ||
1035 | -> NodeInfo | ||
1036 | -> IO (Maybe b) | ||
1037 | mainlineSend meth unwrap msg client nid addr = do | ||
1038 | reply <- sendQuery client (mainlineSerializeer meth unwrap client) (msg nid) addr | ||
1039 | -- sendQuery will return (Just (Left _)) on a parse error. We're going to | ||
1040 | -- blow it away with the join-either sequence. | ||
1041 | -- TODO: Do something with parse errors. | ||
1042 | return $ join $ either (const Nothing) Just <$> reply | ||
1043 | |||
1044 | mainlineAsync :: (BEncode a1, BEncode a2) => | ||
1045 | Method | ||
1046 | -> (a2 -> a3) | ||
1047 | -> (t -> a1) | ||
1048 | -> Client String Method TransactionId NodeInfo (Message BValue) | ||
1049 | -> t | ||
1050 | -> NodeInfo | ||
1051 | -> (Maybe a3 -> IO ()) | ||
1052 | -> IO () | ||
1053 | mainlineAsync meth unwrap msg client nid addr onresult = do | ||
1054 | asyncQuery client (mainlineSerializeer meth unwrap client) (msg nid) addr | ||
1055 | $ \reply -> | ||
1056 | -- sendQuery will return (Just (Left _)) on a parse error. We're going to | ||
1057 | -- blow it away with the join-either sequence. | ||
1058 | -- TODO: Do something with parse errors. | ||
1059 | onresult $ join $ either (const Nothing) Just <$> reply | ||
1060 | |||
1061 | mainlineSerializeer :: (BEncode a2, BEncode a1) => | ||
1062 | Method | ||
1063 | -> (a2 -> b) | ||
1064 | -> MainlineClient | ||
1065 | -> MethodSerializer | ||
1066 | TransactionId NodeInfo (Message BValue) Method a1 (Either Error b) | ||
1067 | mainlineSerializeer meth unwrap client = MethodSerializer | ||
1068 | { methodTimeout = \_ ni -> return (ni, 5000000) | ||
1069 | , method = meth | ||
1070 | , wrapQuery = encodeQueryPayload meth (isReadonlyClient client) | ||
1071 | , unwrapResponse = (>>= either (Left . Error GenericError . C8.pack) | ||
1072 | (Right . unwrap) | ||
1073 | . BE.fromBEncode) | ||
1074 | . rspPayload | ||
1075 | } | ||
1076 | |||
1077 | ping :: MainlineClient -> NodeInfo -> IO Bool | ||
1078 | ping client addr = | ||
1079 | fromMaybe False | ||
1080 | <$> mainlineSend (Method "ping") (\Pong -> True) (const Ping) client () addr | ||
1081 | |||
1082 | -- searchQuery :: ni -> IO (Maybe [ni], [r], tok)) | ||
1083 | getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | ||
1084 | getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) | ||
1085 | |||
1086 | asyncGetNodes :: Client String Method TransactionId NodeInfo (Message BValue) | ||
1087 | -> NodeId | ||
1088 | -> NodeInfo | ||
1089 | -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ()) | ||
1090 | -> IO () | ||
1091 | asyncGetNodes = mainlineAsync (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) | ||
1092 | |||
1093 | unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ()) | ||
1094 | unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ()) | ||
1095 | |||
1096 | getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token)) | ||
1097 | getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce | ||
1098 | |||
1099 | asyncGetPeers :: Client String Method TransactionId NodeInfo (Message BValue) | ||
1100 | -> NodeId | ||
1101 | -> NodeInfo | ||
1102 | -> (Maybe ([NodeInfo], [PeerAddr], Maybe Token) -> IO ()) | ||
1103 | -> IO () | ||
1104 | asyncGetPeers = mainlineAsync (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce | ||
1105 | |||
1106 | unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token) | ||
1107 | unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok) | ||
1108 | |||
1109 | mainlineSearch :: Either (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], Maybe tok))) | ||
1110 | (NodeId -> NodeInfo -> (Maybe ([NodeInfo], [r], Maybe tok) -> IO ()) -> IO ()) | ||
1111 | -> Search NodeId (IP, PortNumber) tok NodeInfo r | ||
1112 | mainlineSearch qry = Search | ||
1113 | { searchSpace = mainlineSpace | ||
1114 | , searchNodeAddress = nodeIP &&& nodePort | ||
1115 | , searchQuery = qry | ||
1116 | , searchAlpha = 8 | ||
1117 | , searchK = 16 | ||
1118 | } | ||
1119 | |||
1120 | nodeSearch :: MainlineClient -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo | ||
1121 | nodeSearch client = mainlineSearch (Right $ asyncGetNodes client) | ||
1122 | |||
1123 | peerSearch :: MainlineClient -> Search NodeId (IP, PortNumber) Token NodeInfo PeerAddr | ||
1124 | peerSearch client = mainlineSearch (Right $ asyncGetPeers client) | ||
1125 | |||
1126 | -- | List of bootstrap nodes maintained by different bittorrent | ||
1127 | -- software authors. | ||
1128 | bootstrapNodes :: WantIP -> IO [NodeInfo] | ||
1129 | bootstrapNodes want = unsafeInterleaveIO $ do | ||
1130 | let wellknowns = | ||
1131 | [ "router.bittorrent.com:6881" -- by BitTorrent Inc. | ||
1132 | |||
1133 | -- doesn't work at the moment (use git blame) of commit | ||
1134 | , "dht.transmissionbt.com:6881" -- by Transmission project | ||
1135 | |||
1136 | , "router.utorrent.com:6881" | ||
1137 | ] | ||
1138 | nss <- forM wellknowns $ \hostAndPort -> do | ||
1139 | e <- resolve want hostAndPort | ||
1140 | case e of | ||
1141 | Left _ -> return [] | ||
1142 | Right sockaddr -> either (const $ return []) | ||
1143 | (return . (: [])) | ||
1144 | $ nodeInfo zeroID sockaddr | ||
1145 | return $ concat nss | ||
1146 | |||
1147 | -- | Resolve either a numeric network address or a hostname to a | ||
1148 | -- numeric IP address of the node. | ||
1149 | resolve :: WantIP -> String -> IO (Either IOError SockAddr) | ||
1150 | resolve want hostAndPort = do | ||
1151 | let hints = defaultHints { addrSocketType = Datagram | ||
1152 | , addrFamily = case want of | ||
1153 | Want_IP4 -> AF_INET | ||
1154 | _ -> AF_INET6 | ||
1155 | } | ||
1156 | (rport,rhost) = span (/= ':') $ reverse hostAndPort | ||
1157 | (host,port) = case rhost of | ||
1158 | [] -> (hostAndPort, Nothing) | ||
1159 | (_:hs) -> (reverse hs, Just (reverse rport)) | ||
1160 | tryIOError $ do | ||
1161 | -- getAddrInfo throws exception on empty list, so this | ||
1162 | -- pattern matching never fails. | ||
1163 | info : _ <- getAddrInfo (Just hints) (Just host) port | ||
1164 | return $ addrAddress info | ||
1165 | |||
1166 | |||
1167 | announce :: MainlineClient -> Announce -> NodeInfo -> IO (Maybe Announced) | ||
1168 | announce client msg addr = do | ||
1169 | mainlineSend (Method "announce_peer") id (\() -> msg) client () addr | ||
diff --git a/dht/src/Network/BitTorrent/MainlineDHT/Symbols.hs b/dht/src/Network/BitTorrent/MainlineDHT/Symbols.hs new file mode 100644 index 00000000..05a64014 --- /dev/null +++ b/dht/src/Network/BitTorrent/MainlineDHT/Symbols.hs | |||
@@ -0,0 +1,24 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} | ||
2 | module Network.BitTorrent.MainlineDHT.Symbols where | ||
3 | |||
4 | import Data.BEncode.BDict | ||
5 | |||
6 | peer_ip_key = "ip" :: BKey | ||
7 | peer_id_key = "peer id" :: BKey | ||
8 | peer_port_key = "port" :: BKey | ||
9 | msg_type_key = "msg_type" :: BKey | ||
10 | piece_key = "piece" :: BKey | ||
11 | total_size_key = "total_size" :: BKey | ||
12 | node_id_key = "id" :: BKey | ||
13 | read_only_key = "ro" :: BKey | ||
14 | want_key = "want" :: BKey | ||
15 | target_key = "target" :: BKey | ||
16 | nodes_key = "nodes" :: BKey | ||
17 | nodes6_key = "nodes6" :: BKey | ||
18 | info_hash_key = "info_hash" :: BKey | ||
19 | peers_key = "values" :: BKey | ||
20 | token_key = "token" :: BKey | ||
21 | name_key = "name" :: BKey | ||
22 | port_key = "port" :: BKey | ||
23 | implied_port_key = "implied_port" :: BKey | ||
24 | |||
diff --git a/dht/src/Network/Lossless.hs b/dht/src/Network/Lossless.hs new file mode 100644 index 00000000..861792ab --- /dev/null +++ b/dht/src/Network/Lossless.hs | |||
@@ -0,0 +1,124 @@ | |||
1 | -- | This module uses 'Data.PacketBuffer' appropriately to implement a reliable | ||
2 | -- transport over an underlying lossy one. | ||
3 | -- | ||
4 | -- It was written to be a helper to 'Network.Tox.Session' but it is | ||
5 | -- representation-agnostic and so could potentially be used on an unrelated | ||
6 | -- lossy transport. | ||
7 | {-# LANGUAGE CPP #-} | ||
8 | {-# LANGUAGE LambdaCase #-} | ||
9 | {-# LANGUAGE TupleSections #-} | ||
10 | module Network.Lossless where | ||
11 | |||
12 | import Control.Concurrent.STM.TChan | ||
13 | import Control.Monad | ||
14 | import Control.Monad.STM | ||
15 | import Data.Function | ||
16 | import Data.Word | ||
17 | import System.IO.Error | ||
18 | |||
19 | import Data.PacketBuffer as PB | ||
20 | import DPut | ||
21 | import DebugTag | ||
22 | import Network.QueryResponse | ||
23 | |||
24 | #ifdef THREAD_DEBUG | ||
25 | import Control.Concurrent.Lifted.Instrument | ||
26 | #else | ||
27 | import Control.Concurrent.Lifted | ||
28 | #endif | ||
29 | |||
30 | -- | Sequencing information for a packet. | ||
31 | data SequenceInfo = SequenceInfo | ||
32 | { sequenceNumber :: {-# UNPACK #-} !Word32 -- ^ Packets are ordered by their 'sequenceNumber'. | ||
33 | , sequenceAck :: {-# UNPACK #-} !Word32 -- ^ This is the sender's latest received in-order packet. | ||
34 | } | ||
35 | deriving (Eq,Ord,Show) | ||
36 | |||
37 | data OutgoingInfo y = OutgoingInfo | ||
38 | { oIsLossy :: Bool -- ^ True if the packet is treated as lossy. | ||
39 | , oEncoded :: y -- ^ The packet. | ||
40 | , oHandleException :: Maybe (IOError -> IO ()) -- ^ Optionally handle send failure. | ||
41 | } | ||
42 | |||
43 | -- | Obtain a reliable transport form an unreliable one. | ||
44 | lossless :: Show addr => | ||
45 | (x -> addr -> IO (PacketInboundEvent (x',addr'))) -- ^ Used to classify newly arrived packets. | ||
46 | -> (SequenceInfo -> x' -> addr' -> IO (OutgoingInfo y)) -- ^ Used to encode and classify outbound packets. | ||
47 | -> addr -- ^ The remote address for this session. | ||
48 | -> TransportA String addr x y -- ^ An unreliable lossy transport. | ||
49 | |||
50 | -> IO ( Transport String addr' x' -- ^ A reliable lossless transport. | ||
51 | , [Word32] -> IO () -- ^ Use this to request lost packets be re-sent. | ||
52 | , IO ([Word32],Word32) -- ^ Use this to discover missing packets to request. | ||
53 | ) | ||
54 | lossless isLossless encode saddr udp = do | ||
55 | pb <- atomically newPacketBuffer | ||
56 | oob <- atomically newTChan -- Out-of-band channel, these packets (or | ||
57 | -- errors) bypass the packet buffer to be | ||
58 | -- received immediately. | ||
59 | rloop <- forkIO $ do | ||
60 | -- This thread enqueues inbound packets or writes them to the oob | ||
61 | -- channel. | ||
62 | myThreadId >>= flip labelThread ("lossless."++show saddr) | ||
63 | fix $ \loop -> do | ||
64 | awaitMessage udp $ \m -> do | ||
65 | m' <- mapM (mapM $ uncurry isLossless) m | ||
66 | case m' of | ||
67 | Nothing -> do | ||
68 | atomically $ writeTChan oob Nothing | ||
69 | -- Quit thread here. | ||
70 | Just (Left e) -> do | ||
71 | atomically $ writeTChan oob (Just $ Left e) | ||
72 | loop | ||
73 | Just (Right event) -> do | ||
74 | atomically $ do | ||
75 | -- x' <- isLossless xaddr x | ||
76 | PB.grokInboundPacket pb event | ||
77 | case event of | ||
78 | PacketReceivedLossy {} -> writeTChan oob (Just $ Right $ peReceivedPayload event) | ||
79 | _ -> do | ||
80 | report <- pbReport "enqueued" pb | ||
81 | writeTChan oob (Just $ Left report) | ||
82 | loop | ||
83 | let tr = Transport | ||
84 | { awaitMessage = \kont -> do | ||
85 | join $ atomically $ orElse | ||
86 | (do x <- readTChan oob | ||
87 | return $ kont $! x) | ||
88 | (do x <- PB.awaitReadyPacket pb | ||
89 | report <- pbReport "dequeued" pb | ||
90 | return $ do | ||
91 | atomically $ writeTChan oob (Just $ Left report) | ||
92 | kont $! Just (Right x)) | ||
93 | , sendMessage = \a' x' -> do | ||
94 | seqno <- atomically $ do | ||
95 | seqno <- PB.nextToSendSequenceNumber pb | ||
96 | ack <- PB.expectingSequenceNumber pb | ||
97 | return $ SequenceInfo seqno ack | ||
98 | OutgoingInfo islossy x oops <- encode seqno x' a' | ||
99 | (isfull,nn) <- | ||
100 | if islossy | ||
101 | then do | ||
102 | dput XNetCrypto $ shows saddr $ " <-- Lossy packet " ++ show seqno | ||
103 | return (False,(0,0)) -- avoid updating seqno on lossy packets. | ||
104 | else do | ||
105 | dput XNetCrypto $ shows saddr $ " <-- Lossless packet " ++ show seqno | ||
106 | atomically $ PB.grokOutboundPacket pb (PacketSent (sequenceNumber seqno) x) | ||
107 | when isfull $ do | ||
108 | dput XNetCrypto $ shows saddr $ " <-- Outbound queue is full! Retrying... " ++ show (nn,seqno) | ||
109 | atomically $ do | ||
110 | (isfull,_) <- PB.grokOutboundPacket pb (PacketSent (sequenceNumber seqno) x) | ||
111 | when isfull retry | ||
112 | let sendit = sendMessage udp saddr x | ||
113 | maybe sendit (catchIOError sendit) oops | ||
114 | , closeTransport = do | ||
115 | atomically $ writeTChan oob Nothing -- quit rloop thread | ||
116 | closeTransport udp | ||
117 | } | ||
118 | resend ns = do | ||
119 | xs <- atomically $ retrieveForResend pb ns | ||
120 | dput XNetCrypto $ shows saddr $ " <-- Resending " ++ show (length xs) ++ " packets." | ||
121 | forM_ xs $ \x -> do | ||
122 | dput XNetCrypto $ shows saddr $ " <-- Resending packet." | ||
123 | sendMessage udp saddr . snd $ x | ||
124 | return (tr, resend, atomically $ PB.packetNumbersToRequest pb) | ||
diff --git a/dht/src/Network/QueryResponse.hs b/dht/src/Network/QueryResponse.hs new file mode 100644 index 00000000..c4ff50e3 --- /dev/null +++ b/dht/src/Network/QueryResponse.hs | |||
@@ -0,0 +1,638 @@ | |||
1 | -- | This module can implement any query\/response protocol. It was written | ||
2 | -- with Kademlia implementations in mind. | ||
3 | |||
4 | {-# LANGUAGE CPP #-} | ||
5 | {-# LANGUAGE GADTs #-} | ||
6 | {-# LANGUAGE LambdaCase #-} | ||
7 | {-# LANGUAGE PartialTypeSignatures #-} | ||
8 | {-# LANGUAGE RankNTypes #-} | ||
9 | {-# LANGUAGE ScopedTypeVariables #-} | ||
10 | {-# LANGUAGE TupleSections #-} | ||
11 | module Network.QueryResponse where | ||
12 | |||
13 | #ifdef THREAD_DEBUG | ||
14 | import Control.Concurrent.Lifted.Instrument | ||
15 | #else | ||
16 | import Control.Concurrent | ||
17 | import GHC.Conc (labelThread) | ||
18 | #endif | ||
19 | import Control.Concurrent.STM | ||
20 | import Control.Exception | ||
21 | import Control.Monad | ||
22 | import qualified Data.ByteString as B | ||
23 | ;import Data.ByteString (ByteString) | ||
24 | import Data.Function | ||
25 | import Data.Functor.Contravariant | ||
26 | import qualified Data.IntMap.Strict as IntMap | ||
27 | ;import Data.IntMap.Strict (IntMap) | ||
28 | import qualified Data.Map.Strict as Map | ||
29 | ;import Data.Map.Strict (Map) | ||
30 | import Data.Time.Clock.POSIX | ||
31 | import qualified Data.Word64Map as W64Map | ||
32 | ;import Data.Word64Map (Word64Map) | ||
33 | import Data.Word | ||
34 | import Data.Maybe | ||
35 | import GHC.Event | ||
36 | import Network.Socket | ||
37 | import Network.Socket.ByteString as B | ||
38 | import System.Endian | ||
39 | import System.IO | ||
40 | import System.IO.Error | ||
41 | import System.Timeout | ||
42 | import DPut | ||
43 | import DebugTag | ||
44 | import Data.TableMethods | ||
45 | |||
46 | -- | Three methods are required to implement a datagram based query\/response protocol. | ||
47 | data TransportA err addr x y = Transport | ||
48 | { -- | Blocks until an inbound packet is available. Returns 'Nothing' when | ||
49 | -- no more packets are expected due to a shutdown or close event. | ||
50 | -- Otherwise, the packet will be parsed as type /x/ and an origin address | ||
51 | -- /addr/. Parse failure is indicated by the type 'err'. | ||
52 | awaitMessage :: forall a. (Maybe (Either err (x, addr)) -> IO a) -> IO a | ||
53 | -- | Send an /y/ packet to the given destination /addr/. | ||
54 | , sendMessage :: addr -> y -> IO () | ||
55 | -- | Shutdown and clean up any state related to this 'Transport'. | ||
56 | , closeTransport :: IO () | ||
57 | } | ||
58 | |||
59 | type Transport err addr x = TransportA err addr x x | ||
60 | |||
61 | -- | This function modifies a 'Transport' to use higher-level addresses and | ||
62 | -- packet representations. It could be used to change UDP 'ByteString's into | ||
63 | -- bencoded syntax trees or to add an encryption layer in which addresses have | ||
64 | -- associated public keys. | ||
65 | layerTransportM :: | ||
66 | (x -> addr -> IO (Either err (x', addr'))) | ||
67 | -- ^ Function that attempts to transform a low-level address/packet | ||
68 | -- pair into a higher level representation. | ||
69 | -> (y' -> addr' -> IO (y, addr)) | ||
70 | -- ^ Function to encode a high-level address/packet into a lower level | ||
71 | -- representation. | ||
72 | -> TransportA err addr x y | ||
73 | -- ^ The low-level transport to be transformed. | ||
74 | -> TransportA err addr' x' y' | ||
75 | layerTransportM parse encode tr = | ||
76 | tr { awaitMessage = \kont -> | ||
77 | awaitMessage tr $ \m -> mapM (mapM $ uncurry parse) m >>= kont . fmap join | ||
78 | , sendMessage = \addr' msg' -> do | ||
79 | (msg,addr) <- encode msg' addr' | ||
80 | sendMessage tr addr msg | ||
81 | } | ||
82 | |||
83 | |||
84 | -- | This function modifies a 'Transport' to use higher-level addresses and | ||
85 | -- packet representations. It could be used to change UDP 'ByteString's into | ||
86 | -- bencoded syntax trees or to add an encryption layer in which addresses have | ||
87 | -- associated public keys. | ||
88 | layerTransport :: | ||
89 | (x -> addr -> Either err (x', addr')) | ||
90 | -- ^ Function that attempts to transform a low-level address/packet | ||
91 | -- pair into a higher level representation. | ||
92 | -> (y' -> addr' -> (y, addr)) | ||
93 | -- ^ Function to encode a high-level address/packet into a lower level | ||
94 | -- representation. | ||
95 | -> TransportA err addr x y | ||
96 | -- ^ The low-level transport to be transformed. | ||
97 | -> TransportA err addr' x' y' | ||
98 | layerTransport parse encode tr = | ||
99 | layerTransportM (\x addr -> return $ parse x addr) | ||
100 | (\x' addr' -> return $ encode x' addr') | ||
101 | tr | ||
102 | |||
103 | -- | Paritions a 'Transport' into two higher-level transports. Note: An 'MVar' | ||
104 | -- is used to share the same underlying socket, so be sure to fork a thread for | ||
105 | -- both returned 'Transport's to avoid hanging. | ||
106 | partitionTransport :: ((b,a) -> Either (x,xaddr) (b,a)) | ||
107 | -> ((x,xaddr) -> Maybe (b,a)) | ||
108 | -> Transport err a b | ||
109 | -> IO (Transport err xaddr x, Transport err a b) | ||
110 | partitionTransport parse encodex tr = | ||
111 | partitionTransportM (return . parse) (return . encodex) tr | ||
112 | |||
113 | -- | Paritions a 'Transport' into two higher-level transports. Note: An 'MVar' | ||
114 | -- is used to share the same underlying socket, so be sure to fork a thread for | ||
115 | -- both returned 'Transport's to avoid hanging. | ||
116 | partitionTransportM :: ((b,a) -> IO (Either (x,xaddr) (b,a))) | ||
117 | -> ((x,xaddr) -> IO (Maybe (b,a))) | ||
118 | -> Transport err a b | ||
119 | -> IO (Transport err xaddr x, Transport err a b) | ||
120 | partitionTransportM parse encodex tr = do | ||
121 | mvar <- newEmptyMVar | ||
122 | let xtr = tr { awaitMessage = \kont -> fix $ \again -> do | ||
123 | awaitMessage tr $ \m -> case m of | ||
124 | Just (Right msg) -> parse msg >>= | ||
125 | either (kont . Just . Right) | ||
126 | (\y -> putMVar mvar y >> again) | ||
127 | Just (Left e) -> kont $ Just (Left e) | ||
128 | Nothing -> kont Nothing | ||
129 | , sendMessage = \addr' msg' -> do | ||
130 | msg_addr <- encodex (msg',addr') | ||
131 | mapM_ (uncurry . flip $ sendMessage tr) msg_addr | ||
132 | } | ||
133 | ytr = Transport | ||
134 | { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right | ||
135 | , sendMessage = sendMessage tr | ||
136 | , closeTransport = return () | ||
137 | } | ||
138 | return (xtr, ytr) | ||
139 | |||
140 | partitionAndForkTransport :: | ||
141 | (dst -> msg -> IO ()) | ||
142 | -> ((b,a) -> IO (Either (x,xaddr) (b,a))) | ||
143 | -> ((x,xaddr) -> IO (Maybe (Either (msg,dst) (b,a)))) | ||
144 | -> Transport err a b | ||
145 | -> IO (Transport err xaddr x, Transport err a b) | ||
146 | partitionAndForkTransport forkedSend parse encodex tr = do | ||
147 | mvar <- newEmptyMVar | ||
148 | let xtr = tr { awaitMessage = \kont -> fix $ \again -> do | ||
149 | awaitMessage tr $ \m -> case m of | ||
150 | Just (Right msg) -> parse msg >>= | ||
151 | either (kont . Just . Right) | ||
152 | (\y -> putMVar mvar y >> again) | ||
153 | Just (Left e) -> kont $ Just (Left e) | ||
154 | Nothing -> kont Nothing | ||
155 | , sendMessage = \addr' msg' -> do | ||
156 | msg_addr <- encodex (msg',addr') | ||
157 | case msg_addr of | ||
158 | Just (Right (b,a)) -> sendMessage tr a b | ||
159 | Just (Left (msg,dst)) -> forkedSend dst msg | ||
160 | Nothing -> return () | ||
161 | } | ||
162 | ytr = Transport | ||
163 | { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right | ||
164 | , sendMessage = sendMessage tr | ||
165 | , closeTransport = return () | ||
166 | } | ||
167 | return (xtr, ytr) | ||
168 | |||
169 | -- | | ||
170 | -- * f add x --> Nothing, consume x | ||
171 | -- --> Just id, leave x to a different handler | ||
172 | -- --> Just g, apply g to x and leave that to a different handler | ||
173 | addHandler :: (err -> IO ()) -> (addr -> x -> IO (Maybe (x -> x))) -> Transport err addr x -> Transport err addr x | ||
174 | addHandler onParseError f tr = tr | ||
175 | { awaitMessage = \kont -> fix $ \eat -> awaitMessage tr $ \m -> do | ||
176 | case m of | ||
177 | Just (Right (x, addr)) -> f addr x >>= maybe eat (kont . Just . Right . (, addr) . ($ x)) | ||
178 | Just (Left e ) -> onParseError e >> kont (Just $ Left e) | ||
179 | Nothing -> kont $ Nothing | ||
180 | } | ||
181 | |||
182 | -- | Modify a 'Transport' to invoke an action upon every received packet. | ||
183 | onInbound :: (addr -> x -> IO ()) -> Transport err addr x -> Transport err addr x | ||
184 | onInbound f tr = addHandler (const $ return ()) (\addr x -> f addr x >> return (Just id)) tr | ||
185 | |||
186 | -- * Using a query\/response client. | ||
187 | |||
188 | -- | Fork a thread that handles inbound packets. The returned action may be used | ||
189 | -- to terminate the thread and clean up any related state. | ||
190 | -- | ||
191 | -- Example usage: | ||
192 | -- | ||
193 | -- > -- Start client. | ||
194 | -- > quitServer <- forkListener "listener" (clientNet client) | ||
195 | -- > -- Send a query q, recieve a response r. | ||
196 | -- > r <- sendQuery client method q | ||
197 | -- > -- Quit client. | ||
198 | -- > quitServer | ||
199 | forkListener :: String -> Transport err addr x -> IO (IO ()) | ||
200 | forkListener name client = do | ||
201 | thread_id <- forkIO $ do | ||
202 | myThreadId >>= flip labelThread ("listener."++name) | ||
203 | fix $ awaitMessage client . const | ||
204 | dput XMisc $ "Listener died: " ++ name | ||
205 | return $ do | ||
206 | closeTransport client | ||
207 | killThread thread_id | ||
208 | |||
209 | asyncQuery_ :: Client err meth tid addr x | ||
210 | -> MethodSerializer tid addr x meth a b | ||
211 | -> a | ||
212 | -> addr | ||
213 | -> (Maybe b -> IO ()) | ||
214 | -> IO (tid,POSIXTime,Int) | ||
215 | asyncQuery_ (Client net d err pending whoami _) meth q addr0 withResponse = do | ||
216 | now <- getPOSIXTime | ||
217 | (tid,addr,expiry) <- atomically $ do | ||
218 | tbl <- readTVar pending | ||
219 | ((tid,addr,expiry), tbl') <- dispatchRegister (tableMethods d) | ||
220 | (methodTimeout meth) | ||
221 | now | ||
222 | (withResponse . fmap (unwrapResponse meth)) | ||
223 | addr0 | ||
224 | tbl | ||
225 | -- (addr,expiry) <- methodTimeout meth tid addr0 | ||
226 | writeTVar pending tbl' | ||
227 | return (tid,addr,expiry) | ||
228 | self <- whoami (Just addr) | ||
229 | mres <- do sendMessage net addr (wrapQuery meth tid self addr q) | ||
230 | return $ Just () | ||
231 | `catchIOError` (\e -> return Nothing) | ||
232 | return (tid,now,expiry) | ||
233 | |||
234 | asyncQuery :: Show meth => Client err meth tid addr x | ||
235 | -> MethodSerializer tid addr x meth a b | ||
236 | -> a | ||
237 | -> addr | ||
238 | -> (Maybe b -> IO ()) | ||
239 | -> IO () | ||
240 | asyncQuery client meth q addr withResponse0 = do | ||
241 | tm <- getSystemTimerManager | ||
242 | tidvar <- newEmptyMVar | ||
243 | timedout <- registerTimeout tm 1000000 $ do | ||
244 | dput XMisc $ "async TIMEDOUT " ++ show (method meth) | ||
245 | withResponse0 Nothing | ||
246 | tid <- takeMVar tidvar | ||
247 | dput XMisc $ "async TIMEDOUT mvar " ++ show (method meth) | ||
248 | case client of | ||
249 | Client { clientDispatcher = d, clientPending = pending } -> do | ||
250 | atomically $ readTVar pending >>= dispatchCancel (tableMethods d) tid >>= writeTVar pending | ||
251 | (tid,now,expiry) <- asyncQuery_ client meth q addr $ \x -> do | ||
252 | unregisterTimeout tm timedout | ||
253 | withResponse0 x | ||
254 | putMVar tidvar tid | ||
255 | updateTimeout tm timedout expiry | ||
256 | dput XMisc $ "FIN asyncQuery "++show (method meth)++" TIMEOUT="++show expiry | ||
257 | |||
258 | -- | Send a query to a remote peer. Note that this function will always time | ||
259 | -- out if 'forkListener' was never invoked to spawn a thread to receive and | ||
260 | -- dispatch the response. | ||
261 | sendQuery :: | ||
262 | forall err a b tbl x meth tid addr. | ||
263 | Client err meth tid addr x -- ^ A query/response implementation. | ||
264 | -> MethodSerializer tid addr x meth a b -- ^ Information for marshaling the query. | ||
265 | -> a -- ^ The outbound query. | ||
266 | -> addr -- ^ Destination address of query. | ||
267 | -> IO (Maybe b) -- ^ The response, or 'Nothing' if it timed out. | ||
268 | sendQuery c@(Client net d err pending whoami _) meth q addr0 = do | ||
269 | mvar <- newEmptyMVar | ||
270 | (tid,now,expiry) <- asyncQuery_ c meth q addr0 $ mapM_ (putMVar mvar) | ||
271 | mres <- timeout expiry $ takeMVar mvar | ||
272 | case mres of | ||
273 | Just b -> return $ Just b | ||
274 | Nothing -> do | ||
275 | atomically $ readTVar pending >>= dispatchCancel (tableMethods d) tid >>= writeTVar pending | ||
276 | return Nothing | ||
277 | |||
278 | -- * Implementing a query\/response 'Client'. | ||
279 | |||
280 | -- | All inputs required to implement a query\/response client. | ||
281 | data Client err meth tid addr x = forall tbl. Client | ||
282 | { -- | The 'Transport' used to dispatch and receive packets. | ||
283 | clientNet :: Transport err addr x | ||
284 | -- | Methods for handling inbound packets. | ||
285 | , clientDispatcher :: DispatchMethods tbl err meth tid addr x | ||
286 | -- | Methods for reporting various conditions. | ||
287 | , clientErrorReporter :: ErrorReporter addr x meth tid err | ||
288 | -- | State necessary for routing inbound responses and assigning unique | ||
289 | -- /tid/ values for outgoing queries. | ||
290 | , clientPending :: TVar tbl | ||
291 | -- | An action yielding this client\'s own address. It is invoked once | ||
292 | -- on each outbound and inbound packet. It is valid for this to always | ||
293 | -- return the same value. | ||
294 | -- | ||
295 | -- The argument, if supplied, is the remote address for the transaction. | ||
296 | -- This can be used to maintain consistent aliases for specific peers. | ||
297 | , clientAddress :: Maybe addr -> IO addr | ||
298 | -- | Transform a query /tid/ value to an appropriate response /tid/ | ||
299 | -- value. Normally, this would be the identity transformation, but if | ||
300 | -- /tid/ includes a unique cryptographic nonce, then it should be | ||
301 | -- generated here. | ||
302 | , clientResponseId :: tid -> IO tid | ||
303 | } | ||
304 | |||
305 | -- | An incoming message can be classified into three cases. | ||
306 | data MessageClass err meth tid addr x | ||
307 | = IsQuery meth tid -- ^ An unsolicited query is handled based on it's /meth/ value. Any response | ||
308 | -- should include the provided /tid/ value. | ||
309 | | IsResponse tid -- ^ A response to a outgoing query we associated with a /tid/ value. | ||
310 | | IsUnsolicited (addr -> addr -> IO (Maybe (x -> x))) -- ^ Transactionless informative packet. The io action will be invoked | ||
311 | -- with the source and destination address of a message. If it handles the | ||
312 | -- message, it should return Nothing. Otherwise, it should return a transform | ||
313 | -- (usually /id/) to apply before the next handler examines it. | ||
314 | | IsUnknown err -- ^ None of the above. | ||
315 | |||
316 | -- | Handler for an inbound query of type /x/ from an address of type _addr_. | ||
317 | data MethodHandler err tid addr x = forall a b. MethodHandler | ||
318 | { -- | Parse the query into a more specific type for this method. | ||
319 | methodParse :: x -> Either err a | ||
320 | -- | Serialize the response for transmission, given a context /ctx/ and the origin | ||
321 | -- and destination addresses. | ||
322 | , methodSerialize :: tid -> addr -> addr -> b -> x | ||
323 | -- | Fully typed action to perform upon the query. The remote origin | ||
324 | -- address of the query is provided to the handler. | ||
325 | , methodAction :: addr -> a -> IO b | ||
326 | } | ||
327 | -- | See also 'IsUnsolicited' which likely makes this constructor unnecessary. | ||
328 | | forall a. NoReply | ||
329 | { -- | Parse the query into a more specific type for this method. | ||
330 | methodParse :: x -> Either err a | ||
331 | -- | Fully typed action to perform upon the query. The remote origin | ||
332 | -- address of the query is provided to the handler. | ||
333 | , noreplyAction :: addr -> a -> IO () | ||
334 | } | ||
335 | |||
336 | contramapAddr :: (a -> b) -> MethodHandler err tid b x -> MethodHandler err tid a x | ||
337 | contramapAddr f (MethodHandler p s a) | ||
338 | = MethodHandler | ||
339 | p | ||
340 | (\tid src dst result -> s tid (f src) (f dst) result) | ||
341 | (\addr arg -> a (f addr) arg) | ||
342 | contramapAddr f (NoReply p a) | ||
343 | = NoReply p (\addr arg -> a (f addr) arg) | ||
344 | |||
345 | |||
346 | -- | Attempt to invoke a 'MethodHandler' upon a given inbound query. If the | ||
347 | -- parse is successful, the returned IO action will construct our reply if | ||
348 | -- there is one. Otherwise, a parse err is returned. | ||
349 | dispatchQuery :: MethodHandler err tid addr x -- ^ Handler to invoke. | ||
350 | -> tid -- ^ The transaction id for this query\/response session. | ||
351 | -> addr -- ^ Our own address, to which the query was sent. | ||
352 | -> x -- ^ The query packet. | ||
353 | -> addr -- ^ The origin address of the query. | ||
354 | -> Either err (IO (Maybe x)) | ||
355 | dispatchQuery (MethodHandler unwrapQ wrapR f) tid self x addr = | ||
356 | fmap (\a -> Just . wrapR tid self addr <$> f addr a) $ unwrapQ x | ||
357 | dispatchQuery (NoReply unwrapQ f) tid self x addr = | ||
358 | fmap (\a -> f addr a >> return Nothing) $ unwrapQ x | ||
359 | |||
360 | -- | These four parameters are required to implement an outgoing query. A | ||
361 | -- peer-to-peer algorithm will define a 'MethodSerializer' for every 'MethodHandler' that | ||
362 | -- might be returned by 'lookupHandler'. | ||
363 | data MethodSerializer tid addr x meth a b = MethodSerializer | ||
364 | { -- | Returns the microseconds to wait for a response to this query being | ||
365 | -- sent to the given address. The /addr/ may also be modified to add | ||
366 | -- routing information. | ||
367 | methodTimeout :: tid -> addr -> STM (addr,Int) | ||
368 | -- | A method identifier used for error reporting. This needn't be the | ||
369 | -- same as the /meth/ argument to 'MethodHandler', but it is suggested. | ||
370 | , method :: meth | ||
371 | -- | Serialize the outgoing query /a/ into a transmittable packet /x/. | ||
372 | -- The /addr/ arguments are, respectively, our own origin address and the | ||
373 | -- destination of the request. The /tid/ argument is useful for attaching | ||
374 | -- auxiliary notations on all outgoing packets. | ||
375 | , wrapQuery :: tid -> addr -> addr -> a -> x | ||
376 | -- | Parse an inbound packet /x/ into a response /b/ for this query. | ||
377 | , unwrapResponse :: x -> b | ||
378 | } | ||
379 | |||
380 | |||
381 | -- | To dispatch responses to our outbound queries, we require three | ||
382 | -- primitives. See the 'transactionMethods' function to create these | ||
383 | -- primitives out of a lookup table and a generator for transaction ids. | ||
384 | -- | ||
385 | -- The type variable /d/ is used to represent the current state of the | ||
386 | -- transaction generator and the table of pending transactions. | ||
387 | data TransactionMethods d tid addr x = TransactionMethods | ||
388 | { | ||
389 | -- | Before a query is sent, this function stores an 'MVar' to which the | ||
390 | -- response will be written too. The returned /tid/ is a transaction id | ||
391 | -- that can be used to forget the 'MVar' if the remote peer is not | ||
392 | -- responding. | ||
393 | dispatchRegister :: (tid -> addr -> STM (addr,Int)) -> POSIXTime -> (Maybe x -> IO ()) -> addr -> d -> STM ((tid,addr,Int), d) | ||
394 | -- | This method is invoked when an incoming packet /x/ indicates it is | ||
395 | -- a response to the transaction with id /tid/. The returned IO action | ||
396 | -- will write the packet to the correct 'MVar' thus completing the | ||
397 | -- dispatch. | ||
398 | , dispatchResponse :: tid -> x -> d -> STM (d, IO ()) | ||
399 | -- | When a timeout interval elapses, this method is called to remove the | ||
400 | -- transaction from the table. | ||
401 | , dispatchCancel :: tid -> d -> STM d | ||
402 | } | ||
403 | |||
404 | -- | Construct 'TransactionMethods' methods out of 3 lookup table primitives and a | ||
405 | -- function for generating unique transaction ids. | ||
406 | transactionMethods :: | ||
407 | TableMethods t tid -- ^ Table methods to lookup values by /tid/. | ||
408 | -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/. | ||
409 | -> TransactionMethods (g,t (Maybe x -> IO ())) tid addr x | ||
410 | transactionMethods methods generate = transactionMethods' id id methods generate | ||
411 | |||
412 | microsecondsDiff :: Int -> POSIXTime | ||
413 | microsecondsDiff us = fromIntegral us / 1000000 | ||
414 | |||
415 | -- | Like 'transactionMethods' but allows extra information to be stored in the | ||
416 | -- table of pending transactions. This also enables multiple 'Client's to | ||
417 | -- share a single transaction table. | ||
418 | transactionMethods' :: | ||
419 | ((Maybe x -> IO ()) -> a) -- ^ store MVar into table entry | ||
420 | -> (a -> Maybe x -> IO void) -- ^ load MVar from table entry | ||
421 | -> TableMethods t tid -- ^ Table methods to lookup values by /tid/. | ||
422 | -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/. | ||
423 | -> TransactionMethods (g,t a) tid addr x | ||
424 | transactionMethods' store load (TableMethods insert delete lookup) generate = TransactionMethods | ||
425 | { dispatchCancel = \tid (g,t) -> return (g, delete tid t) | ||
426 | , dispatchRegister = \getTimeout now v a0 (g,t) -> do | ||
427 | let (tid,g') = generate g | ||
428 | (a,expiry) <- getTimeout tid a0 | ||
429 | let t' = insert tid (store v) (now + microsecondsDiff expiry) t | ||
430 | return ( (tid,a,expiry), (g',t') ) | ||
431 | , dispatchResponse = \tid x (g,t) -> | ||
432 | case lookup tid t of | ||
433 | Just v -> let t' = delete tid t | ||
434 | in return ((g,t'),void $ load v $ Just x) | ||
435 | Nothing -> return ((g,t), return ()) | ||
436 | } | ||
437 | |||
438 | -- | A set of methods necessary for dispatching incoming packets. | ||
439 | data DispatchMethods tbl err meth tid addr x = DispatchMethods | ||
440 | { -- | Classify an inbound packet as a query or response. | ||
441 | classifyInbound :: x -> MessageClass err meth tid addr x | ||
442 | -- | Lookup the handler for a inbound query. | ||
443 | , lookupHandler :: meth -> Maybe (MethodHandler err tid addr x) | ||
444 | -- | Methods for handling incoming responses. | ||
445 | , tableMethods :: TransactionMethods tbl tid addr x | ||
446 | } | ||
447 | |||
448 | -- | These methods indicate what should be done upon various conditions. Write | ||
449 | -- to a log file, make debug prints, or simply ignore them. | ||
450 | -- | ||
451 | -- [ /addr/ ] Address of remote peer. | ||
452 | -- | ||
453 | -- [ /x/ ] Incoming or outgoing packet. | ||
454 | -- | ||
455 | -- [ /meth/ ] Method id of incoming or outgoing request. | ||
456 | -- | ||
457 | -- [ /tid/ ] Transaction id for outgoing packet. | ||
458 | -- | ||
459 | -- [ /err/ ] Error information, typically a 'String'. | ||
460 | data ErrorReporter addr x meth tid err = ErrorReporter | ||
461 | { -- | Incoming: failed to parse packet. | ||
462 | reportParseError :: err -> IO () | ||
463 | -- | Incoming: no handler for request. | ||
464 | , reportMissingHandler :: meth -> addr -> x -> IO () | ||
465 | -- | Incoming: unable to identify request. | ||
466 | , reportUnknown :: addr -> x -> err -> IO () | ||
467 | } | ||
468 | |||
469 | ignoreErrors :: ErrorReporter addr x meth tid err | ||
470 | ignoreErrors = ErrorReporter | ||
471 | { reportParseError = \_ -> return () | ||
472 | , reportMissingHandler = \_ _ _ -> return () | ||
473 | , reportUnknown = \_ _ _ -> return () | ||
474 | } | ||
475 | |||
476 | logErrors :: ( Show addr | ||
477 | , Show meth | ||
478 | ) => ErrorReporter addr x meth tid String | ||
479 | logErrors = ErrorReporter | ||
480 | { reportParseError = \err -> dput XMisc err | ||
481 | , reportMissingHandler = \meth addr x -> dput XMisc $ show addr ++ " --> Missing handler ("++show meth++")" | ||
482 | , reportUnknown = \addr x err -> dput XMisc $ show addr ++ " --> " ++ err | ||
483 | } | ||
484 | |||
485 | printErrors :: ( Show addr | ||
486 | , Show meth | ||
487 | ) => Handle -> ErrorReporter addr x meth tid String | ||
488 | printErrors h = ErrorReporter | ||
489 | { reportParseError = \err -> hPutStrLn h err | ||
490 | , reportMissingHandler = \meth addr x -> hPutStrLn h $ show addr ++ " --> Missing handler ("++show meth++")" | ||
491 | , reportUnknown = \addr x err -> hPutStrLn h $ show addr ++ " --> " ++ err | ||
492 | } | ||
493 | |||
494 | -- Change the /err/ type for an 'ErrorReporter'. | ||
495 | instance Contravariant (ErrorReporter addr x meth tid) where | ||
496 | -- contramap :: (t5 -> t4) -> ErrorReporter t3 t2 t1 t t4 -> ErrorReporter t3 t2 t1 t t5 | ||
497 | contramap f (ErrorReporter pe mh unk) | ||
498 | = ErrorReporter (\e -> pe (f e)) | ||
499 | mh | ||
500 | (\addr x e -> unk addr x (f e)) | ||
501 | |||
502 | -- | Handle a single inbound packet and then invoke the given continuation. | ||
503 | -- The 'forkListener' function is implemented by passing this function to 'fix' | ||
504 | -- in a forked thread that loops until 'awaitMessage' returns 'Nothing' or | ||
505 | -- throws an exception. | ||
506 | handleMessage :: | ||
507 | Client err meth tid addr x | ||
508 | -> addr | ||
509 | -> x | ||
510 | -> IO (Maybe (x -> x)) | ||
511 | handleMessage (Client net d err pending whoami responseID) addr plain = do | ||
512 | -- Just (Left e) -> do reportParseError err e | ||
513 | -- return $! Just id | ||
514 | -- Just (Right (plain, addr)) -> do | ||
515 | case classifyInbound d plain of | ||
516 | IsQuery meth tid -> case lookupHandler d meth of | ||
517 | Nothing -> do reportMissingHandler err meth addr plain | ||
518 | return $! Just id | ||
519 | Just m -> do | ||
520 | self <- whoami (Just addr) | ||
521 | tid' <- responseID tid | ||
522 | either (\e -> do reportParseError err e | ||
523 | return $! Just id) | ||
524 | (>>= \m -> do mapM_ (sendMessage net addr) m | ||
525 | return $! Nothing) | ||
526 | (dispatchQuery m tid' self plain addr) | ||
527 | IsUnsolicited action -> do | ||
528 | self <- whoami (Just addr) | ||
529 | action self addr | ||
530 | return Nothing | ||
531 | IsResponse tid -> do | ||
532 | action <- atomically $ do | ||
533 | ts0 <- readTVar pending | ||
534 | (ts, action) <- dispatchResponse (tableMethods d) tid plain ts0 | ||
535 | writeTVar pending ts | ||
536 | return action | ||
537 | action | ||
538 | return $! Nothing | ||
539 | IsUnknown e -> do reportUnknown err addr plain e | ||
540 | return $! Just id | ||
541 | -- Nothing -> return $! id | ||
542 | |||
543 | -- * UDP Datagrams. | ||
544 | |||
545 | -- | Access the address family of a given 'SockAddr'. This convenient accessor | ||
546 | -- is missing from 'Network.Socket', so I implemented it here. | ||
547 | sockAddrFamily :: SockAddr -> Family | ||
548 | sockAddrFamily (SockAddrInet _ _ ) = AF_INET | ||
549 | sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6 | ||
550 | sockAddrFamily (SockAddrUnix _ ) = AF_UNIX | ||
551 | sockAddrFamily _ = AF_CAN -- SockAddrCan constructor deprecated | ||
552 | |||
553 | -- | Packets with an empty payload may trigger EOF exception. | ||
554 | -- 'udpTransport' uses this function to avoid throwing in that | ||
555 | -- case. | ||
556 | ignoreEOF :: a -> IOError -> IO a | ||
557 | ignoreEOF def e | isEOFError e = pure def | ||
558 | | otherwise = throwIO e | ||
559 | |||
560 | -- | Hard-coded maximum packet size for incoming UDP Packets received via | ||
561 | -- 'udpTransport'. | ||
562 | udpBufferSize :: Int | ||
563 | udpBufferSize = 65536 | ||
564 | |||
565 | -- | Wrapper around 'B.sendTo' that silently ignores DoesNotExistError. | ||
566 | saferSendTo :: Socket -> ByteString -> SockAddr -> IO () | ||
567 | saferSendTo sock bs saddr = void (B.sendTo sock bs saddr) | ||
568 | `catch` \e -> | ||
569 | -- sendTo: does not exist (Network is unreachable) | ||
570 | -- Occurs when IPv6 or IPv4 network is not available. | ||
571 | -- Currently, we require -threaded to prevent a forever-hang in this case. | ||
572 | if isDoesNotExistError e | ||
573 | then return () | ||
574 | else throw e | ||
575 | |||
576 | -- | A 'udpTransport' uses a UDP socket to send and receive 'ByteString's. The | ||
577 | -- argument is the listen-address for incoming packets. This is a useful | ||
578 | -- low-level 'Transport' that can be transformed for higher-level protocols | ||
579 | -- using 'layerTransport'. | ||
580 | udpTransport :: SockAddr -> IO (Transport err SockAddr ByteString) | ||
581 | udpTransport bind_address = fst <$> udpTransport' bind_address | ||
582 | |||
583 | -- | Like 'udpTransport' except also returns the raw socket (for broadcast use). | ||
584 | udpTransport' :: SockAddr -> IO (Transport err SockAddr ByteString, Socket) | ||
585 | udpTransport' bind_address = do | ||
586 | let family = sockAddrFamily bind_address | ||
587 | sock <- socket family Datagram defaultProtocol | ||
588 | when (family == AF_INET6) $ do | ||
589 | setSocketOption sock IPv6Only 0 | ||
590 | setSocketOption sock Broadcast 1 | ||
591 | bind sock bind_address | ||
592 | let tr = Transport { | ||
593 | awaitMessage = \kont -> do | ||
594 | r <- handle (ignoreEOF $ Just $ Right (B.empty, SockAddrInet 0 0)) $ do | ||
595 | Just . Right <$!> B.recvFrom sock udpBufferSize | ||
596 | kont $! r | ||
597 | , sendMessage = case family of | ||
598 | AF_INET6 -> \case | ||
599 | (SockAddrInet port addr) -> \bs -> | ||
600 | -- Change IPv4 to 4mapped6 address. | ||
601 | saferSendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0 | ||
602 | addr6 -> \bs -> saferSendTo sock bs addr6 | ||
603 | AF_INET -> \case | ||
604 | (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do | ||
605 | let host4 = toBE32 raw4 | ||
606 | -- Change 4mapped6 to ordinary IPv4. | ||
607 | -- dput XMisc $ "4mapped6 -> "++show (SockAddrInet port host4) | ||
608 | saferSendTo sock bs (SockAddrInet port host4) | ||
609 | addr@(SockAddrInet6 {}) -> \bs -> dput XMisc ("Discarding packet to "++show addr) | ||
610 | addr4 -> \bs -> saferSendTo sock bs addr4 | ||
611 | _ -> \addr bs -> saferSendTo sock bs addr | ||
612 | , closeTransport = close sock | ||
613 | } | ||
614 | return (tr, sock) | ||
615 | |||
616 | chanTransport :: (addr -> TChan (x, addr)) -> addr -> TChan (x, addr) -> TVar Bool -> Transport err addr x | ||
617 | chanTransport chanFromAddr self achan aclosed = Transport | ||
618 | { awaitMessage = \kont -> do | ||
619 | x <- atomically $ (Just <$> readTChan achan) | ||
620 | `orElse` | ||
621 | (readTVar aclosed >>= check >> return Nothing) | ||
622 | kont $ Right <$> x | ||
623 | , sendMessage = \them bs -> do | ||
624 | atomically $ writeTChan (chanFromAddr them) (bs,self) | ||
625 | , closeTransport = atomically $ writeTVar aclosed True | ||
626 | } | ||
627 | |||
628 | -- | Returns a pair of transports linked together to simulate two computers talking to each other. | ||
629 | testPairTransport :: IO (Transport err SockAddr ByteString, Transport err SockAddr ByteString) | ||
630 | testPairTransport = do | ||
631 | achan <- atomically newTChan | ||
632 | bchan <- atomically newTChan | ||
633 | aclosed <- atomically $ newTVar False | ||
634 | bclosed <- atomically $ newTVar False | ||
635 | let a = SockAddrInet 1 1 | ||
636 | b = SockAddrInet 2 2 | ||
637 | return ( chanTransport (const bchan) a achan aclosed | ||
638 | , chanTransport (const achan) b bchan bclosed ) | ||
diff --git a/dht/src/Network/QueryResponse/TCP.hs b/dht/src/Network/QueryResponse/TCP.hs new file mode 100644 index 00000000..bad61727 --- /dev/null +++ b/dht/src/Network/QueryResponse/TCP.hs | |||
@@ -0,0 +1,192 @@ | |||
1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
2 | {-# LANGUAGE CPP #-} | ||
3 | module Network.QueryResponse.TCP where | ||
4 | |||
5 | #ifdef THREAD_DEBUG | ||
6 | import Control.Concurrent.Lifted.Instrument | ||
7 | #else | ||
8 | import Control.Concurrent.Lifted | ||
9 | import GHC.Conc (labelThread) | ||
10 | #endif | ||
11 | |||
12 | import Control.Arrow | ||
13 | import Control.Concurrent.STM | ||
14 | import Control.Monad | ||
15 | import Data.ByteString (ByteString,hPut) | ||
16 | import Data.Function | ||
17 | import Data.Hashable | ||
18 | import Data.Maybe | ||
19 | import Data.Ord | ||
20 | import Data.Time.Clock.POSIX | ||
21 | import Data.Word | ||
22 | import Network.BSD | ||
23 | import Network.Socket | ||
24 | import System.Timeout | ||
25 | import System.IO | ||
26 | import System.IO.Error | ||
27 | |||
28 | import DebugTag | ||
29 | import DPut | ||
30 | import Connection.Tcp (socketFamily) | ||
31 | import qualified Data.MinMaxPSQ as MM | ||
32 | import Network.QueryResponse | ||
33 | |||
34 | data TCPSession st | ||
35 | = PendingTCPSession | ||
36 | | TCPSession | ||
37 | { tcpHandle :: Handle | ||
38 | , tcpState :: st | ||
39 | , tcpThread :: ThreadId | ||
40 | } | ||
41 | |||
42 | newtype TCPAddress = TCPAddress SockAddr | ||
43 | deriving (Eq,Ord,Show) | ||
44 | |||
45 | instance Hashable TCPAddress where | ||
46 | hashWithSalt salt (TCPAddress x) = case x of | ||
47 | SockAddrInet port addr -> hashWithSalt salt (fromIntegral port :: Word16,addr) | ||
48 | SockAddrInet6 port b c d -> hashWithSalt salt (fromIntegral port :: Word16,b,c,d) | ||
49 | _ -> 0 | ||
50 | |||
51 | data TCPCache st = TCPCache | ||
52 | { lru :: TVar (MM.MinMaxPSQ' TCPAddress (Down POSIXTime) (TCPSession st)) | ||
53 | , tcpMax :: Int | ||
54 | } | ||
55 | |||
56 | data SessionProtocol x y = SessionProtocol | ||
57 | { streamGoodbye :: IO () -- ^ "Goodbye" protocol upon termination. | ||
58 | , streamDecode :: IO (Maybe x) -- ^ Parse inbound messages. | ||
59 | , streamEncode :: y -> IO () -- ^ Serialize outbound messages. | ||
60 | } | ||
61 | |||
62 | data StreamHandshake addr x y = StreamHandshake | ||
63 | { streamHello :: addr -> Handle -> IO (SessionProtocol x y) -- ^ "Hello" protocol upon fresh connection. | ||
64 | , streamAddr :: addr -> SockAddr | ||
65 | } | ||
66 | |||
67 | killSession :: TCPSession st -> IO () | ||
68 | killSession PendingTCPSession = return () | ||
69 | killSession TCPSession{tcpThread=t} = killThread t | ||
70 | |||
71 | showStat r = case r of PendingTCPSession -> "pending." | ||
72 | TCPSession {} -> "established." | ||
73 | |||
74 | acquireConnection :: MVar (Maybe (Either a (x, addr))) | ||
75 | -> TCPCache (SessionProtocol x y) | ||
76 | -> StreamHandshake addr x y | ||
77 | -> addr | ||
78 | -> Bool | ||
79 | -> IO (Maybe (y -> IO ())) | ||
80 | acquireConnection mvar tcpcache stream addr bDoCon = do | ||
81 | now <- getPOSIXTime | ||
82 | -- dput XTCP $ "acquireConnection 0 " ++ show (streamAddr stream addr) | ||
83 | entry <- atomically $ do | ||
84 | c <- readTVar (lru tcpcache) | ||
85 | let v = MM.lookup' (TCPAddress $ streamAddr stream addr) c | ||
86 | case v of | ||
87 | Nothing | bDoCon -> writeTVar (lru tcpcache) | ||
88 | $ MM.insert' (TCPAddress $ streamAddr stream addr) PendingTCPSession (Down now) c | ||
89 | | otherwise -> return () | ||
90 | Just (tm, v) -> modifyTVar' (lru tcpcache) $ MM.insert' (TCPAddress $ streamAddr stream addr) v (Down now) | ||
91 | return v | ||
92 | -- dput XTCP $ "acquireConnection 1 " ++ show (streamAddr stream addr, fmap (second showStat) entry) | ||
93 | case entry of | ||
94 | Nothing -> fmap join $ forM (guard bDoCon) $ \() -> do | ||
95 | proto <- getProtocolNumber "tcp" | ||
96 | mh <- catchIOError (do h <- timeout 10000000 $ do | ||
97 | sock <- socket (socketFamily $ streamAddr stream addr) Stream proto | ||
98 | connect sock (streamAddr stream addr) `catchIOError` (\e -> close sock) | ||
99 | h <- socketToHandle sock ReadWriteMode | ||
100 | hSetBuffering h NoBuffering | ||
101 | return h | ||
102 | return h) | ||
103 | $ \e -> return Nothing | ||
104 | ret <- fmap join $ forM mh $ \h -> do | ||
105 | st <- streamHello stream addr h | ||
106 | dput XTCP $ "TCP Connected! " ++ show (streamAddr stream addr) | ||
107 | signal <- newTVarIO False | ||
108 | rthread <- forkIO $ do | ||
109 | atomically (readTVar signal >>= check) | ||
110 | fix $ \loop -> do | ||
111 | x <- streamDecode st | ||
112 | dput XTCP $ "TCP streamDecode " ++ show (streamAddr stream addr) ++ " --> " ++ maybe "Nothing" (const "got") x | ||
113 | case x of | ||
114 | Just u -> do | ||
115 | m <- timeout (1000000) $ putMVar mvar $ Just $ Right (u, addr) | ||
116 | when (isNothing m) $ do | ||
117 | dput XTCP $ "TCP "++show (streamAddr stream addr) ++ " dropped packet." | ||
118 | tryTakeMVar mvar | ||
119 | return () | ||
120 | loop | ||
121 | Nothing -> do | ||
122 | dput XTCP $ "TCP disconnected: " ++ show (streamAddr stream addr) | ||
123 | do atomically $ modifyTVar' (lru tcpcache) | ||
124 | $ MM.delete (TCPAddress $ streamAddr stream addr) | ||
125 | c <- atomically $ readTVar (lru tcpcache) | ||
126 | now <- getPOSIXTime | ||
127 | forM_ (zip [1..] $ MM.toList c) $ \(i,MM.Binding (TCPAddress addr) r (Down tm)) -> do | ||
128 | dput XTCP $ unwords [show i ++ ".", "Still connected:", show addr, show (now - tm), showStat r] | ||
129 | hClose h | ||
130 | let showAddr a = show (streamAddr stream a) | ||
131 | labelThread rthread ("tcp:"++showAddr addr) | ||
132 | let v = TCPSession | ||
133 | { tcpHandle = h | ||
134 | , tcpState = st | ||
135 | , tcpThread = rthread | ||
136 | } | ||
137 | t <- getPOSIXTime | ||
138 | retires <- atomically $ do | ||
139 | c <- readTVar (lru tcpcache) | ||
140 | let (rs,c') = MM.takeView (tcpMax tcpcache) | ||
141 | $ MM.insert' (TCPAddress $ streamAddr stream addr) v (Down t) c | ||
142 | writeTVar (lru tcpcache) c' | ||
143 | writeTVar signal True | ||
144 | return rs | ||
145 | forM_ retires $ \(MM.Binding (TCPAddress k) r _) -> void $ forkIO $ do | ||
146 | myThreadId >>= flip labelThread ("tcp-close:"++show k) | ||
147 | dput XTCP $ "TCP dropped: " ++ show k | ||
148 | killSession r | ||
149 | case r of TCPSession {tcpState=st,tcpHandle=h} -> do | ||
150 | streamGoodbye st | ||
151 | hClose h | ||
152 | _ -> return () | ||
153 | |||
154 | return $ Just $ streamEncode st | ||
155 | when (isNothing ret) $ do | ||
156 | atomically $ modifyTVar' (lru tcpcache) $ MM.delete (TCPAddress $ streamAddr stream addr) | ||
157 | return ret | ||
158 | Just (tm, PendingTCPSession) | ||
159 | | not bDoCon -> return Nothing | ||
160 | | otherwise -> fmap join $ timeout 10000000 $ atomically $ do | ||
161 | c <- readTVar (lru tcpcache) | ||
162 | let v = MM.lookup' (TCPAddress $ streamAddr stream addr) c | ||
163 | case v of | ||
164 | Just (_,TCPSession{tcpState=st}) -> return $ Just $ streamEncode st | ||
165 | Nothing -> return Nothing | ||
166 | _ -> retry | ||
167 | Just (tm, v@TCPSession {tcpState=st}) -> return $ Just $ streamEncode st | ||
168 | |||
169 | closeAll :: TCPCache (SessionProtocol x y) -> StreamHandshake addr x y -> IO () | ||
170 | closeAll tcpcache stream = do | ||
171 | cache <- atomically $ swapTVar (lru tcpcache) MM.empty | ||
172 | forM_ (MM.toList cache) $ \(MM.Binding (TCPAddress addr) r tm) -> do | ||
173 | killSession r | ||
174 | case r of TCPSession{tcpState=st,tcpHandle=h} -> streamGoodbye st >> hClose h | ||
175 | _ -> return () | ||
176 | |||
177 | tcpTransport :: Int -- ^ maximum number of TCP links to maintain. | ||
178 | -> StreamHandshake addr x y | ||
179 | -> IO (TCPCache (SessionProtocol x y), TransportA err addr x (Bool,y)) | ||
180 | tcpTransport maxcon stream = do | ||
181 | msgvar <- newEmptyMVar | ||
182 | tcpcache <- atomically $ (`TCPCache` maxcon) <$> newTVar (MM.empty) | ||
183 | return $ (,) tcpcache Transport | ||
184 | { awaitMessage = \f -> takeMVar msgvar >>= \x -> f x `catchIOError` (\e -> dput XTCP ("TCP transport stopped. " ++ show e) >> f Nothing) | ||
185 | , sendMessage = \addr (bDoCon,y) -> do | ||
186 | t <- forkIO $ do | ||
187 | msock <- acquireConnection msgvar tcpcache stream addr bDoCon | ||
188 | mapM_ ($ y) msock | ||
189 | `catchIOError` \e -> dput XTCP $ "TCP-send: " ++ show e | ||
190 | labelThread t "tcp-send" | ||
191 | , closeTransport = closeAll tcpcache stream | ||
192 | } | ||
diff --git a/dht/src/Network/SessionTransports.hs b/dht/src/Network/SessionTransports.hs new file mode 100644 index 00000000..e9daf6c1 --- /dev/null +++ b/dht/src/Network/SessionTransports.hs | |||
@@ -0,0 +1,98 @@ | |||
1 | {-# LANGUAGE NamedFieldPuns #-} | ||
2 | module Network.SessionTransports | ||
3 | ( Sessions | ||
4 | , initSessions | ||
5 | , newSession | ||
6 | , sessionHandler | ||
7 | ) where | ||
8 | |||
9 | import Control.Concurrent | ||
10 | import Control.Concurrent.STM | ||
11 | import Control.Monad | ||
12 | import qualified Data.IntMap.Strict as IntMap | ||
13 | ;import Data.IntMap.Strict (IntMap) | ||
14 | import qualified Data.Map.Strict as Map | ||
15 | ;import Data.Map.Strict (Map) | ||
16 | |||
17 | import Network.Address (SockAddr,either4or6) | ||
18 | import Network.QueryResponse | ||
19 | import qualified Data.IntervalSet as S | ||
20 | ;import Data.IntervalSet (IntSet) | ||
21 | |||
22 | data Sessions x = Sessions | ||
23 | { sessionsByAddr :: TVar (Map SockAddr (IntMap (x -> IO Bool))) | ||
24 | , sessionsById :: TVar (IntMap SockAddr) | ||
25 | , sessionIds :: TVar IntSet | ||
26 | , sessionsSendRaw :: SockAddr -> x -> IO () | ||
27 | } | ||
28 | |||
29 | initSessions :: (SockAddr -> x -> IO ()) -> IO (Sessions x) | ||
30 | initSessions send = atomically $ do | ||
31 | byaddr <- newTVar Map.empty | ||
32 | byid <- newTVar IntMap.empty | ||
33 | idset <- newTVar S.empty | ||
34 | return Sessions { sessionsByAddr = byaddr | ||
35 | , sessionsById = byid | ||
36 | , sessionIds = idset | ||
37 | , sessionsSendRaw = send | ||
38 | } | ||
39 | |||
40 | |||
41 | |||
42 | rmSession :: Int -> (Maybe (IntMap x)) -> (Maybe (IntMap x)) | ||
43 | rmSession sid Nothing = Nothing | ||
44 | rmSession sid (Just m) = case IntMap.delete sid m of | ||
45 | m' | IntMap.null m' -> Nothing | ||
46 | | otherwise -> Just m' | ||
47 | |||
48 | newSession :: Sessions raw | ||
49 | -> (addr -> y -> IO raw) | ||
50 | -> (SockAddr -> raw -> IO (Maybe (x, addr))) | ||
51 | -> SockAddr | ||
52 | -> IO (Maybe (Int,TransportA err addr x y)) | ||
53 | newSession Sessions{sessionsByAddr,sessionsById,sessionIds,sessionsSendRaw} unwrap wrap addr0 = do | ||
54 | mvar <- newEmptyMVar | ||
55 | let saddr = -- Canonical in case of 6-mapped-4 addresses. | ||
56 | either id id $ either4or6 addr0 | ||
57 | handlePacket x = do | ||
58 | m <- wrap saddr x | ||
59 | case m of | ||
60 | Nothing -> return False | ||
61 | Just x' -> do putMVar mvar $! Just $! x' | ||
62 | return True | ||
63 | msid <- atomically $ do | ||
64 | msid <- S.nearestOutsider 0 <$> readTVar sessionIds | ||
65 | forM msid $ \sid -> do | ||
66 | modifyTVar' sessionIds $ S.insert sid | ||
67 | modifyTVar' sessionsById $ IntMap.insert sid saddr | ||
68 | modifyTVar' sessionsByAddr $ Map.insertWith IntMap.union saddr | ||
69 | $ IntMap.singleton sid handlePacket | ||
70 | return sid | ||
71 | forM msid $ \sid -> do | ||
72 | let tr = Transport | ||
73 | { awaitMessage = \kont -> do | ||
74 | x <- takeMVar mvar | ||
75 | kont $! Right <$> x | ||
76 | , sendMessage = \addr x -> do | ||
77 | x' <- unwrap addr x | ||
78 | sessionsSendRaw saddr x' | ||
79 | , closeTransport = do | ||
80 | tryTakeMVar mvar | ||
81 | putMVar mvar Nothing | ||
82 | atomically $ do | ||
83 | modifyTVar' sessionIds $ S.delete sid | ||
84 | modifyTVar' sessionsById $ IntMap.delete sid | ||
85 | modifyTVar' sessionsByAddr $ Map.alter (rmSession sid) saddr | ||
86 | } | ||
87 | return (sid,tr) | ||
88 | |||
89 | sessionHandler :: Sessions x -> (SockAddr -> x -> IO (Maybe (x -> x))) | ||
90 | sessionHandler Sessions{sessionsByAddr} = \addr0 x -> do | ||
91 | let addr = -- Canonical in case of 6-mapped-4 addresses. | ||
92 | either id id $ either4or6 addr0 | ||
93 | dispatch [] = return () | ||
94 | dispatch (f:fs) = do b <- f x | ||
95 | when (not b) $ dispatch fs | ||
96 | fs <- atomically $ Map.lookup addr <$> readTVar sessionsByAddr | ||
97 | mapM_ (dispatch . IntMap.elems) fs | ||
98 | return Nothing -- consume all packets. | ||
diff --git a/dht/src/Network/SocketLike.hs b/dht/src/Network/SocketLike.hs new file mode 100644 index 00000000..d533dd7f --- /dev/null +++ b/dht/src/Network/SocketLike.hs | |||
@@ -0,0 +1,124 @@ | |||
1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
2 | {-# LANGUAGE CPP #-} | ||
3 | -- | | ||
4 | -- | ||
5 | -- A socket could be used indirectly via a 'System.IO.Handle' or a conduit from | ||
6 | -- Michael Snoyman's conduit package. But doing so presents an encapsulation | ||
7 | -- problem. Do we allow access to the underlying socket and trust that it wont | ||
8 | -- be used in an unsafe way? Or do we protect it at the higher level and deny | ||
9 | -- access to various state information? | ||
10 | -- | ||
11 | -- The 'SocketLike' class enables the approach that provides a safe wrapper to | ||
12 | -- the underlying socket and gives access to various state information without | ||
13 | -- enabling direct reads or writes. | ||
14 | module Network.SocketLike | ||
15 | ( SocketLike(..) | ||
16 | , RestrictedSocket | ||
17 | , restrictSocket | ||
18 | , restrictHandleSocket | ||
19 | -- * Re-exports | ||
20 | -- | ||
21 | -- | To make the 'SocketLike' methods less awkward to use, the types | ||
22 | -- 'CUInt', 'SockAddr', and 'PortNumber' are re-exported. | ||
23 | , CUInt | ||
24 | , PortNumber | ||
25 | , SockAddr(..) | ||
26 | ) where | ||
27 | |||
28 | import Network.Socket | ||
29 | ( PortNumber | ||
30 | , SockAddr | ||
31 | ) | ||
32 | import Foreign.C.Types ( CUInt ) | ||
33 | |||
34 | import qualified Network.Socket as NS | ||
35 | import System.IO (Handle,hClose,hIsOpen) | ||
36 | |||
37 | -- | A safe (mostly read-only) interface to a 'NS.Socket'. Note that despite | ||
38 | -- how this class is named, it provides no access to typical 'NS.Socket' uses | ||
39 | -- like sending or receiving network packets. | ||
40 | class SocketLike sock where | ||
41 | -- | See 'NS.getSocketName' | ||
42 | getSocketName :: sock -> IO SockAddr | ||
43 | -- | See 'NS.getPeerName' | ||
44 | getPeerName :: sock -> IO SockAddr | ||
45 | -- | See 'NS.getPeerCred' | ||
46 | getPeerCred :: sock -> IO (CUInt, CUInt, CUInt) | ||
47 | -- | See 'NS.socketPort' | ||
48 | socketPort :: sock -> IO PortNumber | ||
49 | -- | See 'NS.sIsConnected' | ||
50 | -- | ||
51 | -- __Warning__: Don't rely on this method if it's possible the socket was | ||
52 | -- converted into a 'Handle'. | ||
53 | sIsConnected :: sock -> IO Bool | ||
54 | -- | See 'NS.sIsBound' | ||
55 | sIsBound :: sock -> IO Bool | ||
56 | -- | See 'NS.sIsListening' | ||
57 | sIsListening :: sock -> IO Bool | ||
58 | -- | See 'NS.sIsReadable' | ||
59 | sIsReadable :: sock -> IO Bool | ||
60 | -- | See 'NS.sIsWritable' | ||
61 | sIsWritable :: sock -> IO Bool | ||
62 | |||
63 | -- | This is the only exposed write-access method to the | ||
64 | -- underlying state. Usually implemented by 'NS.close' | ||
65 | sClose :: sock -> IO () | ||
66 | |||
67 | instance SocketLike NS.Socket where | ||
68 | getSocketName = NS.getSocketName | ||
69 | getPeerName = NS.getPeerName | ||
70 | getPeerCred = NS.getPeerCred | ||
71 | socketPort = NS.socketPort | ||
72 | #if MIN_VERSION_network(2,4,0) | ||
73 | sIsConnected = NS.isConnected -- warning: this is always False if the socket | ||
74 | -- was converted to a Handle | ||
75 | sIsBound = NS.isBound | ||
76 | sIsListening = NS.isListening | ||
77 | sIsReadable = NS.isReadable | ||
78 | sIsWritable = NS.isWritable | ||
79 | sClose = NS.close | ||
80 | #else | ||
81 | sIsConnected = NS.sIsConnected -- warning: this is always False if the socket | ||
82 | -- was converted to a Handle | ||
83 | sIsBound = NS.sIsBound | ||
84 | sIsListening = NS.sIsListening | ||
85 | sIsReadable = NS.sIsReadable | ||
86 | sIsWritable = NS.sIsWritable | ||
87 | sClose = NS.sClose | ||
88 | #endif | ||
89 | |||
90 | |||
91 | -- | An encapsulated socket. Data reads and writes are not possible. | ||
92 | data RestrictedSocket = Restricted (Maybe Handle) NS.Socket deriving Show | ||
93 | |||
94 | instance SocketLike RestrictedSocket where | ||
95 | getSocketName (Restricted mb sock) = NS.getSocketName sock | ||
96 | getPeerName (Restricted mb sock) = NS.getPeerName sock | ||
97 | getPeerCred (Restricted mb sock) = NS.getPeerCred sock | ||
98 | socketPort (Restricted mb sock) = NS.socketPort sock | ||
99 | #if MIN_VERSION_network(2,4,0) | ||
100 | sIsConnected (Restricted mb sock) = maybe (NS.isConnected sock) (hIsOpen) mb | ||
101 | sIsBound (Restricted mb sock) = NS.isBound sock | ||
102 | sIsListening (Restricted mb sock) = NS.isListening sock | ||
103 | sIsReadable (Restricted mb sock) = NS.isReadable sock | ||
104 | sIsWritable (Restricted mb sock) = NS.isWritable sock | ||
105 | sClose (Restricted mb sock) = maybe (NS.close sock) (\h -> hClose h >> NS.close sock) mb | ||
106 | #else | ||
107 | sIsConnected (Restricted mb sock) = maybe (NS.sIsConnected sock) (hIsOpen) mb | ||
108 | sIsBound (Restricted mb sock) = NS.sIsBound sock | ||
109 | sIsListening (Restricted mb sock) = NS.sIsListening sock | ||
110 | sIsReadable (Restricted mb sock) = NS.sIsReadable sock | ||
111 | sIsWritable (Restricted mb sock) = NS.sIsWritable sock | ||
112 | sClose (Restricted mb sock) = maybe (NS.sClose sock) (\h -> hClose h >> NS.sClose sock) mb | ||
113 | #endif | ||
114 | |||
115 | -- | Create a 'RestrictedSocket' that explicitly disallows sending or | ||
116 | -- receiving data. | ||
117 | restrictSocket :: NS.Socket -> RestrictedSocket | ||
118 | restrictSocket socket = Restricted Nothing socket | ||
119 | |||
120 | -- | Build a 'RestrictedSocket' for which 'sClose' will close the given | ||
121 | -- 'Handle'. It is intended that this 'Handle' was obtained via | ||
122 | -- 'NS.socketToHandle'. | ||
123 | restrictHandleSocket :: Handle -> NS.Socket -> RestrictedSocket | ||
124 | restrictHandleSocket h socket = Restricted (Just h) socket | ||
diff --git a/dht/src/Network/StreamServer.hs b/dht/src/Network/StreamServer.hs new file mode 100644 index 00000000..80ed4ee2 --- /dev/null +++ b/dht/src/Network/StreamServer.hs | |||
@@ -0,0 +1,154 @@ | |||
1 | -- | This module implements a bare-bones TCP or Unix socket server. | ||
2 | {-# LANGUAGE CPP #-} | ||
3 | {-# LANGUAGE TypeFamilies #-} | ||
4 | {-# LANGUAGE TypeOperators #-} | ||
5 | {-# LANGUAGE OverloadedStrings #-} | ||
6 | {-# LANGUAGE RankNTypes #-} | ||
7 | module Network.StreamServer | ||
8 | ( streamServer | ||
9 | , ServerHandle | ||
10 | , ServerConfig(..) | ||
11 | , withSession | ||
12 | , quitListening | ||
13 | , dummyServerHandle | ||
14 | , listenSocket | ||
15 | ) where | ||
16 | |||
17 | import Data.Monoid | ||
18 | import Network.Socket as Socket | ||
19 | import System.Directory (removeFile) | ||
20 | import System.IO | ||
21 | ( IOMode(..) | ||
22 | , stderr | ||
23 | , hFlush | ||
24 | ) | ||
25 | import Control.Monad | ||
26 | import Control.Monad.Fix (fix) | ||
27 | #ifdef THREAD_DEBUG | ||
28 | import Control.Concurrent.Lifted.Instrument | ||
29 | ( forkIO, threadDelay, ThreadId, mkWeakThreadId, labelThread, myThreadId | ||
30 | , killThread ) | ||
31 | #else | ||
32 | import GHC.Conc (labelThread) | ||
33 | import Control.Concurrent | ||
34 | ( forkIO, threadDelay, ThreadId, mkWeakThreadId, myThreadId | ||
35 | , killThread ) | ||
36 | #endif | ||
37 | import Control.Exception (handle,finally) | ||
38 | import System.IO.Error (tryIOError) | ||
39 | import System.Mem.Weak | ||
40 | import System.IO.Error | ||
41 | |||
42 | -- import Data.Conduit | ||
43 | import System.IO (Handle) | ||
44 | import Control.Concurrent.MVar (newMVar) | ||
45 | |||
46 | import Network.SocketLike | ||
47 | import DPut | ||
48 | import DebugTag | ||
49 | |||
50 | data ServerHandle = ServerHandle Socket (Weak ThreadId) | ||
51 | |||
52 | listenSocket :: ServerHandle -> RestrictedSocket | ||
53 | listenSocket (ServerHandle sock _) = restrictSocket sock | ||
54 | |||
55 | -- | Create a useless do-nothing 'ServerHandle'. | ||
56 | dummyServerHandle :: IO ServerHandle | ||
57 | dummyServerHandle = do | ||
58 | mvar <- newMVar Closed | ||
59 | let sock = MkSocket 0 AF_UNSPEC NoSocketType 0 mvar | ||
60 | thread <- mkWeakThreadId <=< forkIO $ return () | ||
61 | return (ServerHandle sock thread) | ||
62 | |||
63 | removeSocketFile :: SockAddr -> IO () | ||
64 | removeSocketFile (SockAddrUnix fname) = removeFile fname | ||
65 | removeSocketFile _ = return () | ||
66 | |||
67 | -- | Terminate the server accept-loop. Call this to shut down the server. | ||
68 | quitListening :: ServerHandle -> IO () | ||
69 | quitListening (ServerHandle socket acceptThread) = | ||
70 | finally (Socket.getSocketName socket >>= removeSocketFile) | ||
71 | (do mapM_ killThread =<< deRefWeak acceptThread | ||
72 | Socket.close socket) | ||
73 | |||
74 | |||
75 | -- | It's 'bshow' instead of 'show' to enable swapping in a 'ByteString' | ||
76 | -- variation. (This is not exported.) | ||
77 | bshow :: Show a => a -> String | ||
78 | bshow e = show e | ||
79 | |||
80 | -- | Send a string to stderr. Not exported. Default 'serverWarn' when | ||
81 | -- 'withSession' is used to configure the server. | ||
82 | warnStderr :: String -> IO () | ||
83 | warnStderr str = dput XMisc str >> hFlush stderr | ||
84 | |||
85 | data ServerConfig = ServerConfig | ||
86 | { serverWarn :: String -> IO () | ||
87 | -- ^ Action to report warnings and errors. | ||
88 | , serverSession :: RestrictedSocket -> Int -> Handle -> IO () | ||
89 | -- ^ Action to handle interaction with a client | ||
90 | } | ||
91 | |||
92 | -- | Initialize a 'ServerConfig' using the provided session handler. | ||
93 | withSession :: (RestrictedSocket -> Int -> Handle -> IO ()) -> ServerConfig | ||
94 | withSession session = ServerConfig warnStderr session | ||
95 | |||
96 | -- | Launch a thread to listen at the given bind address and dispatch | ||
97 | -- to session handler threads on every incoming connection. Supports | ||
98 | -- IPv4 and IPv6, TCP and unix sockets. | ||
99 | -- | ||
100 | -- The returned handle can be used with 'quitListening' to terminate the | ||
101 | -- thread and prevent any new sessions from starting. Currently active | ||
102 | -- session threads will not be terminated or signaled in any way. | ||
103 | streamServer :: ServerConfig -> [SockAddr] -> IO ServerHandle | ||
104 | streamServer cfg addrs = do | ||
105 | let warn = serverWarn cfg | ||
106 | family = case addrs of | ||
107 | SockAddrInet {}:_ -> AF_INET | ||
108 | SockAddrInet6 {}:_ -> AF_INET6 | ||
109 | SockAddrUnix {}:_ -> AF_UNIX | ||
110 | [] -> AF_INET6 | ||
111 | sock <- socket family Stream 0 | ||
112 | setSocketOption sock ReuseAddr 1 | ||
113 | let tryBind addr next _ = do | ||
114 | tryIOError (removeSocketFile addr) | ||
115 | bind sock addr | ||
116 | `catchIOError` \e -> next (Just e) | ||
117 | fix $ \loop -> let again mbe = do | ||
118 | forM_ mbe $ \e -> warn $ "bind-error: " <> bshow addrs <> " " <> bshow e | ||
119 | threadDelay 5000000 | ||
120 | loop | ||
121 | in foldr tryBind again addrs Nothing | ||
122 | listen sock maxListenQueue | ||
123 | thread <- mkWeakThreadId <=< forkIO $ do | ||
124 | myThreadId >>= flip labelThread "StreamServer.acceptLoop" | ||
125 | acceptLoop cfg sock 0 | ||
126 | return (ServerHandle sock thread) | ||
127 | |||
128 | -- | Not exported. This, combined with 'acceptException' form a mutually | ||
129 | -- recursive loop that handles incoming connections. To quit the loop, the | ||
130 | -- socket must be closed by 'quitListening'. | ||
131 | acceptLoop :: ServerConfig -> Socket -> Int -> IO () | ||
132 | acceptLoop cfg sock n = handle (acceptException cfg n sock) $ do | ||
133 | con <- accept sock | ||
134 | let conkey = n + 1 | ||
135 | h <- socketToHandle (fst con) ReadWriteMode | ||
136 | forkIO $ do | ||
137 | myThreadId >>= flip labelThread "StreamServer.session" | ||
138 | serverSession cfg (restrictHandleSocket h (fst con)) conkey h | ||
139 | acceptLoop cfg sock (n + 1) | ||
140 | |||
141 | acceptException :: ServerConfig -> Int -> Socket -> IOError -> IO () | ||
142 | acceptException cfg n sock ioerror = do | ||
143 | Socket.close sock | ||
144 | case show (ioeGetErrorType ioerror) of | ||
145 | "resource exhausted" -> do -- try again | ||
146 | serverWarn cfg $ ("acceptLoop: resource exhasted") | ||
147 | threadDelay 500000 | ||
148 | acceptLoop cfg sock (n + 1) | ||
149 | "invalid argument" -> do -- quit on closed socket | ||
150 | return () | ||
151 | message -> do -- unexpected exception | ||
152 | serverWarn cfg $ ("acceptLoop: "<>bshow message) | ||
153 | return () | ||
154 | |||
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs new file mode 100644 index 00000000..98c03b80 --- /dev/null +++ b/dht/src/Network/Tox.hs | |||
@@ -0,0 +1,456 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE FlexibleContexts #-} | ||
3 | {-# LANGUAGE DeriveDataTypeable #-} | ||
4 | {-# LANGUAGE DeriveFoldable #-} | ||
5 | {-# LANGUAGE DeriveFunctor #-} | ||
6 | {-# LANGUAGE DeriveGeneric #-} | ||
7 | {-# LANGUAGE DeriveTraversable #-} | ||
8 | {-# LANGUAGE ExistentialQuantification #-} | ||
9 | {-# LANGUAGE FlexibleInstances #-} | ||
10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
11 | {-# LANGUAGE LambdaCase #-} | ||
12 | {-# LANGUAGE NamedFieldPuns #-} | ||
13 | {-# LANGUAGE PatternSynonyms #-} | ||
14 | {-# LANGUAGE RankNTypes #-} | ||
15 | {-# LANGUAGE RecursiveDo #-} | ||
16 | {-# LANGUAGE ScopedTypeVariables #-} | ||
17 | {-# LANGUAGE TupleSections #-} | ||
18 | {-# LANGUAGE ViewPatterns #-} | ||
19 | module Network.Tox where | ||
20 | |||
21 | #ifdef THREAD_DEBUG | ||
22 | import Control.Concurrent.Lifted.Instrument | ||
23 | #else | ||
24 | import Control.Concurrent.Lifted | ||
25 | #endif | ||
26 | import Control.Concurrent.STM | ||
27 | import Control.Exception (throwIO) | ||
28 | import Control.Monad | ||
29 | import Crypto.PubKey.Curve25519 | ||
30 | import Crypto.Random | ||
31 | import Data.Bits.ByteString () | ||
32 | import qualified Data.ByteString as B | ||
33 | ;import Data.ByteString (ByteString) | ||
34 | import qualified Data.ByteString.Char8 as C8 | ||
35 | import Data.Data | ||
36 | import Data.Functor.Identity | ||
37 | import Data.Functor.Contravariant | ||
38 | import Data.Maybe | ||
39 | import qualified Data.MinMaxPSQ as MinMaxPSQ | ||
40 | import qualified Data.Serialize as S | ||
41 | import Data.Time.Clock.POSIX (getPOSIXTime) | ||
42 | import Data.Word | ||
43 | import Network.Socket | ||
44 | import System.Endian | ||
45 | import System.IO.Error | ||
46 | |||
47 | import Data.TableMethods | ||
48 | import qualified Data.Word64Map | ||
49 | import Network.BitTorrent.DHT.Token as Token | ||
50 | import qualified Data.Wrapper.PSQ as PSQ | ||
51 | import System.Global6 | ||
52 | import Network.Address (WantIP (..),IP,getBindAddress) | ||
53 | import qualified Network.Kademlia.Routing as R | ||
54 | import Network.QueryResponse | ||
55 | import Crypto.Tox | ||
56 | import Data.Word64Map (fitsInInt) | ||
57 | import qualified Data.Word64Map (empty) | ||
58 | import Network.Kademlia.Bootstrap (forkPollForRefresh, bootstrap) | ||
59 | import Network.Tox.Crypto.Transport (Handshake(..),CryptoPacket) | ||
60 | import qualified Network.Tox.DHT.Handlers as DHT | ||
61 | import qualified Network.Tox.DHT.Transport as DHT | ||
62 | import Network.Tox.NodeId | ||
63 | import qualified Network.Tox.Onion.Handlers as Onion | ||
64 | import qualified Network.Tox.Onion.Transport as Onion | ||
65 | import Network.Tox.Transport | ||
66 | import Network.Tox.TCP (tcpClient) | ||
67 | import OnionRouter | ||
68 | import Network.Tox.ContactInfo | ||
69 | import Text.XXD | ||
70 | import DPut | ||
71 | import DebugTag | ||
72 | import TCPProber | ||
73 | import Network.Tox.Avahi | ||
74 | import Network.Tox.Session | ||
75 | import qualified Data.Tox.Relay as TCP | ||
76 | import Network.Tox.Relay | ||
77 | import Network.SessionTransports | ||
78 | import Network.Kademlia.Search | ||
79 | import HandshakeCache | ||
80 | |||
81 | updateIP :: TVar (R.BucketList NodeInfo) -> SockAddr -> STM () | ||
82 | updateIP tblvar a = do | ||
83 | bkts <- readTVar tblvar | ||
84 | case nodeInfo (nodeId (R.thisNode bkts)) a of | ||
85 | Right ni -> writeTVar tblvar (bkts { R.thisNode = ni }) | ||
86 | Left _ -> return () | ||
87 | |||
88 | genNonce24 :: DRG g => | ||
89 | TVar (g, pending) -> DHT.TransactionId -> IO DHT.TransactionId | ||
90 | genNonce24 var (DHT.TransactionId nonce8 _) = atomically $ do | ||
91 | (g,pending) <- readTVar var | ||
92 | let (bs, g') = randomBytesGenerate 24 g | ||
93 | writeTVar var (g',pending) | ||
94 | return $ DHT.TransactionId nonce8 (Nonce24 bs) | ||
95 | |||
96 | |||
97 | gen :: forall gen. DRG gen => gen -> (DHT.TransactionId, gen) | ||
98 | gen g = let (bs, g') = randomBytesGenerate 24 g | ||
99 | (ws, g'') = randomBytesGenerate 8 g' | ||
100 | Right w = S.runGet S.getWord64be ws | ||
101 | in ( DHT.TransactionId (Nonce8 w) (Nonce24 bs), g'' ) | ||
102 | |||
103 | intKey :: DHT.TransactionId -> Int | ||
104 | intKey (DHT.TransactionId (Nonce8 w) _) = fromIntegral w | ||
105 | |||
106 | w64Key :: DHT.TransactionId -> Word64 | ||
107 | w64Key (DHT.TransactionId (Nonce8 w) _) = w | ||
108 | |||
109 | nonceKey :: DHT.TransactionId -> Nonce8 | ||
110 | nonceKey (DHT.TransactionId n _) = n | ||
111 | |||
112 | -- | Return my own address. | ||
113 | myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets | ||
114 | -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets | ||
115 | -> Maybe NodeInfo -- ^ Interested remote address | ||
116 | -> IO NodeInfo | ||
117 | myAddr routing4 routing6 maddr = atomically $ do | ||
118 | let var = case flip DHT.prefer4or6 Nothing <$> maddr of | ||
119 | Just Want_IP6 -> routing4 | ||
120 | _ -> routing6 | ||
121 | a <- readTVar var | ||
122 | return $ R.thisNode a | ||
123 | |||
124 | newClient :: (DRG g, Show addr, Show meth) => | ||
125 | g -> Transport String addr x | ||
126 | -> (Client String meth DHT.TransactionId addr x | ||
127 | -> x | ||
128 | -> MessageClass String meth DHT.TransactionId addr x) | ||
129 | -> (Maybe addr -> IO addr) | ||
130 | -> (Client String meth DHT.TransactionId addr x | ||
131 | -> meth | ||
132 | -> Maybe (MethodHandler String DHT.TransactionId addr x)) | ||
133 | -> (forall d. TransactionMethods d DHT.TransactionId addr x | ||
134 | -> TransactionMethods d DHT.TransactionId addr x) | ||
135 | -> (Client String meth DHT.TransactionId addr x | ||
136 | -> Transport String addr x -> Transport String addr x) | ||
137 | -> IO (Client String meth DHT.TransactionId addr x) | ||
138 | newClient drg net classify selfAddr handlers modifytbl modifynet = do | ||
139 | -- If we have 8-byte keys for IntMap, then use it for transaction lookups. | ||
140 | -- Otherwise, use ordinary Map. The details of which will be hidden by an | ||
141 | -- existential closure (see mkclient below). | ||
142 | -- | ||
143 | tblvar <- | ||
144 | if fitsInInt (Proxy :: Proxy Word64) | ||
145 | then do | ||
146 | let intmapT = transactionMethods (contramap intKey intMapMethods) gen | ||
147 | intmap_var <- atomically $ newTVar (drg, mempty) | ||
148 | return $ Right (intmapT,intmap_var) | ||
149 | else do | ||
150 | let word64mapT = transactionMethods (contramap w64Key w64MapMethods) gen | ||
151 | map_var <- atomically $ newTVar (drg, Data.Word64Map.empty) | ||
152 | return $ Left (word64mapT,map_var) | ||
153 | let dispatch tbl var handlers client = DispatchMethods | ||
154 | { classifyInbound = classify client | ||
155 | , lookupHandler = handlers -- var | ||
156 | , tableMethods = modifytbl tbl | ||
157 | } | ||
158 | eprinter = logErrors -- printErrors stderr | ||
159 | mkclient (tbl,var) handlers = | ||
160 | let client = Client | ||
161 | { clientNet = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net | ||
162 | , clientDispatcher = dispatch tbl var (handlers client) client | ||
163 | , clientErrorReporter = eprinter | ||
164 | , clientPending = var | ||
165 | , clientAddress = selfAddr | ||
166 | , clientResponseId = genNonce24 var | ||
167 | } | ||
168 | in client | ||
169 | return $ either mkclient mkclient tblvar handlers | ||
170 | |||
171 | data Tox extra = Tox | ||
172 | { toxDHT :: DHT.Client | ||
173 | , toxOnion :: Onion.Client RouteId | ||
174 | , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData) | ||
175 | , toxCrypto :: Transport String SockAddr (CryptoPacket Encrypted) | ||
176 | , toxHandshakes :: Transport String SockAddr (Handshake Encrypted) | ||
177 | , toxHandshakeCache :: HandshakeCache | ||
178 | , toxCryptoKeys :: TransportCrypto | ||
179 | , toxRouting :: DHT.Routing | ||
180 | , toxTokens :: TVar SessionTokens | ||
181 | , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys | ||
182 | , toxOnionRoutes :: OnionRouter | ||
183 | , toxContactInfo :: ContactInfo extra | ||
184 | , toxAnnounceToLan :: IO () | ||
185 | , toxBindAddress :: SockAddr | ||
186 | } | ||
187 | |||
188 | |||
189 | |||
190 | -- | Create a DHTPublicKey packet to send to a remote contact. | ||
191 | getContactInfo :: Tox extra -> IO DHT.DHTPublicKey | ||
192 | getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do | ||
193 | r4 <- readTVar $ DHT.routing4 toxRouting | ||
194 | r6 <- readTVar $ DHT.routing6 toxRouting | ||
195 | nonce <- transportNewNonce toxCryptoKeys | ||
196 | let self = nodeId n4 | ||
197 | n4 = R.thisNode r4 | ||
198 | n6 = R.thisNode r6 | ||
199 | n4s = R.kclosest DHT.toxSpace 4 self r4 | ||
200 | n6s = R.kclosest DHT.toxSpace 4 self r6 | ||
201 | ns = filter (DHT.isGlobal . nodeIP) [n4,n6] | ||
202 | ++ concat (zipWith (\a b -> [a,b]) n4s n6s) | ||
203 | return $ do | ||
204 | timestamp <- round . (* 1000000) <$> getPOSIXTime | ||
205 | return DHT.DHTPublicKey | ||
206 | { dhtpkNonce = timestamp | ||
207 | , dhtpk = id2key self | ||
208 | , dhtpkNodes = DHT.SendNodes $ take 4 ns | ||
209 | } | ||
210 | |||
211 | isLocalHost :: SockAddr -> Bool | ||
212 | isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001) | ||
213 | isLocalHost _ = False | ||
214 | |||
215 | addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString | ||
216 | addVerbosity tr = | ||
217 | tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do | ||
218 | forM_ m $ mapM_ $ \(msg,addr) -> do | ||
219 | when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do | ||
220 | mapM_ (\x -> dput XMisc ( (show addr) ++ " --> " ++ x)) | ||
221 | $ xxd 0 msg | ||
222 | kont m | ||
223 | , sendMessage = \addr msg -> do | ||
224 | when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do | ||
225 | mapM_ (\x -> dput XMisc ( (show addr) ++ " <-- " ++ x)) | ||
226 | $ xxd 0 msg | ||
227 | sendMessage tr addr msg | ||
228 | } | ||
229 | |||
230 | newKeysDatabase :: IO (TVar Onion.AnnouncedKeys) | ||
231 | newKeysDatabase = | ||
232 | atomically $ newTVar $ Onion.AnnouncedKeys PSQ.empty MinMaxPSQ.empty | ||
233 | |||
234 | |||
235 | getOnionAlias :: TransportCrypto -> STM NodeInfo -> Maybe (Onion.OnionDestination r) -> IO (Onion.OnionDestination r) | ||
236 | getOnionAlias crypto dhtself remoteNode = atomically $ do | ||
237 | ni <- dhtself | ||
238 | let alias = case remoteNode of | ||
239 | Just (Onion.OnionDestination (Onion.AnnouncingAlias _ uk) _ _) | ||
240 | -> ni { nodeId = key2id uk } | ||
241 | _ -> ni { nodeId = key2id (onionAliasPublic crypto) } | ||
242 | return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing | ||
243 | |||
244 | newOnionClient :: DRG g => | ||
245 | TransportCrypto | ||
246 | -> Transport String (Onion.OnionDestination RouteId) Onion.Message | ||
247 | -> DHT.Routing | ||
248 | -> TVar SessionTokens | ||
249 | -> TVar Onion.AnnouncedKeys | ||
250 | -> OnionRouter | ||
251 | -> TVar (g, Data.Word64Map.Word64Map a) | ||
252 | -> ((Maybe Onion.Message -> IO ()) -> a) | ||
253 | -> (a -> Maybe Onion.Message -> IO void) | ||
254 | -> Client String | ||
255 | DHT.PacketKind | ||
256 | DHT.TransactionId | ||
257 | (Onion.OnionDestination RouteId) | ||
258 | Onion.Message | ||
259 | newOnionClient crypto net r toks keydb orouter map_var store load = c | ||
260 | where | ||
261 | eprinter = logErrors | ||
262 | c = Client | ||
263 | { clientNet = addHandler (reportParseError eprinter) (handleMessage c) net | ||
264 | , clientDispatcher = DispatchMethods | ||
265 | { classifyInbound = Onion.classify | ||
266 | , lookupHandler = Onion.handlers net r toks keydb | ||
267 | , tableMethods = hookQueries orouter DHT.transactionKey | ||
268 | $ transactionMethods' store load (contramap w64Key w64MapMethods) gen | ||
269 | } | ||
270 | , clientErrorReporter = eprinter | ||
271 | , clientPending = map_var | ||
272 | , clientAddress = getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 r) | ||
273 | , clientResponseId = genNonce24 map_var | ||
274 | } | ||
275 | |||
276 | newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for. | ||
277 | -> [String] -- ^ Bind-address to listen on. Must provide at least one. | ||
278 | -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) | ||
279 | -> Maybe SecretKey -- ^ Optional DHT secret key to use. | ||
280 | -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. | ||
281 | -> IO (Tox extra) | ||
282 | newTox keydb bindspecs onsess suppliedDHTKey tcp = do | ||
283 | addrs <- mapM (`getBindAddress` True) bindspecs | ||
284 | let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just) | ||
285 | failedBind mbe = do | ||
286 | forM_ mbe $ \e -> do | ||
287 | dput XDHT $ "tox udp bind error: " ++ show addrs ++ " " ++ show e | ||
288 | throwIO e | ||
289 | throwIO $ userError "Tox UDP listen port?" | ||
290 | (udp,sock) <- foldr tryBind failedBind addrs Nothing | ||
291 | addr <- getSocketName sock | ||
292 | (relay,sendTCP) <- tcpRelay addr (\a x -> sendMessage udp a $ S.runPut $ Onion.putRequest x) | ||
293 | tox <- newToxOverTransport keydb addr onsess suppliedDHTKey udp sendTCP | ||
294 | return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) } | ||
295 | |||
296 | -- | This version of 'newTox' is useful for automated tests using 'testPairTransport'. | ||
297 | newToxOverTransport :: TVar Onion.AnnouncedKeys | ||
298 | -> SockAddr | ||
299 | -> ( ContactInfo extra -> SockAddr -> Session -> IO () ) | ||
300 | -> Maybe SecretKey | ||
301 | -> Onion.UDPTransport | ||
302 | -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses. | ||
303 | -> IO (Tox extra) | ||
304 | newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do | ||
305 | roster <- newContactInfo | ||
306 | crypto0 <- newCrypto | ||
307 | let -- patch in supplied DHT key | ||
308 | crypto1 = fromMaybe crypto0 $do | ||
309 | k <- suppliedDHTKey | ||
310 | return crypto0 | ||
311 | { transportSecret = k | ||
312 | , transportPublic = toPublic k | ||
313 | } | ||
314 | -- patch in newly allocated roster state. | ||
315 | crypto = crypto1 { userKeys = myKeyPairs roster } | ||
316 | forM_ suppliedDHTKey $ \k -> do | ||
317 | maybe (dput XMisc "failed to encode suppliedDHTKey") | ||
318 | (dputB XMisc . C8.append "Using suppliedDHTKey: ") | ||
319 | $ encodeSecret k | ||
320 | |||
321 | drg <- drgNew | ||
322 | let lookupClose _ = return Nothing | ||
323 | |||
324 | mkrouting <- DHT.newRouting addr crypto updateIP updateIP | ||
325 | (orouter,otbl) <- newOnionRouter crypto (dput XRoutes) | ||
326 | (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) | ||
327 | <- toxTransport crypto orouter lookupClose udp | ||
328 | (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x)) | ||
329 | tcp | ||
330 | sessions <- initSessions (sendMessage cryptonet) | ||
331 | |||
332 | let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt | ||
333 | tbl4 = DHT.routing4 $ mkrouting (error "missing client") | ||
334 | tbl6 = DHT.routing6 $ mkrouting (error "missing client") | ||
335 | updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr | ||
336 | dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id | ||
337 | (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net) | ||
338 | |||
339 | hscache <- newHandshakeCache crypto (sendMessage handshakes) | ||
340 | let sparams = SessionParams | ||
341 | { spCrypto = crypto | ||
342 | , spSessions = sessions | ||
343 | , spGetSentHandshake = getSentHandshake hscache | ||
344 | , spOnNewSession = onNewSession roster addr | ||
345 | } | ||
346 | |||
347 | -- TODO: Refactor so that these threads are forked when 'forkTox' is invoked. | ||
348 | -- This function should only initialize state. | ||
349 | orouter' <- forkRouteBuilder orouter | ||
350 | $ \nid ni -> fmap (\(_,ns,_)->ns) | ||
351 | <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid ni | ||
352 | |||
353 | toks <- do | ||
354 | nil <- nullSessionTokens | ||
355 | atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids. | ||
356 | let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt | ||
357 | let onionclient = newOnionClient crypto onionnet (mkrouting dhtclient) toks keydb orouter' otbl | ||
358 | Right $ \case | ||
359 | Right v -> v | ||
360 | Left v -> \_ -> | ||
361 | dput XUnexpected "TCP-sent onion query got response over UDP?" | ||
362 | |||
363 | return Tox | ||
364 | { toxDHT = dhtclient | ||
365 | , toxOnion = onionclient | ||
366 | , toxToRoute = onInbound (updateContactInfo roster) dtacrypt | ||
367 | , toxCrypto = addHandler (dput XMisc) (sessionHandler sessions) cryptonet | ||
368 | , toxHandshakes = addHandler (dput XMisc) (handshakeH sparams) handshakes | ||
369 | , toxHandshakeCache = hscache | ||
370 | , toxCryptoKeys = crypto | ||
371 | , toxRouting = mkrouting dhtclient | ||
372 | , toxTokens = toks | ||
373 | , toxAnnouncedKeys = keydb | ||
374 | , toxOnionRoutes = orouter' -- TODO: see above | ||
375 | , toxContactInfo = roster | ||
376 | , toxAnnounceToLan = return () | ||
377 | , toxBindAddress = addr | ||
378 | } | ||
379 | |||
380 | onionTimeout :: Tox extra -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int) | ||
381 | onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od | ||
382 | |||
383 | routing4nodeInfo :: DHT.Routing -> IO NodeInfo | ||
384 | routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv | ||
385 | |||
386 | dnssdAnnounce :: Tox extra -> IO () | ||
387 | dnssdAnnounce tox = do | ||
388 | ni <- routing4nodeInfo (toxRouting tox) | ||
389 | keys <- fmap (key2id . snd) <$> atomically (userKeys $ toxCryptoKeys tox) | ||
390 | announceToxService (nodePort ni) (nodeId ni) (listToMaybe keys) | ||
391 | |||
392 | dnssdDiscover :: Tox extra -> NodeInfo -> (Maybe NodeId) -> IO () | ||
393 | dnssdDiscover tox ni toxid = do | ||
394 | acts <- atomically $ readTVar $ accounts $ toxContactInfo tox | ||
395 | now <- getPOSIXTime | ||
396 | forM toxid $ \tid -> | ||
397 | forM acts $ \act -> | ||
398 | atomically $ setContactAddr now (id2key tid) ni act | ||
399 | |||
400 | void $ DHT.ping (toxDHT tox) ni | ||
401 | |||
402 | -- | Returns: | ||
403 | -- | ||
404 | -- * action to shutdown this node, terminating all threads. | ||
405 | -- | ||
406 | -- * action to bootstrap an IPv4 Kademlia table. | ||
407 | -- | ||
408 | -- * action to bootstrap an IPv6 Kademlia table. | ||
409 | forkTox :: Tox extra -> Bool -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ()) | ||
410 | forkTox tox with_avahi = do | ||
411 | quitHs <- forkListener "toxHandshakes" (toxHandshakes tox) | ||
412 | quitToRoute <- forkListener "toxToRoute" (toxToRoute tox) | ||
413 | quitOnion <- forkListener "toxOnion" (clientNet $ toxOnion tox) | ||
414 | quitDHT <- forkListener "toxDHT" (clientNet $ toxDHT tox) | ||
415 | quitNC <- forkListener "toxCrypto" (toxCrypto tox) | ||
416 | quitTCP <- forkListener "relay-client" (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox) | ||
417 | quitAvahi <- if with_avahi then do | ||
418 | forkPollForRefresh (DHT.refresher4 $ toxRouting tox) | ||
419 | forkPollForRefresh (DHT.refresher6 $ toxRouting tox) | ||
420 | dnssdIn <- forkIO $ queryToxService (dnssdDiscover tox) | ||
421 | dnssdOut <- forkIO $ dnssdAnnounce tox | ||
422 | labelThread dnssdIn "tox-avahi-monitor" | ||
423 | labelThread dnssdOut "tox-avahi-publish" | ||
424 | return $ forM_ [dnssdIn,dnssdOut] killThread | ||
425 | else return $ return () | ||
426 | keygc <- Onion.forkAnnouncedKeysGC (toxAnnouncedKeys tox) | ||
427 | return ( do quitAvahi | ||
428 | killThread keygc | ||
429 | quitNC | ||
430 | quitDHT | ||
431 | quitOnion | ||
432 | quitTCP | ||
433 | quitRouteBuilder (toxOnionRoutes tox) | ||
434 | quitToRoute | ||
435 | quitHs | ||
436 | , bootstrap (DHT.refresher4 $ toxRouting tox) | ||
437 | , bootstrap (DHT.refresher6 $ toxRouting tox) | ||
438 | ) | ||
439 | |||
440 | -- TODO: Don't export this. The exported interface is 'toxAnnounceToLan'. | ||
441 | announceToLan :: Socket -> NodeId -> IO () | ||
442 | announceToLan sock nid = do | ||
443 | addrs <- broadcastAddrs | ||
444 | forM_ addrs $ \addr -> do | ||
445 | (broadcast_info:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }) | ||
446 | (Just addr) | ||
447 | (Just "33445") | ||
448 | let broadcast = addrAddress broadcast_info | ||
449 | bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid) | ||
450 | dput XLan $ show broadcast ++ " <-- LanAnnounce " ++ show nid | ||
451 | saferSendTo sock bs broadcast | ||
452 | |||
453 | |||
454 | toxQSearch :: Tox extra -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Onion.Rendezvous | ||
455 | toxQSearch tox = Onion.toxidSearch (onionTimeout tox) (toxCryptoKeys tox) (toxOnion tox) | ||
456 | |||
diff --git a/dht/src/Network/Tox/AggregateSession.hs b/dht/src/Network/Tox/AggregateSession.hs new file mode 100644 index 00000000..8c728660 --- /dev/null +++ b/dht/src/Network/Tox/AggregateSession.hs | |||
@@ -0,0 +1,374 @@ | |||
1 | -- | This module aggregates all sessions to the same remote Tox contact into a | ||
2 | -- single online/offline presence. This allows multiple lossless links to the | ||
3 | -- same identity at different addresses, or even to the same address. | ||
4 | {-# LANGUAGE CPP #-} | ||
5 | {-# LANGUAGE GADTs #-} | ||
6 | {-# LANGUAGE LambdaCase #-} | ||
7 | {-# LANGUAGE PatternSynonyms #-} | ||
8 | module Network.Tox.AggregateSession | ||
9 | ( AggregateSession | ||
10 | , newAggregateSession | ||
11 | , aggregateStatus | ||
12 | , checkCompatible | ||
13 | , compatibleKeys | ||
14 | , AddResult(..) | ||
15 | , addSession | ||
16 | , DelResult(..) | ||
17 | , delSession | ||
18 | , closeAll | ||
19 | , awaitAny | ||
20 | , dispatchMessage | ||
21 | ) where | ||
22 | |||
23 | |||
24 | import Control.Concurrent.STM | ||
25 | import Control.Concurrent.STM.TMChan | ||
26 | import Control.Monad | ||
27 | import Data.Dependent.Sum | ||
28 | import Data.Function | ||
29 | import qualified Data.IntMap.Strict as IntMap | ||
30 | ;import Data.IntMap.Strict (IntMap) | ||
31 | import Data.List | ||
32 | import Data.Time.Clock.POSIX | ||
33 | import System.IO.Error | ||
34 | |||
35 | #ifdef THREAD_DEBUG | ||
36 | import Control.Concurrent.Lifted.Instrument | ||
37 | #else | ||
38 | import Control.Concurrent.Lifted | ||
39 | import GHC.Conc (labelThread) | ||
40 | #endif | ||
41 | |||
42 | import Connection (Status (..)) | ||
43 | import Crypto.Tox (PublicKey, toPublic) | ||
44 | import Data.Tox.Msg | ||
45 | import Data.Wrapper.PSQInt as PSQ | ||
46 | import DPut | ||
47 | import DebugTag | ||
48 | import Network.QueryResponse | ||
49 | import Network.Tox.Crypto.Transport | ||
50 | import Network.Tox.DHT.Transport (key2id) | ||
51 | import Network.Tox.NodeId (ToxProgress (..)) | ||
52 | import Network.Tox.Session | ||
53 | |||
54 | -- | For each component session, we track the current status. | ||
55 | data SingleCon = SingleCon | ||
56 | { singleSession :: Session -- ^ A component session. | ||
57 | , singleStatus :: TVar (Status ToxProgress) -- ^ Either 'AwaitingSessionPacket' or 'Established'. | ||
58 | } | ||
59 | |||
60 | -- | A collection of sessions between the same local and remote identities. | ||
61 | data AggregateSession = AggregateSession | ||
62 | { -- | The set of component sessions indexed by their ID. | ||
63 | contactSession :: TVar (IntMap SingleCon) | ||
64 | -- | Each inbound packets is written to this channel with the session ID | ||
65 | -- from which it came originally. | ||
66 | , contactChannel :: TMChan (Int,CryptoMessage) | ||
67 | -- | The set of 'Established' sessions IDs. | ||
68 | , contactEstablished :: TVar (IntMap ()) | ||
69 | -- | Callback for state-change notifications. | ||
70 | , notifyState :: AggregateSession -> Session -> Status ToxProgress -> STM () | ||
71 | } | ||
72 | |||
73 | |||
74 | -- | Create a new empty aggregate session. The argument is a callback to | ||
75 | -- receive notifications when the new session changes status. There are three | ||
76 | -- possible status values: | ||
77 | -- | ||
78 | -- [ Dormant ] - No pending or established sessions. | ||
79 | -- | ||
80 | -- [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are | ||
81 | -- fully established. | ||
82 | -- | ||
83 | -- [ Established ] - At least one session is fully established and we can | ||
84 | -- send and receive packets via this aggregate. | ||
85 | -- | ||
86 | -- The 'Session' object is provided to the callback so that it can determine the | ||
87 | -- current remote and local identities for this AggregateSession. It may not even | ||
88 | -- be Established, so do not use it to send or receive packets. | ||
89 | newAggregateSession :: (AggregateSession -> Session -> Status ToxProgress -> STM ()) | ||
90 | -> STM AggregateSession | ||
91 | newAggregateSession notify = do | ||
92 | vimap <- newTVar IntMap.empty | ||
93 | chan <- newTMChan | ||
94 | vemap <- newTVar IntMap.empty | ||
95 | return AggregateSession | ||
96 | { contactSession = vimap | ||
97 | , contactChannel = chan | ||
98 | , contactEstablished = vemap | ||
99 | , notifyState = notify | ||
100 | } | ||
101 | |||
102 | -- | Information returned from 'addSession'. Note that a value other than | ||
103 | -- 'RejectedSession' does not mean there is any 'Established' session in the | ||
104 | -- Aggregate. Sessions are in 'AwaitingSessionPacket' state until a single | ||
105 | -- packet is received from the remote end. | ||
106 | data AddResult = FirstSession -- ^ Initial connection with this contact. | ||
107 | | AddedSession -- ^ Added another connection to active session. | ||
108 | | RejectedSession -- ^ Failed to add session (wrong contact / closed session). | ||
109 | |||
110 | -- | The 'keepAlive' thread juggles three scheduled tasks. | ||
111 | data KeepAliveEvents = DoTimeout -- ^ A session timed-out, close it. | ||
112 | | DoAlive -- ^ Send a the keep-alive becon for a session. | ||
113 | | DoRequestMissing -- ^ Detect and request lost packets. | ||
114 | deriving Enum | ||
115 | |||
116 | -- | This call loops until the provided sesison is closed or times out. It | ||
117 | -- monitors the provided (non-empty) priority queue for scheduled tasks (see | ||
118 | -- 'KeepAliveEvents') to perform for the connection. | ||
119 | keepAlive :: Session -> TVar (PSQ POSIXTime) -> IO () | ||
120 | keepAlive s q = do | ||
121 | myThreadId >>= flip labelThread | ||
122 | (intercalate "." ["beacon" | ||
123 | , take 8 $ show $ key2id $ sTheirUserKey s | ||
124 | , show $ sSessionID s]) | ||
125 | |||
126 | let -- outPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e | ||
127 | unexpected e = dput XUnexpected $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e | ||
128 | |||
129 | doAlive = do | ||
130 | -- outPrint $ "Beacon" | ||
131 | sendMessage (sTransport s) () (Pkt ALIVE ==> ()) | ||
132 | |||
133 | doRequestMissing = do | ||
134 | (ns,nmin) <- sMissingInbound s | ||
135 | -- outPrint $ "PacketRequest " ++ show (nmin,ns) | ||
136 | sendMessage (sTransport s) () (Pkt PacketRequest ==> MissingPackets ns) | ||
137 | `catchIOError` \e -> do | ||
138 | unexpected $ "PacketRequest " ++ take 200 (show (nmin,length ns,ns)) | ||
139 | unexpected $ "PacketRequest: " ++ show e | ||
140 | -- Quit thread by scheduling a timeout event. | ||
141 | now <- getPOSIXTime | ||
142 | atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) now | ||
143 | |||
144 | re tm again e io = do | ||
145 | io | ||
146 | atomically $ modifyTVar' q $ PSQ.insert (fromEnum e) tm | ||
147 | again | ||
148 | |||
149 | doEvent again now e = case e of | ||
150 | DoTimeout -> do dput XNetCrypto $ "TIMEOUT: " ++ show (sSessionID s) | ||
151 | sClose s | ||
152 | DoAlive -> re (now + 10) again e doAlive | ||
153 | DoRequestMissing -> re (now + 5) again e doRequestMissing -- tox-core does this at 1 second intervals | ||
154 | |||
155 | fix $ \again -> do | ||
156 | |||
157 | now <- getPOSIXTime | ||
158 | join $ atomically $ do | ||
159 | PSQ.findMin <$> readTVar q >>= \case | ||
160 | Nothing -> error "keepAlive: unexpected empty PSQ." | ||
161 | Just ( k :-> tm ) -> | ||
162 | return $ if now < tm then threadDelay (toMicroseconds $ tm - now) >> again | ||
163 | else doEvent again now (toEnum k) | ||
164 | |||
165 | |||
166 | -- | This function forks two threads: the 'keepAlive' beacon-sending thread and | ||
167 | -- a thread to read all packets from the provided 'Session' and forward them to | ||
168 | -- 'contactChannel' for a containing 'AggregateSession' | ||
169 | forkSession :: AggregateSession -> Session -> (Status ToxProgress -> STM ()) -> IO ThreadId | ||
170 | forkSession c s setStatus = forkIO $ do | ||
171 | myThreadId >>= flip labelThread | ||
172 | (intercalate "." ["s" | ||
173 | , take 8 $ show $ key2id $ sTheirUserKey s | ||
174 | , show $ sSessionID s]) | ||
175 | |||
176 | q <- atomically $ newTVar $ fromList | ||
177 | [ fromEnum DoAlive :-> 0 | ||
178 | , fromEnum DoRequestMissing :-> 0 | ||
179 | ] | ||
180 | |||
181 | let sendPacket :: CryptoMessage -> STM () | ||
182 | sendPacket msg = writeTMChan (contactChannel c) (sSessionID s, msg) | ||
183 | |||
184 | inPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " --> " ++ e | ||
185 | |||
186 | bump = do | ||
187 | -- inPrint $ "BUMP: " ++ show (sSessionID s) | ||
188 | now <- getPOSIXTime | ||
189 | atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) (now + 15) | ||
190 | |||
191 | onPacket body loop Nothing = return () | ||
192 | onPacket body loop (Just (Left e)) = inPrint e >> loop | ||
193 | onPacket body loop (Just (Right x)) = body loop x | ||
194 | |||
195 | awaitPacket body = fix $ awaitMessage (sTransport s) . onPacket body | ||
196 | |||
197 | atomically $ setStatus $ InProgress AwaitingSessionPacket | ||
198 | awaitPacket $ \_ (online,()) -> do | ||
199 | when (msgID online /= M ONLINE) $ do | ||
200 | inPrint $ "Unexpected initial packet: " ++ show (msgID online) | ||
201 | atomically $ do setStatus Established | ||
202 | sendPacket online | ||
203 | bump | ||
204 | beacon <- forkIO $ keepAlive s q | ||
205 | awaitPacket $ \awaitNext (x,()) -> do | ||
206 | bump | ||
207 | case msgID x of | ||
208 | M ALIVE -> return () | ||
209 | M KillPacket -> sClose s | ||
210 | _ -> atomically $ sendPacket x | ||
211 | awaitNext | ||
212 | atomically $ setStatus Dormant | ||
213 | killThread beacon | ||
214 | |||
215 | -- | Add a new session (in 'AwaitingSessionPacket' state) to the | ||
216 | -- 'AggregateSession'. If the supplied session is not compatible because it is | ||
217 | -- between the wrong ToxIDs or because the AggregateSession is closed, | ||
218 | -- 'RejectedSession' will be returned. Otherwise, the operation is successful. | ||
219 | -- | ||
220 | -- The status-change callback may be triggered by this call as the aggregate | ||
221 | -- may transition from 'Dormant' (empty) to 'AwaitingSessionPacket' (at least | ||
222 | -- one active session). | ||
223 | addSession :: AggregateSession -> Session -> IO AddResult | ||
224 | addSession c s = do | ||
225 | (result,mcon,replaced) <- atomically $ do | ||
226 | let them = sTheirUserKey s | ||
227 | me = toPublic $ sOurKey s | ||
228 | compat <- checkCompatible me them c | ||
229 | let result = case compat of | ||
230 | Nothing -> FirstSession | ||
231 | Just True -> AddedSession | ||
232 | Just False -> RejectedSession | ||
233 | case result of | ||
234 | RejectedSession -> return (result,Nothing,Nothing) | ||
235 | _ -> do | ||
236 | statvar <- newTVar Dormant | ||
237 | imap <- readTVar (contactSession c) | ||
238 | let con = SingleCon s statvar | ||
239 | s0 = IntMap.lookup (sSessionID s) imap | ||
240 | imap' = IntMap.insert (sSessionID s) con imap | ||
241 | writeTVar (contactSession c) imap' | ||
242 | return (result,Just con,s0) | ||
243 | |||
244 | mapM_ (sClose . singleSession) replaced | ||
245 | forM_ mcon $ \con -> | ||
246 | forkSession c s $ \progress -> do | ||
247 | writeTVar (singleStatus con) progress | ||
248 | emap <- readTVar (contactEstablished c) | ||
249 | emap' <- case progress of | ||
250 | Established -> do | ||
251 | when (IntMap.null emap) $ notifyState c c s Established | ||
252 | return $ IntMap.insert (sSessionID s) () emap | ||
253 | _ -> do | ||
254 | let emap' = IntMap.delete (sSessionID s) emap | ||
255 | when (IntMap.null emap' && not (IntMap.null emap)) $ do | ||
256 | imap <- readTVar (contactSession c) | ||
257 | notifyState c c s | ||
258 | $ if IntMap.null imap then Dormant | ||
259 | else InProgress AwaitingSessionPacket | ||
260 | return emap' | ||
261 | writeTVar (contactEstablished c) emap' | ||
262 | return result | ||
263 | |||
264 | -- | Information returned from 'delSession'. | ||
265 | data DelResult = NoSession -- ^ Contact is completely disconnected. | ||
266 | | DeletedSession -- ^ Connection removed but session remains active. | ||
267 | |||
268 | -- | Close and remove the componenent session corresponding to the provided | ||
269 | -- Session ID. | ||
270 | -- | ||
271 | -- The status-change callback may be triggered as the aggregate may may | ||
272 | -- transition to 'Dormant' (empty) or 'AwaitingSessionPacket' (if the last | ||
273 | -- 'Established' session is closed). | ||
274 | delSession :: AggregateSession -> Int -> IO DelResult | ||
275 | delSession c sid = do | ||
276 | (con, r) <- atomically $ do | ||
277 | imap <- readTVar (contactSession c) | ||
278 | emap <- readTVar (contactEstablished c) | ||
279 | let emap' = IntMap.delete sid emap | ||
280 | imap' = IntMap.delete sid imap | ||
281 | case IntMap.toList emap of | ||
282 | (sid0,_):_ | IntMap.null emap' | ||
283 | , let s = singleSession $ imap IntMap.! sid0 | ||
284 | -> notifyState c c s | ||
285 | $ if IntMap.null imap' then Dormant | ||
286 | else InProgress AwaitingSessionPacket | ||
287 | _ -> return () | ||
288 | writeTVar (contactSession c) imap' | ||
289 | writeTVar (contactEstablished c) emap' | ||
290 | return ( IntMap.lookup sid imap, IntMap.null imap') | ||
291 | mapM_ (sClose . singleSession) con | ||
292 | return $ if r then NoSession | ||
293 | else DeletedSession | ||
294 | |||
295 | -- | Send a packet to one or all of the component sessions in the aggregate. | ||
296 | dispatchMessage :: AggregateSession -> Maybe Int -- ^ 'Nothing' to broadcast, otherwise SessionID. | ||
297 | -> CryptoMessage -> IO () | ||
298 | dispatchMessage c msid msg = join $ atomically $ do | ||
299 | imap <- readTVar (contactSession c) | ||
300 | let go = case msid of Nothing -> forM_ imap | ||
301 | Just sid -> forM_ (IntMap.lookup sid imap) | ||
302 | return $ go $ \con -> sendMessage (sTransport $ singleSession con) () msg | ||
303 | |||
304 | -- | Retry until: | ||
305 | -- | ||
306 | -- * a packet arrives (with component session ID) arrives. | ||
307 | -- | ||
308 | -- * the 'AggregateSession' is closed with 'closeAll'. | ||
309 | awaitAny :: AggregateSession -> STM (Maybe (Int,CryptoMessage)) | ||
310 | awaitAny c = readTMChan (contactChannel c) | ||
311 | |||
312 | -- | Close all connections associated with the aggregate. No new sessions will | ||
313 | -- be accepted after this, and the notify callback will be informed that we've | ||
314 | -- transitioned to 'Dormant'. | ||
315 | closeAll :: AggregateSession -> IO () | ||
316 | closeAll c = join $ atomically $ do | ||
317 | imap <- readTVar (contactSession c) | ||
318 | closeTMChan (contactChannel c) | ||
319 | return $ forM_ (IntMap.keys imap) $ \sid -> delSession c sid | ||
320 | |||
321 | -- | Query the current status of the aggregate, there are three possible | ||
322 | -- values: | ||
323 | -- | ||
324 | -- [ Dormant ] - No pending or established sessions. | ||
325 | -- | ||
326 | -- [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are | ||
327 | -- fully established. | ||
328 | -- | ||
329 | -- [ Established ] - At least one session is fully established and we can | ||
330 | -- send and receive packets via this aggregate. | ||
331 | -- | ||
332 | aggregateStatus :: AggregateSession -> STM (Status ToxProgress) | ||
333 | aggregateStatus c = do | ||
334 | isclosed <- isClosedTMChan (contactChannel c) | ||
335 | imap <- readTVar (contactSession c) | ||
336 | emap <- readTVar (contactEstablished c) | ||
337 | return $ case () of | ||
338 | _ | isclosed -> Dormant | ||
339 | | not (IntMap.null emap) -> Established | ||
340 | | not (IntMap.null imap) -> InProgress AwaitingSessionPacket | ||
341 | | otherwise -> Dormant | ||
342 | |||
343 | -- | Query whether the supplied ToxID keys are compatible with this aggregate. | ||
344 | -- | ||
345 | -- [ Nothing ] Any keys would be compatible because there is not yet any | ||
346 | -- sessions in progress. | ||
347 | -- | ||
348 | -- [ Just True ] The supplied keys match the session in progress. | ||
349 | -- | ||
350 | -- [ Just False ] The supplied keys are incompatible. | ||
351 | checkCompatible :: PublicKey -- ^ Local Tox key (for which we know the secret). | ||
352 | -> PublicKey -- ^ Remote Tox key. | ||
353 | -> AggregateSession -> STM (Maybe Bool) | ||
354 | checkCompatible me them c = do | ||
355 | isclosed <- isClosedTMChan (contactChannel c) | ||
356 | imap <- readTVar (contactSession c) | ||
357 | return $ case IntMap.elems imap of | ||
358 | _ | isclosed -> Just False -- All keys are incompatible (closed). | ||
359 | con:_ -> Just $ sTheirUserKey (singleSession con) == them | ||
360 | && toPublic (sOurKey $ singleSession con) == me | ||
361 | [] -> Nothing | ||
362 | |||
363 | -- | Returns the local and remote keys that are compatible with this aggregate. | ||
364 | -- If 'Nothing' Is returned, then either no key is compatible ('closeAll' was | ||
365 | -- called) or all keys are compatible because no sessions have been associated. | ||
366 | compatibleKeys :: AggregateSession -> STM (Maybe (PublicKey,PublicKey)) | ||
367 | compatibleKeys c = do | ||
368 | isclosed <- isClosedTMChan (contactChannel c) | ||
369 | imap <- readTVar (contactSession c) | ||
370 | return $ case IntMap.elems imap of | ||
371 | _ | isclosed -> Nothing -- none. | ||
372 | con:_ -> Just ( toPublic (sOurKey $ singleSession con) | ||
373 | , sTheirUserKey (singleSession con)) | ||
374 | [] -> Nothing -- any. | ||
diff --git a/dht/src/Network/Tox/Avahi.hs b/dht/src/Network/Tox/Avahi.hs new file mode 100644 index 00000000..635ba656 --- /dev/null +++ b/dht/src/Network/Tox/Avahi.hs | |||
@@ -0,0 +1,65 @@ | |||
1 | {-# OPTIONS_GHC -Wall #-} | ||
2 | {-# LANGUAGE RecordWildCards #-} | ||
3 | {-# LANGUAGE ViewPatterns #-} | ||
4 | module Network.Tox.Avahi | ||
5 | ( module Network.Tox.Avahi | ||
6 | , NodeInfo(..) | ||
7 | , NodeId | ||
8 | ) where | ||
9 | |||
10 | import Control.Applicative | ||
11 | import Data.Foldable | ||
12 | import Network.Address | ||
13 | import Network.Avahi | ||
14 | import Network.BSD (getHostName) | ||
15 | import Network.Tox.NodeId | ||
16 | import Text.Read | ||
17 | |||
18 | toxServiceName :: String | ||
19 | toxServiceName = "_tox_dht._udp" | ||
20 | |||
21 | toxServiceDomain :: String | ||
22 | toxServiceDomain = "local" | ||
23 | |||
24 | (<.>) :: String -> String -> String | ||
25 | a <.> b = a ++ "." ++ b | ||
26 | |||
27 | toxService :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> Service | ||
28 | toxService hostname (fromIntegral -> port) dhtkey toxid = | ||
29 | Service { | ||
30 | serviceProtocol = PROTO_UNSPEC, | ||
31 | serviceName = "Tox DHT @ " ++ hostname, | ||
32 | serviceType = toxServiceName, | ||
33 | serviceDomain = toxServiceDomain, | ||
34 | serviceHost = if null hostname then "" else hostname <.> toxServiceDomain, | ||
35 | serviceAddress = Nothing, | ||
36 | servicePort = port, | ||
37 | serviceText = maybe (show dhtkey) (show . ((,) dhtkey)) toxid | ||
38 | } | ||
39 | |||
40 | announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> IO () | ||
41 | announceToxServiceWithHostname = (boobs.boobs) announce toxService | ||
42 | where boobs = ((.).(.)) | ||
43 | |||
44 | announceToxService :: PortNumber -> NodeId -> (Maybe NodeId) -> IO () | ||
45 | announceToxService a b c = do | ||
46 | h <- getHostName | ||
47 | announceToxServiceWithHostname h a b c | ||
48 | |||
49 | queryToxService :: (NodeInfo -> Maybe NodeId -> IO ()) -> IO () | ||
50 | queryToxService cb = | ||
51 | browse $ | ||
52 | BrowseQuery | ||
53 | { lookupProtocol = PROTO_UNSPEC | ||
54 | , lookupServiceName = toxServiceName | ||
55 | , lookupDomain = toxServiceDomain | ||
56 | , lookupCallback = runCallback | ||
57 | } | ||
58 | where | ||
59 | runCallback Service {..} = do | ||
60 | let both :: Maybe (NodeId, NodeId) | ||
61 | both = readMaybe serviceText | ||
62 | nid = (fst <$> both) <|> readMaybe serviceText | ||
63 | addr = readMaybe =<< serviceAddress | ||
64 | p = fromIntegral servicePort | ||
65 | forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p) (snd <$> both) | ||
diff --git a/dht/src/Network/Tox/ContactInfo.hs b/dht/src/Network/Tox/ContactInfo.hs new file mode 100644 index 00000000..e7cb48c1 --- /dev/null +++ b/dht/src/Network/Tox/ContactInfo.hs | |||
@@ -0,0 +1,172 @@ | |||
1 | {-# LANGUAGE NamedFieldPuns #-} | ||
2 | {-# LANGUAGE LambdaCase #-} | ||
3 | module Network.Tox.ContactInfo where | ||
4 | |||
5 | import Connection | ||
6 | |||
7 | import Data.Time.Clock.POSIX | ||
8 | import Control.Concurrent.STM | ||
9 | import Control.Monad | ||
10 | import Crypto.PubKey.Curve25519 | ||
11 | import qualified Data.HashMap.Strict as HashMap | ||
12 | ;import Data.HashMap.Strict (HashMap) | ||
13 | import Data.Maybe | ||
14 | import Network.Tox.DHT.Transport as DHT | ||
15 | import Network.Tox.NodeId (id2key) | ||
16 | import Network.Tox.Onion.Transport as Onion | ||
17 | import DPut | ||
18 | import DebugTag | ||
19 | |||
20 | newtype ContactInfo extra = ContactInfo | ||
21 | -- | Map our toxid public key to an Account record. | ||
22 | { accounts :: TVar (HashMap NodeId{-my userkey-} (Account extra)) | ||
23 | } | ||
24 | |||
25 | data Account extra = Account | ||
26 | { userSecret :: SecretKey -- local secret key | ||
27 | , contacts :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info | ||
28 | , accountExtra :: TVar extra | ||
29 | , eventChan :: TChan ContactEvent | ||
30 | } | ||
31 | |||
32 | data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData } | ||
33 | | PolicyChange { contact :: PublicKey, policyChange :: Policy } | ||
34 | | AddrChange { contact :: PublicKey, addrChange :: NodeInfo } | ||
35 | | SessionEstablished { contact :: PublicKey } | ||
36 | | SessionTerminated { contact :: PublicKey } | ||
37 | |||
38 | data Contact = Contact | ||
39 | { contactKeyPacket :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey)) | ||
40 | , contactLastSeenAddr :: TVar (Maybe (POSIXTime,NodeInfo)) | ||
41 | , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest)) | ||
42 | , contactPolicy :: TVar (Maybe Connection.Policy) | ||
43 | } | ||
44 | |||
45 | newContactInfo :: IO (ContactInfo extra) | ||
46 | newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty | ||
47 | |||
48 | myKeyPairs :: ContactInfo extra -> STM [(SecretKey,PublicKey)] | ||
49 | myKeyPairs (ContactInfo accounts) = do | ||
50 | acnts <- readTVar accounts | ||
51 | forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do | ||
52 | return (userSecret,id2key nid) | ||
53 | |||
54 | updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO () | ||
55 | updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do | ||
56 | dput XMisc "updateContactInfo!!!" | ||
57 | now <- getPOSIXTime | ||
58 | atomically $ do | ||
59 | as <- readTVar (accounts roster) | ||
60 | maybe (return ()) | ||
61 | (updateAccount now remoteUserKey omsg) | ||
62 | $ HashMap.lookup (key2id localUserKey) as | ||
63 | |||
64 | initContact :: STM Contact | ||
65 | initContact = Contact <$> newTVar Nothing | ||
66 | <*> newTVar Nothing | ||
67 | <*> newTVar Nothing | ||
68 | <*> newTVar Nothing | ||
69 | |||
70 | getContact :: PublicKey -> Account extra -> STM (Maybe Contact) | ||
71 | getContact remoteUserKey acc = do | ||
72 | let rkey = key2id remoteUserKey | ||
73 | cmap <- readTVar (contacts acc) | ||
74 | return $ HashMap.lookup rkey cmap | ||
75 | |||
76 | updateAccount' :: PublicKey -> Account extra -> (Contact -> STM ()) -> STM () | ||
77 | updateAccount' remoteUserKey acc updater = do | ||
78 | let rkey = key2id remoteUserKey | ||
79 | cmap <- readTVar (contacts acc) | ||
80 | contact <- case HashMap.lookup rkey cmap of | ||
81 | Just contact -> return contact | ||
82 | Nothing -> do contact <- initContact | ||
83 | writeTVar (contacts acc) $ HashMap.insert rkey contact cmap | ||
84 | return contact | ||
85 | updater contact | ||
86 | |||
87 | updateAccount :: POSIXTime -> PublicKey -> Onion.OnionData -> Account extra -> STM () | ||
88 | updateAccount now remoteUserKey omsg acc = do | ||
89 | updateAccount' remoteUserKey acc $ onionUpdate now omsg | ||
90 | writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg | ||
91 | |||
92 | onionUpdate :: POSIXTime -> OnionData -> Contact -> STM () | ||
93 | onionUpdate now (Onion.OnionDHTPublicKey dhtpk) contact | ||
94 | = writeTVar (contactKeyPacket contact) $ Just (now,dhtpk) | ||
95 | onionUpdate now (Onion.OnionFriendRequest fr) contact | ||
96 | = writeTVar (contactFriendRequest contact) $ Just (now,fr) | ||
97 | |||
98 | policyUpdate :: Policy -> Contact -> STM () | ||
99 | policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy | ||
100 | |||
101 | addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM () | ||
102 | addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr) | ||
103 | |||
104 | setContactPolicy :: PublicKey -> Policy -> Account extra -> STM () | ||
105 | setContactPolicy remoteUserKey policy acc = do | ||
106 | updateAccount' remoteUserKey acc $ policyUpdate policy | ||
107 | writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy | ||
108 | |||
109 | setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM () | ||
110 | setContactAddr now remoteUserKey addr acc = do | ||
111 | contact <- getContact remoteUserKey acc | ||
112 | let update = updateAccount' remoteUserKey acc $ addrUpdate now addr | ||
113 | let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr | ||
114 | join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case | ||
115 | Just (_, a) | addr == a -> update -- updates time only | ||
116 | Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old | ||
117 | Nothing -> update >> notify -- or if we don't have any | ||
118 | _ -> return () -- otherwise just wait | ||
119 | |||
120 | setEstablished :: PublicKey -> Account extra -> STM () | ||
121 | setEstablished remoteUserKey acc = | ||
122 | writeTChan (eventChan acc) $ SessionEstablished remoteUserKey | ||
123 | |||
124 | setTerminated :: PublicKey -> Account extra -> STM () | ||
125 | setTerminated remoteUserKey acc = | ||
126 | writeTChan (eventChan acc) $ SessionTerminated remoteUserKey | ||
127 | |||
128 | |||
129 | addContactInfo :: ContactInfo extra -> SecretKey -> extra -> STM () | ||
130 | addContactInfo (ContactInfo as) sk extra = do | ||
131 | a <- newAccount sk extra | ||
132 | modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a | ||
133 | |||
134 | delContactInfo :: ContactInfo extra -> PublicKey -> STM () | ||
135 | delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk) | ||
136 | |||
137 | newAccount :: SecretKey -> extra -> STM (Account extra) | ||
138 | newAccount sk extra = Account sk <$> newTVar HashMap.empty | ||
139 | <*> newTVar extra | ||
140 | <*> newBroadcastTChan | ||
141 | |||
142 | dnsPresentation :: ContactInfo extra -> STM String | ||
143 | dnsPresentation (ContactInfo accsvar) = do | ||
144 | accs <- readTVar accsvar | ||
145 | ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do | ||
146 | cs <- readTVar cvar | ||
147 | rs <- forM (HashMap.toList cs) $ \(nid,c) -> do | ||
148 | mkpkt <- readTVar (contactKeyPacket c) | ||
149 | return $ fmap (\(_,d) -> (nid,d)) mkpkt | ||
150 | return $ | ||
151 | "; local key = " ++ show (key2id $ toPublic sec) ++ "\n" | ||
152 | ++ concatMap dnsPresentation1 (catMaybes rs) | ||
153 | return $ concat ms | ||
154 | |||
155 | dnsPresentation1 :: (NodeId,DHTPublicKey) -> String | ||
156 | dnsPresentation1 (nid,dk) = unlines | ||
157 | [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ] | ||
158 | ] | ||
159 | |||
160 | type LocalKey = NodeId | ||
161 | type RemoteKey = NodeId | ||
162 | |||
163 | friendRequests :: ContactInfo extra -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)]) | ||
164 | friendRequests (ContactInfo roster) = do | ||
165 | accs <- readTVar roster | ||
166 | forM accs $ \Account { userSecret = sec, contacts = cvar } -> do | ||
167 | cs <- readTVar cvar | ||
168 | rs <- forM (HashMap.toList cs) $ \(nid,c) -> do | ||
169 | mfr <- readTVar (contactFriendRequest c) | ||
170 | return $ fmap (\(_,x) -> (nid,x)) mfr | ||
171 | return $ catMaybes rs | ||
172 | |||
diff --git a/dht/src/Network/Tox/Crypto/Transport.hs b/dht/src/Network/Tox/Crypto/Transport.hs new file mode 100644 index 00000000..a18b550d --- /dev/null +++ b/dht/src/Network/Tox/Crypto/Transport.hs | |||
@@ -0,0 +1,1029 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE DataKinds #-} | ||
3 | {-# LANGUAGE FlexibleInstances #-} | ||
4 | {-# LANGUAGE GADTs #-} | ||
5 | {-# LANGUAGE KindSignatures #-} | ||
6 | {-# LANGUAGE LambdaCase #-} | ||
7 | {-# LANGUAGE NamedFieldPuns #-} | ||
8 | {-# LANGUAGE PatternSynonyms #-} | ||
9 | {-# LANGUAGE StandaloneDeriving #-} | ||
10 | {-# LANGUAGE TupleSections #-} | ||
11 | {-# LANGUAGE ViewPatterns #-} | ||
12 | module Network.Tox.Crypto.Transport | ||
13 | ( showCryptoMsg | ||
14 | , parseCrypto | ||
15 | , encodeCrypto | ||
16 | , unpadCryptoMsg | ||
17 | , decodeRawCryptoMsg | ||
18 | , parseHandshakes | ||
19 | , encodeHandshakes | ||
20 | , CryptoData(..) | ||
21 | , CryptoMessage(..) | ||
22 | , MessageName(..) | ||
23 | , CryptoPacket(..) | ||
24 | , HandshakeData(..) | ||
25 | , Handshake(..) | ||
26 | , PeerInfo(..) | ||
27 | , UserStatus(..) | ||
28 | , TypingStatus(..) | ||
29 | , GroupChatId(..) | ||
30 | , MessageType(..) | ||
31 | , isKillPacket, isOFFLINE | ||
32 | , KnownLossyness(..) | ||
33 | , AsWord16(..) | ||
34 | , AsWord64(..) | ||
35 | -- feild name classes | ||
36 | , HasGroupChatID(..) | ||
37 | , HasGroupNumber(..) | ||
38 | , HasPeerNumber(..) | ||
39 | , HasMessageNumber(..) | ||
40 | , HasMessageName(..) | ||
41 | , HasMessageData(..) | ||
42 | , HasName(..) | ||
43 | , HasTitle(..) | ||
44 | , HasMessage(..) | ||
45 | , HasMessageType(..) | ||
46 | -- lenses | ||
47 | #ifdef USE_lens | ||
48 | , groupNumber, groupNumberToJoin, peerNumber, messageNumber | ||
49 | , messageName, messageData, name, title, message, messageType | ||
50 | #endif | ||
51 | -- constructor | ||
52 | -- utils | ||
53 | , sizedN | ||
54 | , sizedAtLeastN | ||
55 | , isIndirectGrpChat | ||
56 | , fromEnum8 | ||
57 | , fromEnum16 | ||
58 | , toEnum8 | ||
59 | , getCryptoMessage | ||
60 | , putCryptoMessage | ||
61 | ) where | ||
62 | |||
63 | import Crypto.Tox | ||
64 | import Data.Tox.Msg | ||
65 | import Network.Tox.DHT.Transport (Cookie) | ||
66 | import Network.Tox.NodeId | ||
67 | import DPut | ||
68 | import DebugTag | ||
69 | import Data.PacketBuffer as PB | ||
70 | |||
71 | import Network.Socket | ||
72 | import Data.ByteArray | ||
73 | import Data.Dependent.Sum | ||
74 | |||
75 | import Control.Monad | ||
76 | import Data.ByteString as B | ||
77 | import Data.Function | ||
78 | import Data.Maybe | ||
79 | import Data.Monoid | ||
80 | import Data.Word | ||
81 | import Data.Bits | ||
82 | import Crypto.Hash | ||
83 | import Data.Functor.Contravariant | ||
84 | import Data.Functor.Identity | ||
85 | import Data.Text as T | ||
86 | import Data.Text.Encoding as T | ||
87 | import Data.Serialize as S | ||
88 | import Control.Arrow | ||
89 | import GHC.TypeNats | ||
90 | |||
91 | showCryptoMsg :: Word32 -> CryptoMessage -> [Char] | ||
92 | showCryptoMsg _ msg = show msg | ||
93 | |||
94 | parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr) | ||
95 | parseCrypto (bbs,saddr) = case B.uncons bbs of | ||
96 | Just (0x1b,bs) -> case runGet get bs of | ||
97 | Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet. | ||
98 | Left _ -> Right (bs,saddr) -- Failed parse, strip first byte and pass it on. | ||
99 | _ -> Right (bbs,saddr) -- Type-code mismatch, pass it on. | ||
100 | |||
101 | encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr) | ||
102 | encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr) | ||
103 | |||
104 | parseHandshakes :: ByteString -> SockAddr -> Either String (Handshake Encrypted, SockAddr) | ||
105 | parseHandshakes (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseHandshakes: "++) $ (,saddr) <$> runGet get pkt | ||
106 | parseHandshakes bs _ = Left $ "parseHandshakes_: " ++ show (B.unpack $ B.take 1 bs) | ||
107 | |||
108 | encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr) | ||
109 | encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr) | ||
110 | |||
111 | {- | ||
112 | createRequestPacket :: Word32 -> [Word32] -> CryptoMessage | ||
113 | createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns) | ||
114 | in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r | ||
115 | where | ||
116 | ys = Prelude.map (subtract (seqno - 1)) xs | ||
117 | reduceToSums [] = [] | ||
118 | reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs) | ||
119 | makeZeroes :: Word32 -> [Word32] | ||
120 | -- makeZeroes 0 = [] | ||
121 | makeZeroes x | ||
122 | = let (d,m)= x `divMod` 255 | ||
123 | zeros= Prelude.replicate (fromIntegral d) 0 | ||
124 | in zeros ++ [m] | ||
125 | ns :: [Word8] | ||
126 | ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes) | ||
127 | -} | ||
128 | |||
129 | data Handshake (f :: * -> *) = Handshake | ||
130 | { -- The cookie is a cookie obtained by | ||
131 | -- sending a cookie request packet to the peer and getting a cookie | ||
132 | -- response packet with a cookie in it. It may also be obtained in the | ||
133 | -- handshake packet by a peer receiving a handshake packet (Other | ||
134 | -- Cookie). | ||
135 | handshakeCookie :: Cookie f | ||
136 | -- The nonce is a nonce used to encrypt the encrypted part of the handshake | ||
137 | -- packet. | ||
138 | , handshakeNonce :: Nonce24 | ||
139 | -- The encrypted part of the handshake packet is encrypted with the long | ||
140 | -- term user-keys of both peers. | ||
141 | , handshakeData :: f HandshakeData | ||
142 | } | ||
143 | |||
144 | instance Serialize (Handshake Encrypted) where | ||
145 | get = Handshake <$> get <*> get <*> get | ||
146 | put (Handshake cookie n24 dta) = put cookie >> put n24 >> put dta | ||
147 | |||
148 | data HandshakeData = HandshakeData | ||
149 | { baseNonce :: Nonce24 | ||
150 | -- ^ 24 bytes base nonce, recipient uses this to encrypt packets sent to the one who sent this handshake | ||
151 | -- adding one each time, so it can double as something like an approximate packet number | ||
152 | , sessionKey :: PublicKey | ||
153 | -- ^ session public key of the peer (32 bytes) | ||
154 | -- The recipient of the handshake encrypts using this public key when sending CryptoPackets | ||
155 | , cookieHash :: Digest SHA512 | ||
156 | -- ^ sha512 hash of the entire Cookie sitting outside the encrypted part | ||
157 | -- This prevents a replay attack where a new cookie is inserted into | ||
158 | -- an old valid handshake packet | ||
159 | , otherCookie :: Cookie Encrypted | ||
160 | -- ^ Other Cookie (used by the recipient to respond to the handshake packet) | ||
161 | } | ||
162 | deriving (Eq,Ord,Show) | ||
163 | |||
164 | instance Sized HandshakeData where | ||
165 | size = contramap baseNonce size | ||
166 | <> contramap (key2id . sessionKey) size | ||
167 | <> ConstSize 64 -- contramap cookieHash size -- missing instance Sized (Digest SHA512) | ||
168 | <> contramap otherCookie size | ||
169 | |||
170 | instance Serialize HandshakeData where | ||
171 | get = HandshakeData <$> get | ||
172 | <*> getPublicKey | ||
173 | <*> (fromJust . digestFromByteString <$> getBytes 64) | ||
174 | <*> get | ||
175 | put (HandshakeData n k h c) = do | ||
176 | put n | ||
177 | putPublicKey k | ||
178 | putByteString (convert h) | ||
179 | put c | ||
180 | |||
181 | data CryptoPacket (f :: * -> *) = CryptoPacket | ||
182 | { -- | The last 2 bytes of the nonce used to encrypt 'pktData' | ||
183 | pktNonce :: Word16 | ||
184 | -- The payload is encrypted with the session key and 'baseNonce' set by | ||
185 | -- the receiver in their handshake + packet number (starting at 0, big | ||
186 | -- endian math). | ||
187 | , pktData :: f CryptoData | ||
188 | } | ||
189 | |||
190 | deriving instance Show (CryptoPacket Encrypted) | ||
191 | |||
192 | instance Sized CryptoData where | ||
193 | size = contramap bufferStart size | ||
194 | <> contramap bufferEnd size | ||
195 | <> contramap bufferData size | ||
196 | |||
197 | instance Serialize (CryptoPacket Encrypted) where | ||
198 | get = CryptoPacket <$> get <*> get | ||
199 | put (CryptoPacket n16 dta) = put n16 >> put dta | ||
200 | |||
201 | data CryptoData = CryptoData | ||
202 | { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)] | ||
203 | bufferStart :: Word32 | ||
204 | -- | [ uint32_t packet number if lossless | ||
205 | -- , sendbuffer buffer_end if lossy , (big endian)] | ||
206 | , bufferEnd :: Word32 | ||
207 | -- | [data] (TODO See Note [Padding]) | ||
208 | , bufferData :: CryptoMessage | ||
209 | } deriving (Eq,Show) | ||
210 | |||
211 | {- | ||
212 | Note [Padding] | ||
213 | |||
214 | TODO: The 'bufferData' field of 'CryptoData' should probably be something like | ||
215 | /Padded CryptoMessage/ because c-toxcore strips leading zeros on incoming and | ||
216 | pads leading zeros on outgoing packets. | ||
217 | |||
218 | After studying c-toxcore (at commit c49a6e7f5bc245a51a3c85cc2c8b7f881c412998), | ||
219 | I've determined the following behavior. | ||
220 | |||
221 | Incoming: All leading zero bytes are stripped until possibly the whole packet | ||
222 | is consumed (in which case it is discarded). This happens at | ||
223 | toxcore/net_crypto.c:1366:handle_data_packet_core(). | ||
224 | |||
225 | Outgoing: The number of zeros added is: | ||
226 | |||
227 | padding_length len = (1373 - len) `mod` 8 where | ||
228 | |||
229 | where /len/ is the size of the non-padded CryptoMessage. This happens at | ||
230 | toxcore/net_crypto.c:936:send_data_packet_helper() | ||
231 | |||
232 | The number 1373 is written in C as MAX_CRYPTO_DATA_SIZE which is defined in | ||
233 | terms of the max /NetCrypto/ packet size (1400) minus the minimum possible size | ||
234 | of an id-byte (1) and a /CryptoPacket Encrypted/ ( 2 + 4 + 4 + 16 ). | ||
235 | |||
236 | One effect of this is that short messages will be padded to at least 5 bytes. | ||
237 | -} | ||
238 | |||
239 | instance Serialize CryptoData where | ||
240 | get = do | ||
241 | ack <- get | ||
242 | seqno <- get | ||
243 | cm <- getCryptoMessage ack | ||
244 | return $ CryptoData ack seqno cm | ||
245 | put (CryptoData ack seqno dta) = do | ||
246 | put ack | ||
247 | put seqno | ||
248 | putCryptoMessage ack dta | ||
249 | |||
250 | data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum) | ||
251 | instance Serialize TypingStatus where | ||
252 | get = do | ||
253 | x <- get :: Get Word8 | ||
254 | return (toEnum8 x) | ||
255 | put x = put (fromEnum8 x :: Word8) | ||
256 | |||
257 | unpadCryptoMsg :: CryptoMessage -> CryptoMessage | ||
258 | unpadCryptoMsg msg@(Pkt Padding :=> Identity (Padded bs)) = | ||
259 | let unpadded = B.dropWhile (== msgbyte Padding) bs | ||
260 | in either (const msg) id $ runGet (getCryptoMessage 0) unpadded | ||
261 | unpadCryptoMsg msg = msg | ||
262 | |||
263 | decodeRawCryptoMsg :: CryptoData -> CryptoMessage | ||
264 | decodeRawCryptoMsg (CryptoData ack seqno cm) = unpadCryptoMsg cm | ||
265 | |||
266 | instance Sized CryptoMessage where | ||
267 | size = VarSize $ \case | ||
268 | Pkt t :=> Identity x -> case sizeFor t of | ||
269 | ConstSize sz -> 1 + sz | ||
270 | VarSize f -> 1 + f x | ||
271 | |||
272 | sizeFor :: Sized x => p x -> Size x | ||
273 | sizeFor _ = size | ||
274 | |||
275 | |||
276 | getCryptoMessage :: Word32 -> Get CryptoMessage | ||
277 | getCryptoMessage seqno = fix $ \stripPadding -> do | ||
278 | t <- getWord8 | ||
279 | case msgTag t of | ||
280 | Just (M Padding) -> stripPadding | ||
281 | Just (M msg) -> do x <- getPacket seqno | ||
282 | return $ Pkt msg ==> x | ||
283 | Nothing -> return $ Pkt MESSAGE ==> "Unhandled packet: " <> T.pack (show t) -- $ Pkt Padding ==> Padded mempty | ||
284 | |||
285 | putCryptoMessage :: Word32 -> CryptoMessage -> Put | ||
286 | putCryptoMessage seqno (Pkt t :=> Identity x) = do | ||
287 | putWord8 (msgbyte t) | ||
288 | putPacket seqno x | ||
289 | |||
290 | |||
291 | #ifdef USE_lens | ||
292 | erCompat :: String -> a | ||
293 | erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type" | ||
294 | #endif | ||
295 | |||
296 | |||
297 | newtype GroupChatId = GrpId ByteString -- 33 bytes | ||
298 | deriving (Show,Eq) | ||
299 | |||
300 | class HasGroupChatID x where | ||
301 | getGroupChatID :: x -> GroupChatId | ||
302 | setGroupChatID :: x -> GroupChatId -> x | ||
303 | |||
304 | sizedN :: Int -> ByteString -> ByteString | ||
305 | sizedN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) | ||
306 | else B.take n bs | ||
307 | |||
308 | sizedAtLeastN :: Int -> ByteString -> ByteString | ||
309 | sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0) | ||
310 | else bs | ||
311 | |||
312 | {- | ||
313 | instance HasGroupChatID CryptoMessage where | ||
314 | -- Get | ||
315 | getGroupChatID (Pkt INVITE_CONFERENCE :=> Identity payload) | ||
316 | = let (xs,ys) = B.splitAt 1 payload' | ||
317 | payload' = sizedN 38 payload | ||
318 | in case B.unpack xs of | ||
319 | [isResponse] | 0 <- isResponse -> GrpId (B.take 33 $ B.drop 2 ys) -- skip group number | ||
320 | [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers | ||
321 | _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message" | ||
322 | |||
323 | getGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload)) | ||
324 | getGroupChatID _ = error "getGroupChatID on non-groupchat message." | ||
325 | |||
326 | -- Set | ||
327 | setGroupChatID msg@(Pkt INVITE_CONFERENCE :=> Identity payload) (GrpId newid) | ||
328 | = let (xs,ys) = B.splitAt 1 payload' | ||
329 | payload' = sizedN 38 payload | ||
330 | in case B.unpack xs of | ||
331 | [isResponse] | 0 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 2 ys), sizedN 33 newid]) -- keep group number | ||
332 | [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers | ||
333 | _ -> msg -- unexpected condition, leave unchanged | ||
334 | |||
335 | setGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) (GrpId newid) = Pkt ONLINE_PACKET ==> (B.concat [B.take 2 payload, sizedN 33 newid]) | ||
336 | setGroupChatID _ _= error "setGroupChatID on non-groupchat message." | ||
337 | -} | ||
338 | |||
339 | #ifdef USE_lens | ||
340 | groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x) | ||
341 | groupChatID = lens getGroupChatID setGroupChatID | ||
342 | #endif | ||
343 | |||
344 | type GroupNumber = Word16 | ||
345 | type PeerNumber = Word16 | ||
346 | type MessageNumber = Word32 | ||
347 | |||
348 | class HasGroupNumber x where | ||
349 | getGroupNumber :: x -> GroupNumber | ||
350 | setGroupNumber :: x -> GroupNumber -> x | ||
351 | |||
352 | {- | ||
353 | instance HasGroupNumber CryptoMessage where | ||
354 | getGroupNumber (Pkt INVITE_CONFERENCE :=> Identity (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1 | ||
355 | = let twobytes = B.take 2 xs | ||
356 | Right n = S.decode twobytes | ||
357 | in n | ||
358 | getGroupNumber (UpToN (fromEnum -> x) (sizedN 2 -> twobytes)) | x >= 0x61 && x <= 0x63 | ||
359 | = let Right n = S.decode twobytes in n | ||
360 | getGroupNumber (UpToN (fromEnum -> 0xC7) (sizedN 2 -> twobytes)) | ||
361 | = let Right n = S.decode twobytes in n | ||
362 | |||
363 | getGroupNumber _ = error "getGroupNumber on CryptoMessage without group number field." | ||
364 | |||
365 | setGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) groupnum | ||
366 | = UpToN INVITE_GROUPCHAT (B.cons isResp (B.append (S.encode groupnum) (B.drop 2 xs))) | ||
367 | setGroupNumber (UpToN xE@(fromEnum -> x) (sizedAtLeastN 2 -> B.splitAt 2 -> (twobytes,xs))) groupnum | ||
368 | | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs) | ||
369 | | x == 0xC7 = UpToN xE (B.append (S.encode groupnum) xs) | ||
370 | setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field." | ||
371 | -} | ||
372 | |||
373 | #ifdef USE_lens | ||
374 | groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x) | ||
375 | groupNumber = lens getGroupNumber setGroupNumber | ||
376 | #endif | ||
377 | |||
378 | class HasGroupNumberToJoin x where | ||
379 | getGroupNumberToJoin :: x -> GroupNumber | ||
380 | setGroupNumberToJoin :: x -> GroupNumber -> x | ||
381 | |||
382 | {- | ||
383 | instance HasGroupNumberToJoin CryptoMessage where | ||
384 | getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join | ||
385 | = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local) | ||
386 | Right n = S.decode twobytes | ||
387 | in n | ||
388 | getGroupNumberToJoin _ = error "getGroupNumberToJoin on CryptoMessage without group number (to join) field." | ||
389 | setGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) groupnum | ||
390 | = let (a,b) = B.splitAt 2 xs | ||
391 | (twoBytes,c) = B.splitAt 2 b | ||
392 | twoBytes' = S.encode groupnum | ||
393 | in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c])) | ||
394 | setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field." | ||
395 | -} | ||
396 | |||
397 | #ifdef USE_lens | ||
398 | groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x) | ||
399 | groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin | ||
400 | #endif | ||
401 | |||
402 | class HasPeerNumber x where | ||
403 | getPeerNumber :: x -> PeerNumber | ||
404 | setPeerNumber :: x -> PeerNumber -> x | ||
405 | |||
406 | {- | ||
407 | instance HasPeerNumber CryptoMessage where | ||
408 | getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) | ||
409 | = let Right n = S.decode twobytes in n | ||
410 | getPeerNumber (UpToN (fromEnum -> 0xC7) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes))) | ||
411 | = let Right n = S.decode twobytes in n | ||
412 | getPeerNumber _ = error "getPeerNumber on CryptoMessage without peer number field." | ||
413 | |||
414 | setPeerNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum | ||
415 | = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) | ||
416 | setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum | ||
417 | = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs]) | ||
418 | setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field." | ||
419 | -} | ||
420 | |||
421 | #ifdef USE_lens | ||
422 | peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x) | ||
423 | peerNumber = lens getPeerNumber setPeerNumber | ||
424 | #endif | ||
425 | |||
426 | class HasMessageNumber x where | ||
427 | getMessageNumber :: x -> MessageNumber | ||
428 | setMessageNumber :: x -> MessageNumber -> x | ||
429 | |||
430 | {- | ||
431 | instance HasMessageNumber CryptoMessage where | ||
432 | getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) | ||
433 | = let Right n = S.decode fourbytes in n | ||
434 | getMessageNumber (UpToN (fromEnum -> 0xC7) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes))) | ||
435 | = let Right n = S.decode fourbytes in n | ||
436 | getMessageNumber _ = error "getMessageNumber on CryptoMessage without message number field." | ||
437 | |||
438 | setMessageNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum | ||
439 | = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) | ||
440 | setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum | ||
441 | = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs]) | ||
442 | setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field." | ||
443 | -} | ||
444 | |||
445 | #ifdef USE_lens | ||
446 | messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x) | ||
447 | messageNumber = lens getMessageNumber setMessageNumber | ||
448 | #endif | ||
449 | |||
450 | class HasMessageName x where | ||
451 | getMessageName :: x -> MessageName | ||
452 | setMessageName :: x -> MessageName -> x | ||
453 | |||
454 | {- | ||
455 | instance HasMessageName CryptoMessage where | ||
456 | getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) | ||
457 | = let [n] = B.unpack onebyte | ||
458 | in toEnum . fromIntegral $ n | ||
459 | getMessageName (UpToN (fromEnum -> 0xC7) (sizedN 9 -> B.splitAt 8 -> (_,onebyte))) | ||
460 | = let [n] = B.unpack onebyte | ||
461 | in toEnum . fromIntegral $ n | ||
462 | getMessageName _ = error "getMessageName on CryptoMessage without message name field." | ||
463 | |||
464 | setMessageName (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename | ||
465 | = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) | ||
466 | setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename | ||
467 | = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)]) | ||
468 | setMessageName _ _ = error "setMessageName on CryptoMessage without message name field." | ||
469 | -} | ||
470 | |||
471 | #ifdef USE_lens | ||
472 | messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x) | ||
473 | messageName = lens getMessageName setMessageName | ||
474 | #endif | ||
475 | |||
476 | data KnownLossyness = KnownLossy | KnownLossless | ||
477 | deriving (Eq,Ord,Show,Enum) | ||
478 | |||
479 | data MessageType = Msg Word8 | ||
480 | | GrpMsg KnownLossyness MessageName | ||
481 | deriving (Eq,Show) | ||
482 | |||
483 | class AsWord16 a where | ||
484 | toWord16 :: a -> Word16 | ||
485 | fromWord16 :: Word16 -> a | ||
486 | |||
487 | class AsWord64 a where | ||
488 | toWord64 :: a -> Word64 | ||
489 | fromWord64 :: Word64 -> a | ||
490 | |||
491 | |||
492 | fromEnum16 :: Enum a => a -> Word16 | ||
493 | fromEnum16 = fromIntegral . fromEnum | ||
494 | |||
495 | fromEnum64 :: Enum a => a -> Word64 | ||
496 | fromEnum64 = fromIntegral . fromEnum | ||
497 | |||
498 | |||
499 | -- MessageType, for our client keep it inside 16 bits | ||
500 | -- but we should extend it to 32 or even 64 on the wire. | ||
501 | -- Bits: 000000glxxxxxxxx, x = message id or extension specific, l = if extended, lossy/lossless, g = if extended, nongroup/group | ||
502 | -- (at least one bit set in high byte means extended, if none but the g flag and possibly l flag, assume default grp extension) | ||
503 | instance AsWord16 MessageType where | ||
504 | toWord16 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8) | ||
505 | toWord16 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum16 lsy) + fromIntegral (fromEnum8 msgName) | ||
506 | fromWord16 x | x < 256 = Msg (toEnum $ fromIntegral x) | ||
507 | fromWord16 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x) | ||
508 | fromWord16 x = error "Not clear how to convert Word16 to MessageType" | ||
509 | |||
510 | instance AsWord64 MessageType where | ||
511 | toWord64 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8) | ||
512 | toWord64 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum64 lsy) + fromIntegral (fromEnum8 msgName) | ||
513 | fromWord64 x | x < 256 = Msg (toEnum $ fromIntegral x) | ||
514 | fromWord64 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x) | ||
515 | fromWord64 x = error "Not clear how to convert Word64 to MessageType" | ||
516 | |||
517 | #ifdef USE_lens | ||
518 | word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x) | ||
519 | word16 = lens toWord16 (\_ x -> fromWord16 x) | ||
520 | #endif | ||
521 | |||
522 | instance Ord MessageType where | ||
523 | compare (Msg x) (Msg y) = compare x y | ||
524 | compare (GrpMsg lx x) (GrpMsg ly y) = let r1 = compare lx ly | ||
525 | in if r1==EQ then compare x y else r1 | ||
526 | compare (Msg _) (GrpMsg _ _) = LT | ||
527 | compare (GrpMsg _ _) (Msg _) = GT | ||
528 | |||
529 | class HasMessageType x where | ||
530 | getMessageType :: x -> MessageType | ||
531 | setMessageType :: x -> MessageType -> x | ||
532 | |||
533 | {- | ||
534 | instance HasMessageType CryptoMessage where | ||
535 | getMessageType (OneByte mid) = Msg mid | ||
536 | getMessageType (TwoByte mid _) = Msg mid | ||
537 | getMessageType m@(UpToN MESSAGE_GROUPCHAT _) = GrpMsg KnownLossless (getMessageName m) | ||
538 | getMessageType m@(UpToN LOSSY_GROUPCHAT _) = GrpMsg KnownLossy (getMessageName m) | ||
539 | getMessageType (UpToN mid _) = Msg mid | ||
540 | |||
541 | setMessageType (OneByte _ ) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty ) mname | ||
542 | setMessageType (TwoByte _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname | ||
543 | setMessageType (OneByte _ ) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT B.empty ) mname | ||
544 | setMessageType (TwoByte _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT (B.singleton x)) mname | ||
545 | setMessageType (UpToN _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname | ||
546 | setMessageType (UpToN _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT x) mname | ||
547 | setMessageType m (Msg mid) | Just (True,1) <- msgSizeParam mid = OneByte mid | ||
548 | setMessageType (OneByte mid0 ) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid 0 | ||
549 | setMessageType (TwoByte mid0 x) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid x | ||
550 | setMessageType (UpToN mid0 x) (Msg mid) | Just (True,n) <- msgSizeParam mid = UpToN mid (sizedN n x) | ||
551 | setMessageType (OneByte mid0) (Msg mid) = UpToN mid B.empty | ||
552 | setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x) | ||
553 | setMessageType (UpToN mid0 x) (Msg mid) = UpToN mid x | ||
554 | -} | ||
555 | |||
556 | {- | ||
557 | instance HasMessageType CryptoData where | ||
558 | getMessageType (CryptoData { bufferData }) = getMessageType bufferData | ||
559 | setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ } | ||
560 | -} | ||
561 | |||
562 | #ifdef USE_lens | ||
563 | -- | This lens should always succeed on CryptoMessage | ||
564 | messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x) | ||
565 | messageType = lens getMessageType setMessageType | ||
566 | #endif | ||
567 | |||
568 | type MessageData = B.ByteString | ||
569 | |||
570 | class HasMessageData x where | ||
571 | getMessageData :: x -> MessageData | ||
572 | setMessageData :: x -> MessageData -> x | ||
573 | |||
574 | {- | ||
575 | instance HasMessageData CryptoMessage where | ||
576 | getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata | ||
577 | getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata | ||
578 | getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x09,peerinfos)))) = peerinfos | ||
579 | -- getMessageData on 0x62:0a is equivalent to getTitle but without decoding the utf8 | ||
580 | getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,title)))) = title | ||
581 | getMessageData _ = error "getMessageData on CryptoMessage without message data field." | ||
582 | |||
583 | setMessageData (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- MESSAGE_GROUPCHAT | ||
584 | = UpToN xE (B.concat [bs,messagedata]) | ||
585 | setMessageData (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- LOSSY_GROUPCHAT | ||
586 | = UpToN xE (B.concat [bs,messagedata]) | ||
587 | setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets | ||
588 | = UpToN xE (B.concat [bs,peerinfosOrTitle]) | ||
589 | setMessageData _ _ = error "setMessageData on CryptoMessage without message data field." | ||
590 | -} | ||
591 | |||
592 | #ifdef USE_lens | ||
593 | messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x) | ||
594 | messageData = lens getMessageData setMessageData | ||
595 | #endif | ||
596 | |||
597 | class HasTitle x where | ||
598 | getTitle :: x -> Text | ||
599 | setTitle :: x -> Text -> x | ||
600 | |||
601 | {- | ||
602 | instance HasTitle CryptoMessage where | ||
603 | getTitle (UpToN xE bs) | ||
604 | | DIRECT_GROUPCHAT {-0x62-} <- xE, | ||
605 | (_,0x0a,mdata) <- splitByteAt 2 bs = decodeUtf8 mdata | ||
606 | | isIndirectGrpChat xE, | ||
607 | let (_,nmb,mdata) = splitByteAt 8 bs | ||
608 | nm = toEnum (fromIntegral nmb), | ||
609 | GroupchatTitleChange <- nm = decodeUtf8 mdata | ||
610 | getTitle _ = error "getTitle on CryptoMessage without title field." | ||
611 | |||
612 | setTitle (UpToN xE bs) msgdta | ||
613 | | DIRECT_GROUPCHAT {-0x62-} <- xE | ||
614 | = let (pre,_,_) = splitByteAt 2 bs | ||
615 | nm = 0x0a | ||
616 | in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) | ||
617 | | isIndirectGrpChat xE | ||
618 | = let (pre,_,_) = splitByteAt 8 bs | ||
619 | nm = fromIntegral $ fromEnum GroupchatTitleChange | ||
620 | in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta)) | ||
621 | setTitle _ _ = error "setTitle on CryptoMessage without title field." | ||
622 | -} | ||
623 | |||
624 | #ifdef USE_lens | ||
625 | title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) | ||
626 | title = lens getTitle setTitle | ||
627 | #endif | ||
628 | |||
629 | class HasMessage x where | ||
630 | getMessage :: x -> Text | ||
631 | setMessage :: x -> Text -> x | ||
632 | |||
633 | splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString) | ||
634 | splitByteAt n bs = (fixed,w8,bs') | ||
635 | where | ||
636 | (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs | ||
637 | |||
638 | {- | ||
639 | instance HasMessage CryptoMessage where | ||
640 | getMessage (UpToN xE bs) | ||
641 | | MESSAGE <- xE = T.decodeUtf8 bs | ||
642 | | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs | ||
643 | getMessage _ = error "getMessage on CryptoMessage without message field." | ||
644 | |||
645 | setMessage (UpToN xE bs) message | ||
646 | | MESSAGE <- xE | ||
647 | = UpToN xE $ T.encodeUtf8 message | ||
648 | | isIndirectGrpChat xE | ||
649 | = let (pre8,nm0,xs) = splitByteAt 8 bs | ||
650 | nm = if nm0 == 0 then 0x40 else nm0 | ||
651 | prefix x = pre8 <> B.cons nm x | ||
652 | in UpToN xE $ prefix $ T.encodeUtf8 message | ||
653 | setMessage _ _ = error "setMessage on CryptoMessage without message field." | ||
654 | -} | ||
655 | |||
656 | #ifdef USE_lens | ||
657 | message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x) | ||
658 | message = lens getMessage setMessage | ||
659 | #endif | ||
660 | |||
661 | class HasName x where | ||
662 | getName :: x -> Text | ||
663 | setName :: x -> Text -> x | ||
664 | |||
665 | |||
666 | {- | ||
667 | instance HasName CryptoMessage where | ||
668 | -- Only MESSAGE_GROUPCHAT:NameChange has Name field | ||
669 | getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata | ||
670 | getName _ = error "getName on CryptoMessage without name field." | ||
671 | |||
672 | -- If its not NameChange, this setter will set it to NameChange | ||
673 | setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name | ||
674 | | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)]) | ||
675 | setName _ _ = error "setName on CryptoMessage without name field." | ||
676 | -} | ||
677 | |||
678 | #ifdef USE_lens | ||
679 | name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x) | ||
680 | name = lens getTitle setTitle | ||
681 | #endif | ||
682 | |||
683 | data PeerInfo | ||
684 | = PeerInfo | ||
685 | { piPeerNum :: PeerNumber | ||
686 | , piUserKey :: PublicKey | ||
687 | , piDHTKey :: PublicKey | ||
688 | , piName :: ByteString -- byte-prefix for length | ||
689 | } deriving (Eq,Show) | ||
690 | |||
691 | instance HasPeerNumber PeerInfo where | ||
692 | getPeerNumber = piPeerNum | ||
693 | setPeerNumber x n = x { piPeerNum = n } | ||
694 | |||
695 | instance Serialize PeerInfo where | ||
696 | get = do | ||
697 | w16 <- get | ||
698 | ukey <- getPublicKey | ||
699 | dkey <- getPublicKey | ||
700 | w8 <- get :: Get Word8 | ||
701 | PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8) | ||
702 | |||
703 | put (PeerInfo w16 ukey dkey bs) = do | ||
704 | put w16 | ||
705 | putPublicKey ukey | ||
706 | putPublicKey dkey | ||
707 | let sz :: Word8 | ||
708 | sz = case B.length bs of | ||
709 | n | n <= 255 -> fromIntegral n | ||
710 | | otherwise -> 255 | ||
711 | put sz | ||
712 | putByteString $ B.take (fromIntegral sz) bs | ||
713 | |||
714 | |||
715 | {- | ||
716 | -- | | ||
717 | -- default constructor, handy for formations such as: | ||
718 | -- | ||
719 | -- > userStatus .~ Busy $ msg USERSTATUS | ||
720 | -- | ||
721 | msg :: MessageID -> CryptoMessage | ||
722 | msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid | ||
723 | | Just (True,1) <- msgSizeParam mid = TwoByte mid 0 | ||
724 | | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty | ||
725 | | otherwise = UpToN mid B.empty | ||
726 | -} | ||
727 | |||
728 | {- | ||
729 | leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage | ||
730 | leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01) | ||
731 | peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08) | ||
732 | -} | ||
733 | |||
734 | {- | ||
735 | -- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as | ||
736 | -- the maximum allowed size for the message Payload (message minus id) | ||
737 | -- Or Nothing if unknown/unimplemented. | ||
738 | msgSizeParam :: MessageID -> Maybe (Bool,Int) | ||
739 | msgSizeParam ONLINE = Just (True ,0) | ||
740 | msgSizeParam OFFLINE = Just (True ,0) | ||
741 | msgSizeParam USERSTATUS = Just (True ,1) | ||
742 | msgSizeParam TYPING = Just (True ,1) | ||
743 | msgSizeParam NICKNAME = Just (False,128) | ||
744 | msgSizeParam STATUSMESSAGE = Just (False,1007) | ||
745 | msgSizeParam MESSAGE = Just (False,1372) | ||
746 | msgSizeParam ACTION = Just (False,1372) | ||
747 | msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373 | ||
748 | msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301 | ||
749 | msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4 | ||
750 | msgSizeParam INVITE_GROUPCHAT = Just (False,38) | ||
751 | msgSizeParam ONLINE_PACKET = Just (True ,35) | ||
752 | msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets | ||
753 | msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable | ||
754 | msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable | ||
755 | msgSizeParam _ = Nothing | ||
756 | -} | ||
757 | |||
758 | isIndirectGrpChat :: Msg n t -> Bool | ||
759 | isIndirectGrpChat MESSAGE_CONFERENCE = True | ||
760 | isIndirectGrpChat LOSSY_CONFERENCE = True | ||
761 | isIndirectGrpChat _ = False | ||
762 | |||
763 | isKillPacket :: SomeMsg -> Bool | ||
764 | isKillPacket (M KillPacket) = True | ||
765 | isKillPacket _ = False | ||
766 | |||
767 | isOFFLINE :: SomeMsg -> Bool | ||
768 | isOFFLINE (M OFFLINE) = True | ||
769 | isOFFLINE _ = False | ||
770 | |||
771 | |||
772 | data MessageName = Ping -- 0x00 | ||
773 | | MessageName0x01 | ||
774 | | MessageName0x02 | ||
775 | | MessageName0x03 | ||
776 | | MessageName0x04 | ||
777 | | MessageName0x05 | ||
778 | | MessageName0x06 | ||
779 | | MessageName0x07 | ||
780 | | MessageName0x08 | ||
781 | | MessageName0x09 | ||
782 | | MessageName0x0a | ||
783 | | MessageName0x0b | ||
784 | | MessageName0x0c | ||
785 | | MessageName0x0d | ||
786 | | MessageName0x0e | ||
787 | | MessageName0x0f | ||
788 | | NewPeer -- 0x10 | ||
789 | | KillPeer -- 0x11 | ||
790 | | MessageName0x12 | ||
791 | | MessageName0x13 | ||
792 | | MessageName0x14 | ||
793 | | MessageName0x15 | ||
794 | | MessageName0x16 | ||
795 | | MessageName0x17 | ||
796 | | MessageName0x18 | ||
797 | | MessageName0x19 | ||
798 | | MessageName0x1a | ||
799 | | MessageName0x1b | ||
800 | | MessageName0x1c | ||
801 | | MessageName0x1d | ||
802 | | MessageName0x1e | ||
803 | | MessageName0x1f | ||
804 | | MessageName0x20 | ||
805 | | MessageName0x21 | ||
806 | | MessageName0x22 | ||
807 | | MessageName0x23 | ||
808 | | MessageName0x24 | ||
809 | | MessageName0x25 | ||
810 | | MessageName0x26 | ||
811 | | MessageName0x27 | ||
812 | | MessageName0x28 | ||
813 | | MessageName0x29 | ||
814 | | MessageName0x2a | ||
815 | | MessageName0x2b | ||
816 | | MessageName0x2c | ||
817 | | MessageName0x2d | ||
818 | | MessageName0x2e | ||
819 | | MessageName0x2f | ||
820 | | NameChange -- 0x30 | ||
821 | | GroupchatTitleChange -- 0x31 | ||
822 | | MessageName0x32 | ||
823 | | MessageName0x33 | ||
824 | | MessageName0x34 | ||
825 | | MessageName0x35 | ||
826 | | MessageName0x36 | ||
827 | | MessageName0x37 | ||
828 | | MessageName0x38 | ||
829 | | MessageName0x39 | ||
830 | | MessageName0x3a | ||
831 | | MessageName0x3b | ||
832 | | MessageName0x3c | ||
833 | | MessageName0x3d | ||
834 | | MessageName0x3e | ||
835 | | MessageName0x3f | ||
836 | | ChatMessage -- 0x40 | ||
837 | | Action -- 0x41 | ||
838 | | MessageName0x42 | ||
839 | | MessageName0x43 | ||
840 | | MessageName0x44 | ||
841 | | MessageName0x45 | ||
842 | | MessageName0x46 | ||
843 | | MessageName0x47 | ||
844 | | MessageName0x48 | ||
845 | | MessageName0x49 | ||
846 | | MessageName0x4a | ||
847 | | MessageName0x4b | ||
848 | | MessageName0x4c | ||
849 | | MessageName0x4d | ||
850 | | MessageName0x4e | ||
851 | | MessageName0x4f | ||
852 | | MessageName0x50 | ||
853 | | MessageName0x51 | ||
854 | | MessageName0x52 | ||
855 | | MessageName0x53 | ||
856 | | MessageName0x54 | ||
857 | | MessageName0x55 | ||
858 | | MessageName0x56 | ||
859 | | MessageName0x57 | ||
860 | | MessageName0x58 | ||
861 | | MessageName0x59 | ||
862 | | MessageName0x5a | ||
863 | | MessageName0x5b | ||
864 | | MessageName0x5c | ||
865 | | MessageName0x5d | ||
866 | | MessageName0x5e | ||
867 | | MessageName0x5f | ||
868 | | MessageName0x60 | ||
869 | | MessageName0x61 | ||
870 | | MessageName0x62 | ||
871 | | MessageName0x63 | ||
872 | | MessageName0x64 | ||
873 | | MessageName0x65 | ||
874 | | MessageName0x66 | ||
875 | | MessageName0x67 | ||
876 | | MessageName0x68 | ||
877 | | MessageName0x69 | ||
878 | | MessageName0x6a | ||
879 | | MessageName0x6b | ||
880 | | MessageName0x6c | ||
881 | | MessageName0x6d | ||
882 | | MessageName0x6e | ||
883 | | MessageName0x6f | ||
884 | | MessageName0x70 | ||
885 | | MessageName0x71 | ||
886 | | MessageName0x72 | ||
887 | | MessageName0x73 | ||
888 | | MessageName0x74 | ||
889 | | MessageName0x75 | ||
890 | | MessageName0x76 | ||
891 | | MessageName0x77 | ||
892 | | MessageName0x78 | ||
893 | | MessageName0x79 | ||
894 | | MessageName0x7a | ||
895 | | MessageName0x7b | ||
896 | | MessageName0x7c | ||
897 | | MessageName0x7d | ||
898 | | MessageName0x7e | ||
899 | | MessageName0x7f | ||
900 | | MessageName0x80 | ||
901 | | MessageName0x81 | ||
902 | | MessageName0x82 | ||
903 | | MessageName0x83 | ||
904 | | MessageName0x84 | ||
905 | | MessageName0x85 | ||
906 | | MessageName0x86 | ||
907 | | MessageName0x87 | ||
908 | | MessageName0x88 | ||
909 | | MessageName0x89 | ||
910 | | MessageName0x8a | ||
911 | | MessageName0x8b | ||
912 | | MessageName0x8c | ||
913 | | MessageName0x8d | ||
914 | | MessageName0x8e | ||
915 | | MessageName0x8f | ||
916 | | MessageName0x90 | ||
917 | | MessageName0x91 | ||
918 | | MessageName0x92 | ||
919 | | MessageName0x93 | ||
920 | | MessageName0x94 | ||
921 | | MessageName0x95 | ||
922 | | MessageName0x96 | ||
923 | | MessageName0x97 | ||
924 | | MessageName0x98 | ||
925 | | MessageName0x99 | ||
926 | | MessageName0x9a | ||
927 | | MessageName0x9b | ||
928 | | MessageName0x9c | ||
929 | | MessageName0x9d | ||
930 | | MessageName0x9e | ||
931 | | MessageName0x9f | ||
932 | | MessageName0xa0 | ||
933 | | MessageName0xa1 | ||
934 | | MessageName0xa2 | ||
935 | | MessageName0xa3 | ||
936 | | MessageName0xa4 | ||
937 | | MessageName0xa5 | ||
938 | | MessageName0xa6 | ||
939 | | MessageName0xa7 | ||
940 | | MessageName0xa8 | ||
941 | | MessageName0xa9 | ||
942 | | MessageName0xaa | ||
943 | | MessageName0xab | ||
944 | | MessageName0xac | ||
945 | | MessageName0xad | ||
946 | | MessageName0xae | ||
947 | | MessageName0xaf | ||
948 | | MessageName0xb0 | ||
949 | | MessageName0xb1 | ||
950 | | MessageName0xb2 | ||
951 | | MessageName0xb3 | ||
952 | | MessageName0xb4 | ||
953 | | MessageName0xb5 | ||
954 | | MessageName0xb6 | ||
955 | | MessageName0xb7 | ||
956 | | MessageName0xb8 | ||
957 | | MessageName0xb9 | ||
958 | | MessageName0xba | ||
959 | | MessageName0xbb | ||
960 | | MessageName0xbc | ||
961 | | MessageName0xbd | ||
962 | | MessageName0xbe | ||
963 | | MessageName0xbf | ||
964 | | MessageName0xc0 | ||
965 | | MessageName0xc1 | ||
966 | | MessageName0xc2 | ||
967 | | MessageName0xc3 | ||
968 | | MessageName0xc4 | ||
969 | | MessageName0xc5 | ||
970 | | MessageName0xc6 | ||
971 | | MessageName0xc7 | ||
972 | | MessageName0xc8 | ||
973 | | MessageName0xc9 | ||
974 | | MessageName0xca | ||
975 | | MessageName0xcb | ||
976 | | MessageName0xcc | ||
977 | | MessageName0xcd | ||
978 | | MessageName0xce | ||
979 | | MessageName0xcf | ||
980 | | MessageName0xd0 | ||
981 | | MessageName0xd1 | ||
982 | | MessageName0xd2 | ||
983 | | MessageName0xd3 | ||
984 | | MessageName0xd4 | ||
985 | | MessageName0xd5 | ||
986 | | MessageName0xd6 | ||
987 | | MessageName0xd7 | ||
988 | | MessageName0xd8 | ||
989 | | MessageName0xd9 | ||
990 | | MessageName0xda | ||
991 | | MessageName0xdb | ||
992 | | MessageName0xdc | ||
993 | | MessageName0xdd | ||
994 | | MessageName0xde | ||
995 | | MessageName0xdf | ||
996 | | MessageName0xe0 | ||
997 | | MessageName0xe1 | ||
998 | | MessageName0xe2 | ||
999 | | MessageName0xe3 | ||
1000 | | MessageName0xe4 | ||
1001 | | MessageName0xe5 | ||
1002 | | MessageName0xe6 | ||
1003 | | MessageName0xe7 | ||
1004 | | MessageName0xe8 | ||
1005 | | MessageName0xe9 | ||
1006 | | MessageName0xea | ||
1007 | | MessageName0xeb | ||
1008 | | MessageName0xec | ||
1009 | | MessageName0xed | ||
1010 | | MessageName0xee | ||
1011 | | MessageName0xef | ||
1012 | | MessageName0xf0 | ||
1013 | | MessageName0xf1 | ||
1014 | | MessageName0xf2 | ||
1015 | | MessageName0xf3 | ||
1016 | | MessageName0xf4 | ||
1017 | | MessageName0xf5 | ||
1018 | | MessageName0xf6 | ||
1019 | | MessageName0xf7 | ||
1020 | | MessageName0xf8 | ||
1021 | | MessageName0xf9 | ||
1022 | | MessageName0xfa | ||
1023 | | MessageName0xfb | ||
1024 | | MessageName0xfc | ||
1025 | | MessageName0xfd | ||
1026 | | MessageName0xfe | ||
1027 | | MessageName0xff | ||
1028 | deriving (Show,Eq,Ord,Enum,Bounded) | ||
1029 | |||
diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs new file mode 100644 index 00000000..1eec93b9 --- /dev/null +++ b/dht/src/Network/Tox/DHT/Handlers.hs | |||
@@ -0,0 +1,573 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
3 | {-# LANGUAGE NamedFieldPuns #-} | ||
4 | {-# LANGUAGE PatternSynonyms #-} | ||
5 | {-# LANGUAGE TupleSections #-} | ||
6 | module Network.Tox.DHT.Handlers where | ||
7 | |||
8 | import Debug.Trace | ||
9 | import Network.Tox.DHT.Transport as DHTTransport | ||
10 | import Network.QueryResponse as QR hiding (Client) | ||
11 | import qualified Network.QueryResponse as QR (Client) | ||
12 | import Crypto.Tox | ||
13 | import Network.Kademlia.Search | ||
14 | import qualified Data.Wrapper.PSQInt as Int | ||
15 | import Network.Kademlia | ||
16 | import Network.Kademlia.Bootstrap | ||
17 | import Network.Address (WantIP (..), ipFamily, fromSockAddr, sockAddrPort) | ||
18 | import qualified Network.Kademlia.Routing as R | ||
19 | import Control.TriadCommittee | ||
20 | import System.Global6 | ||
21 | import DPut | ||
22 | import DebugTag | ||
23 | |||
24 | import qualified Data.ByteArray as BA | ||
25 | import qualified Data.ByteString.Char8 as C8 | ||
26 | import qualified Data.ByteString.Base16 as Base16 | ||
27 | import Control.Arrow | ||
28 | import Control.Monad | ||
29 | import Control.Concurrent.Lifted.Instrument | ||
30 | import Control.Concurrent.STM | ||
31 | import Data.Hashable | ||
32 | import Data.Ord | ||
33 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) | ||
34 | import Network.Socket | ||
35 | import qualified Data.HashMap.Strict as HashMap | ||
36 | ;import Data.HashMap.Strict (HashMap) | ||
37 | #if MIN_VERSION_iproute(1,7,4) | ||
38 | import Data.IP hiding (fromSockAddr) | ||
39 | #else | ||
40 | import Data.IP | ||
41 | #endif | ||
42 | import Data.Maybe | ||
43 | import Data.Serialize (Serialize) | ||
44 | import Data.Word | ||
45 | |||
46 | data TransactionId = TransactionId | ||
47 | { transactionKey :: Nonce8 -- ^ Used to lookup pending query. | ||
48 | , cryptoNonce :: Nonce24 -- ^ Used during the encryption layer. | ||
49 | } | ||
50 | deriving (Eq,Ord,Show) | ||
51 | |||
52 | newtype PacketKind = PacketKind Word8 | ||
53 | deriving (Eq, Ord, Serialize) | ||
54 | |||
55 | pattern OnionRequest0Type = PacketKind 128 -- 0x80 Onion Request 0 | ||
56 | pattern OnionRequest1Type = PacketKind 129 -- 0x81 Onion Request 1 | ||
57 | pattern OnionRequest2Type = PacketKind 130 -- 0x82 Onion Request 2 | ||
58 | pattern AnnounceType = PacketKind 131 -- 0x83 Announce Request | ||
59 | pattern AnnounceResponseType = PacketKind 132 -- 0x84 Announce Response | ||
60 | |||
61 | pattern DataRequestType = PacketKind 133 -- 0x85 Onion Data Request (data to route request packet) | ||
62 | pattern DataResponseType = PacketKind 134 -- 0x86 Onion Data Response (data to route response packet) | ||
63 | -- 0x8c Onion Response 3 | ||
64 | -- 0x8d Onion Response 2 | ||
65 | pattern OnionResponse3Type = PacketKind 140 -- 0x8c Onion Response 3 | ||
66 | pattern OnionResponse2Type = PacketKind 141 -- 0x8d Onion Response 2 | ||
67 | pattern OnionResponse1Type = PacketKind 142 -- 0x8e Onion Response 1 | ||
68 | -- 0xf0 Bootstrap Info | ||
69 | |||
70 | pattern DHTRequestType = PacketKind 32 -- 0x20 DHT Request | ||
71 | |||
72 | pattern CookieRequestType = PacketKind 0x18 | ||
73 | pattern CookieResponseType = PacketKind 0x19 | ||
74 | |||
75 | pattern PingType = PacketKind 0 -- 0x00 Ping Request | ||
76 | pattern PongType = PacketKind 1 -- 0x01 Ping Response | ||
77 | pattern GetNodesType = PacketKind 2 -- 0x02 Nodes Request | ||
78 | pattern SendNodesType = PacketKind 4 -- 0x04 Nodes Response | ||
79 | |||
80 | |||
81 | instance Show PacketKind where | ||
82 | showsPrec d PingType = mappend "PingType" | ||
83 | showsPrec d PongType = mappend "PongType" | ||
84 | showsPrec d GetNodesType = mappend "GetNodesType" | ||
85 | showsPrec d SendNodesType = mappend "SendNodesType" | ||
86 | showsPrec d DHTRequestType = mappend "DHTRequestType" | ||
87 | showsPrec d OnionRequest0Type = mappend "OnionRequest0Type" | ||
88 | showsPrec d OnionResponse1Type = mappend "OnionResponse1Type" | ||
89 | showsPrec d OnionResponse3Type = mappend "OnionResponse3Type" | ||
90 | showsPrec d AnnounceType = mappend "AnnounceType" | ||
91 | showsPrec d AnnounceResponseType = mappend "AnnounceResponseType" | ||
92 | showsPrec d DataRequestType = mappend "DataRequestType" | ||
93 | showsPrec d DataResponseType = mappend "DataResponseType" | ||
94 | showsPrec d CookieRequestType = mappend "CookieRequestType" | ||
95 | showsPrec d CookieResponseType = mappend "CookieResponseType" | ||
96 | showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x | ||
97 | |||
98 | msgType :: ( Serialize (f DHTRequest) | ||
99 | , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest) | ||
100 | , Serialize (f SendNodes), Serialize (f GetNodes) | ||
101 | , Serialize (f Pong), Serialize (f Ping) | ||
102 | ) => DHTMessage f -> PacketKind | ||
103 | msgType msg = PacketKind $ fst $ dhtMessageType msg | ||
104 | |||
105 | classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message | ||
106 | classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client) | ||
107 | classify client msg = fromMaybe (IsUnknown "unknown") | ||
108 | $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg | ||
109 | where | ||
110 | go (DHTPing {}) = IsQuery PingType | ||
111 | go (DHTGetNodes {}) = IsQuery GetNodesType | ||
112 | go (DHTPong {}) = IsResponse | ||
113 | go (DHTSendNodes {}) = IsResponse | ||
114 | go (DHTCookieRequest {}) = IsQuery CookieRequestType | ||
115 | go (DHTCookie {}) = IsResponse | ||
116 | go (DHTDHTRequest {}) = IsQuery DHTRequestType | ||
117 | |||
118 | data NodeInfoCallback = NodeInfoCallback | ||
119 | { interestingNodeId :: NodeId | ||
120 | , listenerId :: Int | ||
121 | , observedAddress :: POSIXTime -> NodeInfo -- Address and port for interestingNodeId | ||
122 | -> STM () | ||
123 | , rumoredAddress :: POSIXTime -> SockAddr -- source of information | ||
124 | -> NodeInfo -- Address and port for interestingNodeId | ||
125 | -> STM () | ||
126 | } | ||
127 | |||
128 | data Routing = Routing | ||
129 | { tentativeId :: NodeInfo | ||
130 | , committee4 :: TriadCommittee NodeId SockAddr | ||
131 | , committee6 :: TriadCommittee NodeId SockAddr | ||
132 | , refresher4 :: BucketRefresher NodeId NodeInfo | ||
133 | , refresher6 :: BucketRefresher NodeId NodeInfo | ||
134 | , nodesOfInterest :: TVar (HashMap NodeId [NodeInfoCallback]) | ||
135 | } | ||
136 | |||
137 | registerNodeCallback :: Routing -> NodeInfoCallback -> STM () | ||
138 | registerNodeCallback Routing{nodesOfInterest} cb = do | ||
139 | cbm <- readTVar nodesOfInterest | ||
140 | let ns = fromMaybe [] $ HashMap.lookup (interestingNodeId cb) cbm | ||
141 | bs = filter nonMatching ns | ||
142 | where nonMatching n = (listenerId n /= listenerId cb) | ||
143 | writeTVar nodesOfInterest $ HashMap.insert (interestingNodeId cb) | ||
144 | (cb : bs) | ||
145 | cbm | ||
146 | |||
147 | unregisterNodeCallback :: Int -> Routing -> NodeId -> STM () | ||
148 | unregisterNodeCallback callbackId Routing{nodesOfInterest} nid = do | ||
149 | cbm <- readTVar nodesOfInterest | ||
150 | let ns = fromMaybe [] $ HashMap.lookup nid cbm | ||
151 | bs = filter nonMatching ns | ||
152 | where nonMatching n = (listenerId n /= callbackId) | ||
153 | writeTVar nodesOfInterest | ||
154 | $ if null bs | ||
155 | then HashMap.delete nid cbm | ||
156 | else HashMap.insert nid bs cbm | ||
157 | |||
158 | |||
159 | sched4 :: Routing -> TVar (Int.PSQ POSIXTime) | ||
160 | sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue | ||
161 | |||
162 | sched6 :: Routing -> TVar (Int.PSQ POSIXTime) | ||
163 | sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue | ||
164 | |||
165 | routing4 :: Routing -> TVar (R.BucketList NodeInfo) | ||
166 | routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets | ||
167 | |||
168 | routing6 :: Routing -> TVar (R.BucketList NodeInfo) | ||
169 | routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets | ||
170 | |||
171 | newRouting :: SockAddr -> TransportCrypto | ||
172 | -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv4 change | ||
173 | -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv6 change | ||
174 | -> IO (Client -> Routing) | ||
175 | newRouting addr crypto update4 update6 = do | ||
176 | let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr) | ||
177 | tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr) | ||
178 | tentative_info = NodeInfo | ||
179 | { nodeId = key2id $ transportPublic crypto | ||
180 | , nodeIP = fromMaybe (toEnum 0) (fromSockAddr addr) | ||
181 | , nodePort = fromMaybe 0 $ sockAddrPort addr | ||
182 | } | ||
183 | tentative_info4 = tentative_info { nodeIP = tentative_ip4 } | ||
184 | tentative_info6 <- | ||
185 | maybe (tentative_info { nodeIP = tentative_ip6 }) | ||
186 | (\ip6 -> tentative_info { nodeIP = IPv6 ip6 }) | ||
187 | <$> case addr of | ||
188 | SockAddrInet {} -> return Nothing | ||
189 | _ -> global6 | ||
190 | atomically $ do | ||
191 | -- We defer initializing the refreshSearch and refreshPing until we | ||
192 | -- have a client to send queries with. | ||
193 | let nullPing = const $ return False | ||
194 | nullSearch = Search | ||
195 | { searchSpace = toxSpace | ||
196 | , searchNodeAddress = nodeIP &&& nodePort | ||
197 | , searchQuery = Left $ \_ _ -> return Nothing | ||
198 | , searchAlpha = 1 | ||
199 | , searchK = 2 | ||
200 | } | ||
201 | tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 R.defaultBucketCount | ||
202 | tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount | ||
203 | refresher4 <- newBucketRefresher tbl4 nullSearch nullPing | ||
204 | refresher6 <- newBucketRefresher tbl6 nullSearch nullPing | ||
205 | committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4 | ||
206 | committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6 | ||
207 | cbvar <- newTVar HashMap.empty | ||
208 | return $ \client -> | ||
209 | -- Now we have a client, so tell the BucketRefresher how to search and ping. | ||
210 | let updIO r = updateRefresherIO (nodeSearch client cbvar) (ping client) r | ||
211 | in Routing { tentativeId = tentative_info | ||
212 | , committee4 = committee4 | ||
213 | , committee6 = committee6 | ||
214 | , refresher4 = updIO refresher4 | ||
215 | , refresher6 = updIO refresher6 | ||
216 | , nodesOfInterest = cbvar | ||
217 | } | ||
218 | |||
219 | |||
220 | -- TODO: This should cover more cases | ||
221 | isLocal :: IP -> Bool | ||
222 | isLocal (IPv6 ip6) = (ip6 == toEnum 0) | ||
223 | isLocal (IPv4 ip4) = (ip4 == toEnum 0) | ||
224 | |||
225 | isGlobal :: IP -> Bool | ||
226 | isGlobal = not . isLocal | ||
227 | |||
228 | prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP | ||
229 | prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp | ||
230 | |||
231 | toxSpace :: R.KademliaSpace NodeId NodeInfo | ||
232 | toxSpace = R.KademliaSpace | ||
233 | { R.kademliaLocation = nodeId | ||
234 | , R.kademliaTestBit = testNodeIdBit | ||
235 | , R.kademliaXor = xorNodeId | ||
236 | , R.kademliaSample = sampleNodeId | ||
237 | } | ||
238 | |||
239 | |||
240 | pingH :: NodeInfo -> Ping -> IO Pong | ||
241 | pingH _ Ping = return Pong | ||
242 | |||
243 | getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes | ||
244 | getNodesH routing addr (GetNodes nid) = do | ||
245 | let preferred = prefer4or6 addr Nothing | ||
246 | |||
247 | (append4,append6) <- atomically $ do | ||
248 | ni4 <- R.thisNode <$> readTVar (routing4 routing) | ||
249 | ni6 <- R.thisNode <$> readTVar (routing6 routing) | ||
250 | return $ case ipFamily (nodeIP addr) of | ||
251 | Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6])) | ||
252 | Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id) | ||
253 | _ -> (id, id) | ||
254 | ks <- go append4 $ routing4 routing | ||
255 | ks6 <- go append6 $ routing6 routing | ||
256 | let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks) | ||
257 | Want_IP4 -> (ks,ks6) | ||
258 | Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__ | ||
259 | return $ SendNodes | ||
260 | $ if null ns2 then ns1 | ||
261 | else take 4 (take 3 ns1 ++ ns2) | ||
262 | where | ||
263 | go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var) | ||
264 | |||
265 | k = 4 | ||
266 | |||
267 | createCookie :: TransportCrypto -> NodeInfo -> PublicKey -> IO (Cookie Encrypted) | ||
268 | createCookie crypto ni remoteUserKey = do | ||
269 | (n24,sym) <- atomically $ do | ||
270 | n24 <- transportNewNonce crypto | ||
271 | sym <- transportSymmetric crypto | ||
272 | return (n24,sym) | ||
273 | timestamp <- round . (* 1000000) <$> getPOSIXTime | ||
274 | let dta = encodePlain $ CookieData | ||
275 | { cookieTime = timestamp | ||
276 | , longTermKey = remoteUserKey | ||
277 | , dhtKey = id2key $ nodeId ni -- transportPublic crypto | ||
278 | } | ||
279 | edta = encryptSymmetric sym n24 dta | ||
280 | return $ Cookie n24 edta | ||
281 | |||
282 | createCookieSTM :: POSIXTime -> TransportCrypto -> NodeInfo -> PublicKey -> STM (Cookie Encrypted) | ||
283 | createCookieSTM now crypto ni remoteUserKey = do | ||
284 | let dmsg msg = trace msg (return ()) | ||
285 | (n24,sym) <- do | ||
286 | n24 <- transportNewNonce crypto | ||
287 | sym <- transportSymmetric crypto | ||
288 | return (n24,sym) | ||
289 | let timestamp = round (now * 1000000) | ||
290 | let dta = encodePlain $ CookieData | ||
291 | { cookieTime = timestamp | ||
292 | , longTermKey = remoteUserKey | ||
293 | , dhtKey = id2key $ nodeId ni -- transportPublic crypto | ||
294 | } | ||
295 | edta = encryptSymmetric sym n24 dta | ||
296 | return $ Cookie n24 edta | ||
297 | |||
298 | cookieRequestH :: TransportCrypto -> NodeInfo -> CookieRequest -> IO (Cookie Encrypted) | ||
299 | cookieRequestH crypto ni (CookieRequest remoteUserKey) = do | ||
300 | dput XNetCrypto $ unlines | ||
301 | [ show (nodeAddr ni) ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey) | ||
302 | , show (nodeAddr ni) ++ " --> sender=" ++ show (nodeId ni) ] | ||
303 | x <- createCookie crypto ni remoteUserKey | ||
304 | dput XNetCrypto $ show (nodeAddr ni) ++ " <-- cookie " ++ show (key2id remoteUserKey) | ||
305 | return x | ||
306 | |||
307 | lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message)) | ||
308 | lanDiscoveryH client _ ni = do | ||
309 | dput XLan $ show (nodeAddr ni) ++ " --> LanAnnounce " ++ show (nodeId ni) | ||
310 | forkIO $ do | ||
311 | myThreadId >>= flip labelThread "lan-discover-ping" | ||
312 | ping client ni | ||
313 | return () | ||
314 | return Nothing | ||
315 | |||
316 | type Message = DHTMessage ((,) Nonce8) | ||
317 | |||
318 | type Client = QR.Client String PacketKind TransactionId NodeInfo Message | ||
319 | |||
320 | |||
321 | wrapAsymm :: TransactionId -> NodeInfo -> NodeInfo -> (Nonce8 -> dta) -> Asymm dta | ||
322 | wrapAsymm (TransactionId n8 n24) src dst dta = Asymm | ||
323 | { senderKey = id2key $ nodeId src | ||
324 | , asymmNonce = n24 | ||
325 | , asymmData = dta n8 | ||
326 | } | ||
327 | |||
328 | serializer :: PacketKind | ||
329 | -> (Asymm (Nonce8,ping) -> Message) | ||
330 | -> (Message -> Maybe (Asymm (Nonce8,pong))) | ||
331 | -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong) | ||
332 | serializer pktkind mkping mkpong = MethodSerializer | ||
333 | { methodTimeout = \tid addr -> return (addr, 5000000) | ||
334 | , method = pktkind | ||
335 | -- wrapQuery :: tid -> addr -> addr -> qry -> x | ||
336 | , wrapQuery = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping) | ||
337 | -- unwrapResponse :: x -> b | ||
338 | , unwrapResponse = fmap (snd . asymmData) . mkpong | ||
339 | } | ||
340 | |||
341 | |||
342 | unpong :: Message -> Maybe (Asymm (Nonce8,Pong)) | ||
343 | unpong (DHTPong asymm) = Just asymm | ||
344 | unpong _ = Nothing | ||
345 | |||
346 | ping :: Client -> NodeInfo -> IO Bool | ||
347 | ping client addr = do | ||
348 | dput XPing $ show addr ++ " <-- ping" | ||
349 | reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr | ||
350 | dput XPing $ show addr ++ " -pong-> " ++ show reply | ||
351 | maybe (return False) (\Pong -> return True) $ join reply | ||
352 | |||
353 | |||
354 | saveCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM () | ||
355 | saveCookieKey var saddr pk = do | ||
356 | cookiekeys <- readTVar var | ||
357 | case break (\(stored,_) -> stored == saddr) cookiekeys of | ||
358 | (xs,[]) -> writeTVar var $ (saddr, (1 ,pk)) : xs | ||
359 | (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c+1,pk)) : xs ++ ys | ||
360 | _ -> retry -- Wait for requests to this address | ||
361 | -- under a different key to time out | ||
362 | -- before we try this key. | ||
363 | |||
364 | loseCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM () | ||
365 | loseCookieKey var saddr pk = do | ||
366 | cookiekeys <- readTVar var | ||
367 | case break (\(stored,_) -> stored == saddr) cookiekeys of | ||
368 | (xs,(_,(1,stored)):ys) | stored == pk -> writeTVar var $ xs ++ ys | ||
369 | (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c-1,pk)) : xs ++ ys | ||
370 | _ -> return () -- unreachable? | ||
371 | |||
372 | |||
373 | cookieRequest :: TransportCrypto -> Client -> PublicKey -> NodeInfo -> IO (Maybe (Cookie Encrypted)) | ||
374 | cookieRequest crypto client localUserKey addr = do | ||
375 | let sockAddr = nodeAddr addr | ||
376 | nid = id2key $ nodeId addr | ||
377 | cookieSerializer | ||
378 | = MethodSerializer | ||
379 | { methodTimeout = \tid addr -> return (addr, 5000000) | ||
380 | , method = CookieRequestType | ||
381 | , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr) | ||
382 | , unwrapResponse = fmap snd . unCookie | ||
383 | } | ||
384 | cookieRequest = CookieRequest localUserKey | ||
385 | atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid | ||
386 | dput XNetCrypto $ show addr ++ " <-- cookieRequest" | ||
387 | reply <- QR.sendQuery client cookieSerializer cookieRequest addr | ||
388 | atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid | ||
389 | dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply | ||
390 | return $ join reply | ||
391 | |||
392 | unCookie :: DHTMessage t -> Maybe (t (Cookie Encrypted)) | ||
393 | unCookie (DHTCookie n24 fcookie) = Just fcookie | ||
394 | unCookie _ = Nothing | ||
395 | |||
396 | unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes)) | ||
397 | unsendNodes (DHTSendNodes asymm) = Just asymm | ||
398 | unsendNodes _ = Nothing | ||
399 | |||
400 | unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () ) | ||
401 | unwrapNodes (SendNodes ns) = (ns,ns,Just ()) | ||
402 | |||
403 | data SendableQuery x a b = SendableQuery | ||
404 | { sendableSerializer :: MethodSerializer TransactionId NodeInfo Message PacketKind a (Maybe x) | ||
405 | , sendableQuery :: NodeId -> a | ||
406 | , sendableResult :: Maybe (Maybe x) -> IO b | ||
407 | } | ||
408 | |||
409 | sendQ :: SendableQuery x a b | ||
410 | -> QR.Client err PacketKind TransactionId NodeInfo Message | ||
411 | -> NodeId | ||
412 | -> NodeInfo | ||
413 | -> IO b | ||
414 | sendQ s client nid addr = do | ||
415 | reply <- QR.sendQuery client (sendableSerializer s) (sendableQuery s nid) addr | ||
416 | sendableResult s reply | ||
417 | |||
418 | asyncQ :: SendableQuery x a b | ||
419 | -> QR.Client err PacketKind TransactionId NodeInfo Message | ||
420 | -> NodeId | ||
421 | -> NodeInfo | ||
422 | -> (b -> IO ()) | ||
423 | -> IO () | ||
424 | asyncQ s client nid addr go = do | ||
425 | QR.asyncQuery client (sendableSerializer s) (sendableQuery s nid) addr | ||
426 | $ sendableResult s >=> go | ||
427 | |||
428 | getNodesSendable :: TVar (HashMap NodeId [NodeInfoCallback]) | ||
429 | -> NodeInfo | ||
430 | -> SendableQuery SendNodes GetNodes (Maybe ([NodeInfo], [NodeInfo], Maybe ())) | ||
431 | getNodesSendable cbvar addr = SendableQuery (serializer GetNodesType DHTGetNodes unsendNodes) | ||
432 | GetNodes | ||
433 | go | ||
434 | where | ||
435 | go reply = do | ||
436 | forM_ (join reply) $ \(SendNodes ns) -> | ||
437 | forM_ ns $ \n -> do | ||
438 | now <- getPOSIXTime | ||
439 | atomically $ do | ||
440 | mcbs <- HashMap.lookup (nodeId n) <$> readTVar cbvar | ||
441 | forM_ mcbs $ \cbs -> do | ||
442 | forM_ cbs $ \cb -> do | ||
443 | rumoredAddress cb now (nodeAddr addr) n | ||
444 | return $ fmap unwrapNodes $ join reply | ||
445 | |||
446 | getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | ||
447 | getNodes client cbvar nid addr = | ||
448 | sendQ (getNodesSendable cbvar addr) client nid addr | ||
449 | |||
450 | asyncGetNodes :: QR.Client err PacketKind TransactionId NodeInfo Message | ||
451 | -> TVar (HashMap NodeId [NodeInfoCallback]) | ||
452 | -> NodeId | ||
453 | -> NodeInfo | ||
454 | -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ()) | ||
455 | -> IO () | ||
456 | asyncGetNodes client cbvar nid addr go = | ||
457 | asyncQ (getNodesSendable cbvar addr) client nid addr go | ||
458 | |||
459 | updateRouting :: Client -> Routing | ||
460 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | ||
461 | -> NodeInfo | ||
462 | -> Message | ||
463 | -> IO () | ||
464 | updateRouting client routing orouter naddr msg | ||
465 | | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery | ||
466 | -- Ignore lan announcements until they reply to our ping. | ||
467 | -- We do this because the lan announce is not authenticated. | ||
468 | return () | ||
469 | | otherwise = do | ||
470 | now <- getPOSIXTime | ||
471 | atomically $ do | ||
472 | m <- HashMap.lookup (nodeId naddr) <$> readTVar (nodesOfInterest routing) | ||
473 | forM_ m $ mapM_ $ \NodeInfoCallback{interestingNodeId,observedAddress} -> do | ||
474 | when (interestingNodeId == nodeId naddr) | ||
475 | $ observedAddress now naddr | ||
476 | case prefer4or6 naddr Nothing of | ||
477 | Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing) | ||
478 | Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing) | ||
479 | Want_Both -> do dput XMisc "BUG:unreachable" | ||
480 | error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__ | ||
481 | |||
482 | updateTable :: Client -> NodeInfo | ||
483 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | ||
484 | -> TriadCommittee NodeId SockAddr | ||
485 | -> BucketRefresher NodeId NodeInfo | ||
486 | -> IO () | ||
487 | updateTable client naddr orouter committee refresher = do | ||
488 | self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher) | ||
489 | -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr) | ||
490 | when (self /= naddr) $ do | ||
491 | -- TODO: IP address vote? | ||
492 | insertNode (toxKademlia client committee orouter refresher) naddr | ||
493 | |||
494 | toxKademlia :: Client | ||
495 | -> TriadCommittee NodeId SockAddr | ||
496 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | ||
497 | -> BucketRefresher NodeId NodeInfo | ||
498 | -> Kademlia NodeId NodeInfo | ||
499 | toxKademlia client committee orouter refresher | ||
500 | = Kademlia quietInsertions | ||
501 | toxSpace | ||
502 | (vanillaIO (refreshBuckets refresher) $ ping client) | ||
503 | { tblTransition = \tr -> do | ||
504 | io1 <- transitionCommittee committee tr | ||
505 | io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr | ||
506 | -- hookBucketList toxSpace (refreshBuckets refresher) orouter tr | ||
507 | orouter (refreshBuckets refresher) tr | ||
508 | return $ do | ||
509 | io1 >> io2 | ||
510 | {- | ||
511 | dput XMisc $ unwords | ||
512 | [ show (transitionedTo tr) | ||
513 | , show (transitioningNode tr) | ||
514 | ] | ||
515 | -} | ||
516 | return () | ||
517 | } | ||
518 | |||
519 | transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ()) | ||
520 | transitionCommittee committee (RoutingTransition ni Stranger) = do | ||
521 | delVote committee (nodeId ni) | ||
522 | return $ do | ||
523 | -- dput XMisc $ "delVote "++show (nodeId ni) | ||
524 | return () | ||
525 | transitionCommittee committee _ = return $ return () | ||
526 | |||
527 | type Handler = MethodHandler String TransactionId NodeInfo Message | ||
528 | |||
529 | isPing :: (f Ping -> Ping) -> DHTMessage f -> Either String Ping | ||
530 | isPing unpack (DHTPing a) = Right $ unpack $ asymmData a | ||
531 | isPing _ _ = Left "Bad ping" | ||
532 | |||
533 | mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8) | ||
534 | mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong) | ||
535 | |||
536 | isGetNodes :: (f GetNodes -> GetNodes) -> DHTMessage f -> Either String GetNodes | ||
537 | isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a | ||
538 | isGetNodes _ _ = Left "Bad GetNodes" | ||
539 | |||
540 | mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8) | ||
541 | mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes) | ||
542 | |||
543 | isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest | ||
544 | isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a | ||
545 | isCookieRequest _ _ = Left "Bad cookie request" | ||
546 | |||
547 | mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie Encrypted -> DHTMessage ((,) Nonce8) | ||
548 | mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie) | ||
549 | |||
550 | isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest | ||
551 | isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a | ||
552 | isDHTRequest _ _ = Left "Bad dht relay request" | ||
553 | |||
554 | dhtRequestH :: NodeInfo -> DHTRequest -> IO () | ||
555 | dhtRequestH ni req = do | ||
556 | dput XMisc $ "Unhandled DHT Request: " ++ show req | ||
557 | |||
558 | handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler | ||
559 | handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH | ||
560 | handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing | ||
561 | handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto | ||
562 | handlers _ _ DHTRequestType = Just $ NoReply (isDHTRequest snd) $ dhtRequestH | ||
563 | handlers _ _ typ = error $ "TODO DHT handlers " ++ show typ | ||
564 | |||
565 | nodeSearch :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo | ||
566 | nodeSearch client cbvar = Search | ||
567 | { searchSpace = toxSpace | ||
568 | , searchNodeAddress = nodeIP &&& nodePort | ||
569 | , searchQuery = Right $ asyncGetNodes client cbvar | ||
570 | , searchAlpha = 8 | ||
571 | , searchK = 16 | ||
572 | |||
573 | } | ||
diff --git a/dht/src/Network/Tox/DHT/Transport.hs b/dht/src/Network/Tox/DHT/Transport.hs new file mode 100644 index 00000000..b9b63165 --- /dev/null +++ b/dht/src/Network/Tox/DHT/Transport.hs | |||
@@ -0,0 +1,460 @@ | |||
1 | {-# LANGUAGE DeriveGeneric #-} | ||
2 | {-# LANGUAGE FlexibleContexts #-} | ||
3 | {-# LANGUAGE FlexibleInstances #-} | ||
4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
5 | {-# LANGUAGE KindSignatures #-} | ||
6 | {-# LANGUAGE LambdaCase #-} | ||
7 | {-# LANGUAGE RankNTypes #-} | ||
8 | {-# LANGUAGE StandaloneDeriving #-} | ||
9 | {-# LANGUAGE TupleSections #-} | ||
10 | {-# LANGUAGE TypeOperators #-} | ||
11 | {-# LANGUAGE UndecidableInstances #-} | ||
12 | module Network.Tox.DHT.Transport | ||
13 | ( parseDHTAddr | ||
14 | , encodeDHTAddr | ||
15 | , forwardDHTRequests | ||
16 | , module Network.Tox.NodeId | ||
17 | , DHTMessage(..) | ||
18 | , Ping(..) | ||
19 | , Pong(..) | ||
20 | , GetNodes(..) | ||
21 | , SendNodes(..) | ||
22 | , DHTPublicKey(..) | ||
23 | , FriendRequest(..) | ||
24 | , NoSpam(..) | ||
25 | , CookieRequest(..) | ||
26 | , CookieResponse(..) | ||
27 | , Cookie(..) | ||
28 | , CookieData(..) | ||
29 | , DHTRequest | ||
30 | , mapMessage | ||
31 | , encrypt | ||
32 | , decrypt | ||
33 | , dhtMessageType | ||
34 | , asymNodeInfo | ||
35 | , putMessage -- Convenient for serializing DHTLanDiscovery | ||
36 | ) where | ||
37 | |||
38 | import Network.Tox.NodeId | ||
39 | import Crypto.Tox hiding (encrypt,decrypt) | ||
40 | import qualified Crypto.Tox as ToxCrypto | ||
41 | import Network.QueryResponse | ||
42 | |||
43 | import Control.Applicative | ||
44 | import Control.Arrow | ||
45 | import Control.Concurrent.STM | ||
46 | import Control.Monad | ||
47 | import Data.Bool | ||
48 | import qualified Data.ByteString as B | ||
49 | ;import Data.ByteString (ByteString) | ||
50 | import Data.Functor.Contravariant | ||
51 | import Data.Hashable | ||
52 | import Data.Maybe | ||
53 | import Data.Monoid | ||
54 | import Data.Serialize as S | ||
55 | import Data.Tuple | ||
56 | import Data.Word | ||
57 | import GHC.Generics | ||
58 | import Network.Socket | ||
59 | |||
60 | type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8) | ||
61 | type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a | ||
62 | |||
63 | |||
64 | data DHTMessage (f :: * -> *) | ||
65 | = DHTPing (Asymm (f Ping)) | ||
66 | | DHTPong (Asymm (f Pong)) | ||
67 | | DHTGetNodes (Asymm (f GetNodes)) | ||
68 | | DHTSendNodes (Asymm (f SendNodes)) | ||
69 | | DHTCookieRequest (Asymm (f CookieRequest)) | ||
70 | | DHTCookie Nonce24 (f (Cookie Encrypted)) | ||
71 | | DHTDHTRequest PublicKey (Asymm (f DHTRequest)) | ||
72 | | DHTLanDiscovery NodeId | ||
73 | |||
74 | deriving instance ( Show (f (Cookie Encrypted)) | ||
75 | , Show (f Ping) | ||
76 | , Show (f Pong) | ||
77 | , Show (f GetNodes) | ||
78 | , Show (f SendNodes) | ||
79 | , Show (f CookieRequest) | ||
80 | , Show (f DHTRequest) | ||
81 | ) => Show (DHTMessage f) | ||
82 | |||
83 | mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> Maybe b | ||
84 | mapMessage f (DHTPing a) = Just $ f (asymmNonce a) (asymmData a) | ||
85 | mapMessage f (DHTPong a) = Just $ f (asymmNonce a) (asymmData a) | ||
86 | mapMessage f (DHTGetNodes a) = Just $ f (asymmNonce a) (asymmData a) | ||
87 | mapMessage f (DHTSendNodes a) = Just $ f (asymmNonce a) (asymmData a) | ||
88 | mapMessage f (DHTCookieRequest a) = Just $ f (asymmNonce a) (asymmData a) | ||
89 | mapMessage f (DHTDHTRequest _ a) = Just $ f (asymmNonce a) (asymmData a) | ||
90 | mapMessage f (DHTCookie nonce fcookie) = Just $ f nonce fcookie | ||
91 | mapMessage f (DHTLanDiscovery nid) = Nothing | ||
92 | |||
93 | |||
94 | instance Sized Ping where size = ConstSize 1 | ||
95 | instance Sized Pong where size = ConstSize 1 | ||
96 | |||
97 | parseDHTAddr :: TransportCrypto -> (ByteString, SockAddr) -> IO (Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr)) | ||
98 | parseDHTAddr crypto (msg,saddr) | ||
99 | | Just (typ,bs) <- B.uncons msg | ||
100 | , let right = return $ Right (msg,saddr) | ||
101 | left = either (const right) (return . Left) | ||
102 | = case typ of | ||
103 | 0x00 -> left $ direct bs saddr DHTPing | ||
104 | 0x01 -> left $ direct bs saddr DHTPong | ||
105 | 0x02 -> left $ direct bs saddr DHTGetNodes | ||
106 | 0x04 -> left $ direct bs saddr DHTSendNodes | ||
107 | 0x18 -> left $ direct bs saddr DHTCookieRequest | ||
108 | 0x19 -> do | ||
109 | cs <- atomically $ readTVar (pendingCookies crypto) | ||
110 | let ni = fromMaybe (noReplyAddr saddr) $ do | ||
111 | (cnt,key) <- lookup saddr cs <|> listToMaybe (map snd cs) | ||
112 | either (const Nothing) Just $ nodeInfo (key2id key) saddr | ||
113 | left $ fanGet bs getCookie (uncurry DHTCookie) (const $ ni) | ||
114 | 0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd) | ||
115 | 0x21 -> left $ do | ||
116 | nid <- runGet get bs | ||
117 | ni <- nodeInfo nid saddr | ||
118 | return (DHTLanDiscovery nid, ni) | ||
119 | _ -> right | ||
120 | |||
121 | encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> IO (ByteString, SockAddr) | ||
122 | encodeDHTAddr (msg,ni) = return (runPut $ putMessage msg, nodeAddr ni) | ||
123 | |||
124 | dhtMessageType :: ( Serialize (f DHTRequest) | ||
125 | , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest) | ||
126 | , Serialize (f SendNodes), Serialize (f GetNodes) | ||
127 | , Serialize (f Pong), Serialize (f Ping) | ||
128 | ) => DHTMessage f -> (Word8, Put) | ||
129 | dhtMessageType (DHTPing a) = (0x00, putAsymm a) | ||
130 | dhtMessageType (DHTPong a) = (0x01, putAsymm a) | ||
131 | dhtMessageType (DHTGetNodes a) = (0x02, putAsymm a) | ||
132 | dhtMessageType (DHTSendNodes a) = (0x04, putAsymm a) | ||
133 | dhtMessageType (DHTCookieRequest a) = (0x18, putAsymm a) | ||
134 | dhtMessageType (DHTCookie n x) = (0x19, put n >> put x) | ||
135 | dhtMessageType (DHTDHTRequest k a) = (0x20, putPublicKey k >> putAsymm a) | ||
136 | dhtMessageType (DHTLanDiscovery nid) = (0x21, put nid) | ||
137 | |||
138 | putMessage :: DHTMessage Encrypted8 -> Put | ||
139 | putMessage msg = case dhtMessageType msg of (typ,p) -> put typ >> p | ||
140 | |||
141 | getCookie :: Get (Nonce24, Encrypted8 (Cookie Encrypted)) | ||
142 | getCookie = get | ||
143 | |||
144 | getDHTReqest :: Get (PublicKey, Asymm (Encrypted8 DHTRequest)) | ||
145 | getDHTReqest = (,) <$> getPublicKey <*> getAsymm | ||
146 | |||
147 | -- ## DHT Request packets | ||
148 | -- | ||
149 | -- | Length | Contents | | ||
150 | -- |:-------|:--------------------------| | ||
151 | -- | `1` | `uint8_t` (0x20) | | ||
152 | -- | `32` | receiver's DHT public key | | ||
153 | -- ... ... | ||
154 | |||
155 | |||
156 | getDHT :: Sized a => Get (Asymm (Encrypted8 a)) | ||
157 | getDHT = getAsymm | ||
158 | |||
159 | |||
160 | -- Throws an error if called with a non-internet socket. | ||
161 | direct :: Sized a => ByteString | ||
162 | -> SockAddr | ||
163 | -> (Asymm (Encrypted8 a) -> DHTMessage Encrypted8) | ||
164 | -> Either String (DHTMessage Encrypted8, NodeInfo) | ||
165 | direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr) | ||
166 | |||
167 | -- Throws an error if called with a non-internet socket. | ||
168 | asymNodeInfo :: SockAddr -> Asymm a -> NodeInfo | ||
169 | asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (key2id $ senderKey asym) saddr | ||
170 | |||
171 | |||
172 | fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b) | ||
173 | fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs | ||
174 | |||
175 | -- Throws an error if called with a non-internet socket. | ||
176 | noReplyAddr :: SockAddr -> NodeInfo | ||
177 | noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr | ||
178 | |||
179 | |||
180 | data DHTRequest | ||
181 | -- #### NAT ping request | ||
182 | -- | ||
183 | -- Length Contents | ||
184 | -- :------- :------------------------- | ||
185 | -- `1` `uint8_t` (0xfe) | ||
186 | -- `1` `uint8_t` (0x00) | ||
187 | -- `8` `uint64_t` random number | ||
188 | = NATPing Nonce8 | ||
189 | -- #### NAT ping response | ||
190 | -- | ||
191 | -- Length Contents | ||
192 | -- :------- :----------------------------------------------------------------- | ||
193 | -- `1` `uint8_t` (0xfe) | ||
194 | -- `1` `uint8_t` (0x01) | ||
195 | -- `8` `uint64_t` random number (the same that was received in request) | ||
196 | | NATPong Nonce8 | ||
197 | | DHTPK LongTermKeyWrap | ||
198 | -- From docs/Hardening_docs.txt | ||
199 | -- | ||
200 | -- All hardening requests must contain exactly 384 bytes of data. (The data sent | ||
201 | -- must be padded with zeros if it is smaller than that.) | ||
202 | -- | ||
203 | -- [byte with value: 02 (get nodes test request)][struct Node_format (the node to | ||
204 | -- test.)][client_id(32 bytes) the id to query the node with.][padding] | ||
205 | -- | ||
206 | -- packet id: CRYPTO_PACKET_HARDENING (48) | ||
207 | | Hardening -- TODO | ||
208 | deriving Show | ||
209 | |||
210 | instance Sized DHTRequest where | ||
211 | size = VarSize $ \case | ||
212 | NATPing _ -> 10 | ||
213 | NATPong _ -> 10 | ||
214 | DHTPK wrap -> 1{-typ-} + 32{-key-} + 24{-nonce-} | ||
215 | + case size of | ||
216 | ConstSize n -> n | ||
217 | VarSize f -> f (wrapData wrap) | ||
218 | Hardening -> 1{-typ-} + 384 | ||
219 | |||
220 | instance Serialize DHTRequest where | ||
221 | get = do | ||
222 | tag <- get | ||
223 | case tag :: Word8 of | ||
224 | 0xfe -> do | ||
225 | direction <- get | ||
226 | bool NATPong NATPing (direction==(0::Word8)) <$> get | ||
227 | 0x9c -> DHTPK <$> get | ||
228 | 0x30 -> pure Hardening -- TODO: CRYPTO_PACKET_HARDENING | ||
229 | _ -> fail ("unrecognized DHT request: "++show tag) | ||
230 | put (NATPing n) = put (0xfe00 :: Word16) >> put n | ||
231 | put (NATPong n) = put (0xfe01 :: Word16) >> put n | ||
232 | put (DHTPK pk) = put (0x9c :: Word8) >> put pk | ||
233 | put (Hardening) = put (0x30 :: Word8) >> putByteString (B.replicate 384 0) -- TODO | ||
234 | |||
235 | -- DHT public key packet: | ||
236 | -- (As Onion data packet?) | ||
237 | -- | ||
238 | -- | Length | Contents | | ||
239 | -- |:------------|:------------------------------------| | ||
240 | -- | `1` | `uint8_t` (0x9c) | | ||
241 | -- | `8` | `uint64_t` `no_replay` | | ||
242 | -- | `32` | Our DHT public key | | ||
243 | -- | `[39, 204]` | Maximum of 4 nodes in packed format | | ||
244 | data DHTPublicKey = DHTPublicKey | ||
245 | { dhtpkNonce :: Word64 -- ^ The `no_replay` number is protection if | ||
246 | -- someone tries to replay an older packet and | ||
247 | -- should be set to an always increasing number. | ||
248 | -- It is 8 bytes so you should set a high | ||
249 | -- resolution monotonic time as the value. | ||
250 | , dhtpk :: PublicKey -- dht public key | ||
251 | , dhtpkNodes :: SendNodes -- other reachable nodes | ||
252 | } | ||
253 | deriving (Eq, Show) | ||
254 | |||
255 | |||
256 | -- int8_t (0x20 sent over onion, 0x12 for sent over net_crypto) | ||
257 | -- [uint32_t nospam][Message (UTF8) 1 to ONION_CLIENT_MAX_DATA_SIZE bytes] | ||
258 | data FriendRequest = FriendRequest | ||
259 | { friendNoSpam :: Word32 | ||
260 | , friendRequestText :: ByteString -- UTF8 | ||
261 | } | ||
262 | deriving (Eq, Ord, Show) | ||
263 | |||
264 | |||
265 | -- When sent as a DHT request packet (this is the data sent in the DHT request | ||
266 | -- packet): | ||
267 | -- | ||
268 | -- Length Contents | ||
269 | -- :--------- :------------------------------- | ||
270 | -- `1` `uint8_t` (0x9c) | ||
271 | -- `32` Long term public key of sender | ||
272 | -- `24` Nonce | ||
273 | -- variable Encrypted payload | ||
274 | data LongTermKeyWrap = LongTermKeyWrap | ||
275 | { wrapLongTermKey :: PublicKey | ||
276 | , wrapNonce :: Nonce24 | ||
277 | , wrapData :: Encrypted DHTPublicKey | ||
278 | } | ||
279 | deriving Show | ||
280 | |||
281 | instance Serialize LongTermKeyWrap where | ||
282 | get = LongTermKeyWrap <$> getPublicKey <*> get <*> get | ||
283 | put (LongTermKeyWrap key nonce dta) = putPublicKey key >> put nonce >> put dta | ||
284 | |||
285 | |||
286 | instance Sized DHTPublicKey where | ||
287 | -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size. | ||
288 | -- WARNING: Serialize instance does not include this byte FIXME | ||
289 | size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of | ||
290 | ConstSize nodes -> nodes | ||
291 | VarSize sznodes -> sznodes nodes | ||
292 | |||
293 | instance Sized Word32 where size = ConstSize 4 | ||
294 | |||
295 | -- FIXME: Inconsitently, this type does not include the 0x20 or 0x12 tag byte | ||
296 | -- where the DHTPublicKey type does include its tag. | ||
297 | instance Sized FriendRequest where | ||
298 | size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length) | ||
299 | |||
300 | instance Serialize DHTPublicKey where | ||
301 | -- TODO: This should agree with Sized instance. | ||
302 | get = DHTPublicKey <$> get <*> getPublicKey <*> get | ||
303 | put (DHTPublicKey nonce key nodes) = do | ||
304 | put nonce | ||
305 | putPublicKey key | ||
306 | put nodes | ||
307 | |||
308 | instance Serialize FriendRequest where | ||
309 | get = FriendRequest <$> get <*> (remaining >>= getBytes) | ||
310 | put (FriendRequest nospam txt) = put nospam >> putByteString txt | ||
311 | |||
312 | newtype GetNodes = GetNodes NodeId | ||
313 | deriving (Eq,Ord,Show,Read,S.Serialize) | ||
314 | |||
315 | instance Sized GetNodes where | ||
316 | size = ConstSize 32 -- TODO This right? | ||
317 | |||
318 | newtype SendNodes = SendNodes [NodeInfo] | ||
319 | deriving (Eq,Ord,Show,Read) | ||
320 | |||
321 | instance Sized SendNodes where | ||
322 | size = VarSize $ \(SendNodes ns) -> case size of | ||
323 | ConstSize nodeFormatSize -> nodeFormatSize * length ns | ||
324 | VarSize nsize -> sum $ map nsize ns | ||
325 | |||
326 | instance S.Serialize SendNodes where | ||
327 | get = do | ||
328 | cnt <- S.get :: S.Get Word8 | ||
329 | ns <- sequence $ replicate (fromIntegral cnt) S.get | ||
330 | return $ SendNodes ns | ||
331 | |||
332 | put (SendNodes ns) = do | ||
333 | let ns' = take 4 ns | ||
334 | S.put (fromIntegral (length ns') :: Word8) | ||
335 | mapM_ S.put ns' | ||
336 | |||
337 | data Ping = Ping deriving Show | ||
338 | data Pong = Pong deriving Show | ||
339 | |||
340 | instance S.Serialize Ping where | ||
341 | get = do w8 <- S.get | ||
342 | if (w8 :: Word8) /= 0 | ||
343 | then fail "Malformed ping." | ||
344 | else return Ping | ||
345 | put Ping = S.put (0 :: Word8) | ||
346 | |||
347 | instance S.Serialize Pong where | ||
348 | get = do w8 <- S.get | ||
349 | if (w8 :: Word8) /= 1 | ||
350 | then fail "Malformed pong." | ||
351 | else return Pong | ||
352 | put Pong = S.put (1 :: Word8) | ||
353 | |||
354 | newtype CookieRequest = CookieRequest PublicKey | ||
355 | deriving (Eq, Show) | ||
356 | newtype CookieResponse = CookieResponse (Cookie Encrypted) | ||
357 | deriving (Eq, Show) | ||
358 | |||
359 | data Cookie (f :: * -> *) = Cookie Nonce24 (f CookieData) | ||
360 | |||
361 | deriving instance Eq (f CookieData) => Eq (Cookie f) | ||
362 | deriving instance Ord (f CookieData) => Ord (Cookie f) | ||
363 | deriving instance Show (f CookieData) => Show (Cookie f) | ||
364 | deriving instance Generic (f CookieData) => Generic (Cookie f) | ||
365 | |||
366 | instance Hashable (Cookie Encrypted) | ||
367 | |||
368 | instance Sized (Cookie Encrypted) where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data | ||
369 | |||
370 | instance Serialize (Cookie Encrypted) where | ||
371 | get = Cookie <$> get <*> get | ||
372 | put (Cookie nonce dta) = put nonce >> put dta | ||
373 | |||
374 | data CookieData = CookieData -- 16 (mac) | ||
375 | { cookieTime :: Word64 -- 8 | ||
376 | , longTermKey :: PublicKey -- 32 | ||
377 | , dhtKey :: PublicKey -- + 32 | ||
378 | } -- = 88 bytes when encrypted. | ||
379 | deriving (Show, Generic) | ||
380 | |||
381 | instance Sized CookieData where | ||
382 | size = ConstSize 72 | ||
383 | |||
384 | instance Serialize CookieData where | ||
385 | get = CookieData <$> get <*> getPublicKey <*> getPublicKey | ||
386 | put (CookieData tm userkey dhtkey) = do | ||
387 | put tm | ||
388 | putPublicKey userkey | ||
389 | putPublicKey userkey | ||
390 | |||
391 | instance Sized CookieRequest where | ||
392 | size = ConstSize 64 -- 32 byte key + 32 byte padding | ||
393 | |||
394 | instance Serialize CookieRequest where | ||
395 | get = CookieRequest <$> getPublicKey <* {- padding -} getPublicKey | ||
396 | put (CookieRequest k) = putPublicKey k >> {- padding -} putPublicKey k | ||
397 | |||
398 | forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport | ||
399 | forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' } | ||
400 | where | ||
401 | await' :: HandleHi a -> IO a | ||
402 | await' pass = awaitMessage dht $ \case | ||
403 | Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto | ||
404 | -> do mni <- closeLookup target | ||
405 | -- Forward the message if the target is in our close list. | ||
406 | forM_ mni $ \ni -> sendMessage dht ni m | ||
407 | await' pass | ||
408 | m -> pass m | ||
409 | |||
410 | encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> IO (DHTMessage Encrypted8, NodeInfo) | ||
411 | encrypt crypto msg ni = do | ||
412 | let cipher n plain = Composed $ encryptMessage crypto (id2key $ nodeId ni) n plain | ||
413 | m <- sequenceMessage $ transcode cipher msg | ||
414 | return (m, ni) | ||
415 | |||
416 | encryptMessage :: Serialize a => | ||
417 | TransportCrypto -> | ||
418 | PublicKey -> | ||
419 | Nonce24 -> Either (Nonce8,a) (Asymm (Nonce8,a)) -> IO (Encrypted8 a) | ||
420 | encryptMessage crypto destKey n arg = do | ||
421 | let plain = encodePlain $ swap $ either id asymmData arg | ||
422 | secret <- lookupSharedSecret crypto (transportSecret crypto) destKey n | ||
423 | return $ E8 $ ToxCrypto.encrypt secret plain | ||
424 | |||
425 | decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> IO (Either String (DHTMessage ((,) Nonce8), NodeInfo)) | ||
426 | decrypt crypto msg ni = do | ||
427 | let decipher n c = Composed $ decryptMessage crypto n . left ((,) $ id2key $ nodeId ni) $ c | ||
428 | msg' <- sequenceMessage $ transcode decipher msg | ||
429 | return $ fmap (, ni) $ sequenceMessage msg' | ||
430 | |||
431 | decryptMessage :: Serialize x => | ||
432 | TransportCrypto | ||
433 | -> Nonce24 | ||
434 | -> Either (PublicKey, Encrypted8 x) (Asymm (Encrypted8 x)) | ||
435 | -> IO ((Either String ∘ ((,) Nonce8)) x) | ||
436 | decryptMessage crypto n arg = do | ||
437 | let (remotekey,E8 e) = either id (senderKey &&& asymmData) arg | ||
438 | plain8 = Composed . fmap swap . (>>= decodePlain) | ||
439 | secret <- lookupSharedSecret crypto (transportSecret crypto) remotekey n | ||
440 | return $ plain8 $ ToxCrypto.decrypt secret e | ||
441 | |||
442 | sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f) | ||
443 | sequenceMessage (DHTPing asym) = fmap DHTPing $ sequenceA $ fmap uncomposed asym | ||
444 | sequenceMessage (DHTPong asym) = fmap DHTPong $ sequenceA $ fmap uncomposed asym | ||
445 | sequenceMessage (DHTGetNodes asym) = fmap DHTGetNodes $ sequenceA $ fmap uncomposed asym | ||
446 | sequenceMessage (DHTSendNodes asym) = fmap DHTSendNodes $ sequenceA $ fmap uncomposed asym | ||
447 | sequenceMessage (DHTCookieRequest asym) = fmap DHTCookieRequest $ sequenceA $ fmap uncomposed asym | ||
448 | sequenceMessage (DHTCookie n dta) = fmap (DHTCookie n) $ uncomposed dta | ||
449 | sequenceMessage (DHTDHTRequest pubkey asym) = fmap (DHTDHTRequest pubkey) $ sequenceA $ fmap uncomposed asym | ||
450 | sequenceMessage (DHTLanDiscovery nid) = pure $ DHTLanDiscovery nid | ||
451 | |||
452 | transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> DHTMessage f -> DHTMessage g | ||
453 | transcode f (DHTPing asym) = DHTPing $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
454 | transcode f (DHTPong asym) = DHTPong $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
455 | transcode f (DHTGetNodes asym) = DHTGetNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
456 | transcode f (DHTSendNodes asym) = DHTSendNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
457 | transcode f (DHTCookieRequest asym) = DHTCookieRequest $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
458 | transcode f (DHTCookie n dta) = DHTCookie n $ f n $ Left dta | ||
459 | transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { asymmData = f (asymmNonce asym) (Right asym) } | ||
460 | transcode f (DHTLanDiscovery nid) = DHTLanDiscovery nid | ||
diff --git a/dht/src/Network/Tox/Handshake.hs b/dht/src/Network/Tox/Handshake.hs new file mode 100644 index 00000000..c48b7415 --- /dev/null +++ b/dht/src/Network/Tox/Handshake.hs | |||
@@ -0,0 +1,125 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE DeriveFunctor #-} | ||
3 | {-# LANGUAGE NamedFieldPuns #-} | ||
4 | {-# LANGUAGE PatternSynonyms #-} | ||
5 | {-# LANGUAGE TupleSections #-} | ||
6 | {-# LANGUAGE TypeOperators #-} | ||
7 | module Network.Tox.Handshake where | ||
8 | |||
9 | import Control.Arrow | ||
10 | import Control.Concurrent.STM | ||
11 | import Control.Monad | ||
12 | import Crypto.Hash | ||
13 | import Crypto.Tox | ||
14 | import Data.Functor.Identity | ||
15 | import Data.Time.Clock.POSIX | ||
16 | import Network.Tox.Crypto.Transport | ||
17 | import Network.Tox.DHT.Handlers (createCookieSTM) | ||
18 | import Network.Tox.DHT.Transport (Cookie (..), CookieData (..)) | ||
19 | import Network.Tox.NodeId | ||
20 | #ifdef THREAD_DEBUG | ||
21 | #else | ||
22 | import Control.Concurrent | ||
23 | import GHC.Conc (labelThread) | ||
24 | #endif | ||
25 | import DPut | ||
26 | import DebugTag | ||
27 | |||
28 | |||
29 | anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1) | ||
30 | anyRight e [] f = return $ Left e | ||
31 | anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right) | ||
32 | |||
33 | decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (SecretKey,Handshake Identity)) | ||
34 | decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do | ||
35 | (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto | ||
36 | <*> transportSymmetric crypto | ||
37 | let seckeys = map fst ukeys | ||
38 | now <- getPOSIXTime | ||
39 | -- dput XNetCrypto "decryptHandshake: trying the following keys:" | ||
40 | -- forM_ seckeys $ \k -> dput XNetCrypto $ " " ++ show (key2id . toPublic $ k) | ||
41 | fmap join . sequence $ do -- Either Monad | ||
42 | cd@(CookieData cookieTime remotePubkey remoteDhtkey) <- decodePlain =<< decryptSymmetric symkey n24 ecookie | ||
43 | Right $ do -- IO Monad | ||
44 | decrypted <- anyRight "missing key" seckeys $ \key -> do | ||
45 | -- dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey = " ++ show (key2id $ remotePubkey) | ||
46 | -- dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 = " ++ show nonce24 | ||
47 | secret <- lookupSharedSecret crypto key remotePubkey nonce24 | ||
48 | let step1 = decrypt secret encrypted | ||
49 | case step1 of | ||
50 | Left s -> do | ||
51 | -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s | ||
52 | return (Left s) | ||
53 | Right pln -> do | ||
54 | case decodePlain pln of | ||
55 | Left s -> do | ||
56 | -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s | ||
57 | return (Left s) | ||
58 | Right x -> return (Right (key,x)) | ||
59 | return $ do -- Either Monad | ||
60 | (key,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted | ||
61 | left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15) | ||
62 | let hinit = hashInit | ||
63 | hctx = hashUpdate hinit n24 | ||
64 | hctx' = hashUpdate hctx ecookie | ||
65 | digest = hashFinalize hctx' | ||
66 | left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest) | ||
67 | return ( key | ||
68 | , hshake { handshakeCookie = Cookie n24 (pure cd) | ||
69 | , handshakeData = pure hsdata | ||
70 | } ) | ||
71 | |||
72 | |||
73 | data HandshakeParams | ||
74 | = HParam | ||
75 | { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own | ||
76 | , hpOtherCookie :: Cookie Encrypted | ||
77 | , hpTheirSessionKeyPublic :: Maybe PublicKey | ||
78 | , hpMySecretKey :: SecretKey | ||
79 | , hpCookieRemotePubkey :: PublicKey | ||
80 | , hpCookieRemoteDhtkey :: PublicKey | ||
81 | } | ||
82 | |||
83 | newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData | ||
84 | newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do | ||
85 | let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp | ||
86 | hinit = hashInit | ||
87 | Cookie n24 encrypted = hpOtherCookie | ||
88 | hctx = hashUpdate hinit n24 | ||
89 | hctx' = hashUpdate hctx encrypted | ||
90 | digest = hashFinalize hctx' | ||
91 | freshCookie <- createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey | ||
92 | return HandshakeData | ||
93 | { baseNonce = basenonce | ||
94 | , sessionKey = mySessionPublic | ||
95 | , cookieHash = digest | ||
96 | , otherCookie = freshCookie | ||
97 | } | ||
98 | |||
99 | toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams | ||
100 | toHandshakeParams (key,hs) | ||
101 | = let hd = runIdentity $ handshakeData hs | ||
102 | Cookie _ cd0 = handshakeCookie hs | ||
103 | CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0 | ||
104 | in HParam { hpTheirBaseNonce = Just $ baseNonce hd | ||
105 | , hpOtherCookie = otherCookie hd | ||
106 | , hpTheirSessionKeyPublic = Just $ sessionKey hd | ||
107 | , hpMySecretKey = key | ||
108 | , hpCookieRemotePubkey = remotePublicKey | ||
109 | , hpCookieRemoteDhtkey = remoteDhtPublicKey | ||
110 | } | ||
111 | |||
112 | encodeHandshake :: POSIXTime | ||
113 | -> TransportCrypto | ||
114 | -> SecretKey | ||
115 | -> PublicKey | ||
116 | -> Cookie Encrypted | ||
117 | -> HandshakeData | ||
118 | -> STM (Handshake Encrypted) | ||
119 | encodeHandshake timestamp crypto me them otherCookie myhandshakeData = do | ||
120 | n24 <- transportNewNonce crypto | ||
121 | state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto me them | ||
122 | return Handshake { handshakeCookie = otherCookie | ||
123 | , handshakeNonce = n24 | ||
124 | , handshakeData = encrypt state $ encodePlain myhandshakeData | ||
125 | } | ||
diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs new file mode 100644 index 00000000..9a9c893a --- /dev/null +++ b/dht/src/Network/Tox/NodeId.hs | |||
@@ -0,0 +1,731 @@ | |||
1 | {- LANGUAGE ApplicativeDo -} | ||
2 | {-# LANGUAGE BangPatterns #-} | ||
3 | {-# LANGUAGE CPP #-} | ||
4 | {-# LANGUAGE DataKinds #-} | ||
5 | {-# LANGUAGE DeriveDataTypeable #-} | ||
6 | {-# LANGUAGE DeriveFunctor #-} | ||
7 | {-# LANGUAGE DeriveTraversable #-} | ||
8 | {-# LANGUAGE ExistentialQuantification #-} | ||
9 | {-# LANGUAGE FlexibleInstances #-} | ||
10 | {-# LANGUAGE GADTs #-} | ||
11 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
12 | {-# LANGUAGE KindSignatures #-} | ||
13 | {-# LANGUAGE LambdaCase #-} | ||
14 | {-# LANGUAGE PatternSynonyms #-} | ||
15 | {-# LANGUAGE ScopedTypeVariables #-} | ||
16 | {-# LANGUAGE StandaloneDeriving #-} | ||
17 | {-# LANGUAGE TupleSections #-} | ||
18 | {- LANGUAGE TypeApplications -} | ||
19 | module Network.Tox.NodeId | ||
20 | ( NodeInfo(..) | ||
21 | , NodeId | ||
22 | , nodeInfo | ||
23 | , nodeAddr | ||
24 | , zeroID | ||
25 | , key2id | ||
26 | , id2key | ||
27 | , getIP | ||
28 | , xorNodeId | ||
29 | , testNodeIdBit | ||
30 | , sampleNodeId | ||
31 | , NoSpam(..) | ||
32 | , NoSpamId(..) | ||
33 | , noSpamIdToHex | ||
34 | , parseNoSpamId | ||
35 | , nospam64 | ||
36 | , nospam16 | ||
37 | , verifyChecksum | ||
38 | , ToxContact(..) | ||
39 | , ToxProgress(..) | ||
40 | , parseToken32 | ||
41 | , showToken32 | ||
42 | ) where | ||
43 | |||
44 | import Control.Applicative | ||
45 | import Control.Arrow | ||
46 | import Control.Monad | ||
47 | #ifdef CRYPTONITE_BACKPORT | ||
48 | import Crypto.Error.Types (CryptoFailable (..), | ||
49 | throwCryptoError) | ||
50 | #else | ||
51 | import Crypto.Error | ||
52 | #endif | ||
53 | |||
54 | import Crypto.PubKey.Curve25519 | ||
55 | import qualified Data.Aeson as JSON | ||
56 | ;import Data.Aeson (FromJSON, ToJSON, (.=)) | ||
57 | import Data.Bits.ByteString () | ||
58 | import qualified Data.ByteArray as BA | ||
59 | ;import Data.ByteArray as BA (ByteArrayAccess) | ||
60 | import qualified Data.ByteString as B | ||
61 | ;import Data.ByteString (ByteString) | ||
62 | import qualified Data.ByteString.Base16 as Base16 | ||
63 | import qualified Data.ByteString.Base64 as Base64 | ||
64 | import qualified Data.ByteString.Char8 as C8 | ||
65 | import Data.Char | ||
66 | import Data.Data | ||
67 | import Data.Hashable | ||
68 | #if MIN_VERSION_iproute(1,7,4) | ||
69 | import Data.IP hiding (fromSockAddr) | ||
70 | #else | ||
71 | import Data.IP | ||
72 | #endif | ||
73 | import Data.List | ||
74 | import Data.Maybe | ||
75 | import Data.Serialize as S | ||
76 | import Data.Word | ||
77 | import Foreign.Storable | ||
78 | import GHC.TypeLits | ||
79 | import Network.Address hiding (nodePort) | ||
80 | import System.IO.Unsafe (unsafeDupablePerformIO) | ||
81 | import qualified Text.ParserCombinators.ReadP as RP | ||
82 | import Text.Read hiding (get) | ||
83 | import Data.Bits | ||
84 | import Crypto.Tox | ||
85 | import Foreign.Ptr | ||
86 | import Data.Function | ||
87 | import System.Endian | ||
88 | import qualified Data.Text as Text | ||
89 | ;import Data.Text (Text) | ||
90 | import Util (splitJID) | ||
91 | |||
92 | -- | perform io for hashes that do allocation and ffi. | ||
93 | -- unsafeDupablePerformIO is used when possible as the | ||
94 | -- computation is pure and the output is directly linked | ||
95 | -- to the input. we also do not modify anything after it has | ||
96 | -- been returned to the user. | ||
97 | unsafeDoIO :: IO a -> a | ||
98 | #if __GLASGOW_HASKELL__ > 704 | ||
99 | unsafeDoIO = unsafeDupablePerformIO | ||
100 | #else | ||
101 | unsafeDoIO = unsafePerformIO | ||
102 | #endif | ||
103 | |||
104 | unpackPublicKey :: ByteArrayAccess bs => bs -> [Word64] | ||
105 | unpackPublicKey bs = loop 0 | ||
106 | where loop i | ||
107 | | i == (BA.length bs `div` 8) = [] | ||
108 | | otherwise = | ||
109 | let !v = unsafeDoIO $ BA.withByteArray bs (\p -> fromBE64 <$> peekElemOff p i) | ||
110 | in v : loop (i+1) | ||
111 | |||
112 | packPublicKey :: BA.ByteArray bs => [Word64] -> bs | ||
113 | packPublicKey ws = BA.allocAndFreeze (8 * length ws) $ | ||
114 | flip fix ws $ \loop ys ptr -> case ys of | ||
115 | [] -> return () | ||
116 | x:xs -> do poke ptr (toBE64 x) | ||
117 | loop xs (plusPtr ptr 8) | ||
118 | {-# NOINLINE packPublicKey #-} | ||
119 | |||
120 | -- We represent the node id redundantly in two formats. The [Word64] format is | ||
121 | -- convenient for short-circuiting xor/distance comparisons. The PublicKey | ||
122 | -- format is convenient for encryption. | ||
123 | data NodeId = NodeId [Word64] !(Maybe PublicKey) | ||
124 | deriving Data | ||
125 | |||
126 | instance Data PublicKey where | ||
127 | -- Data a => (forall d b . Data d => c (d -> b) -> d -> c b) -> (forall g . g -> c g) -> a -> c a | ||
128 | gfoldl f z txt = z (throwCryptoError . publicKey) `f` (BA.convert txt :: ByteString) | ||
129 | toConstr _ = error "Crypto.PubKey.Curve25519.toConstr" | ||
130 | gunfold _ _ = error "Crypto.PubKey.Curve25519.gunfold" | ||
131 | #if MIN_VERSION_base(4,2,0) | ||
132 | dataTypeOf _ = mkNoRepType "Crypto.PubKey.Curve25519.PublicKey" | ||
133 | #else | ||
134 | dataTypeOf _ = mkNorepType "Crypto.PubKey.Curve25519.PublicKey" | ||
135 | #endif | ||
136 | |||
137 | |||
138 | instance Eq NodeId where | ||
139 | (NodeId ws _) == (NodeId xs _) | ||
140 | = ws == xs | ||
141 | |||
142 | instance Ord NodeId where | ||
143 | compare (NodeId ws _) (NodeId xs _) = compare ws xs | ||
144 | |||
145 | instance Sized NodeId where size = ConstSize 32 | ||
146 | |||
147 | key2id :: PublicKey -> NodeId | ||
148 | key2id k = NodeId (unpackPublicKey k) (Just k) | ||
149 | |||
150 | bs2id :: ByteString -> NodeId | ||
151 | bs2id bs = uncurry NodeId . (unpackPublicKey &&& Just) $ throwCryptoError . publicKey $ bs | ||
152 | |||
153 | id2key :: NodeId -> PublicKey | ||
154 | id2key (NodeId ws (Just key)) = key | ||
155 | id2key (NodeId key Nothing) = throwCryptoError . publicKey $ (packPublicKey key :: BA.Bytes) | ||
156 | |||
157 | zeroKey :: PublicKey | ||
158 | zeroKey = throwCryptoError $ publicKey $ B.replicate 32 0 | ||
159 | |||
160 | zeroID :: NodeId | ||
161 | zeroID = NodeId (replicate 4 0) (Just zeroKey) | ||
162 | |||
163 | -- | Convert to and from a Base64 variant that uses .- instead of +/. | ||
164 | nmtoken64 :: Bool -> Char -> Char | ||
165 | nmtoken64 False '.' = '+' | ||
166 | nmtoken64 False '-' = '/' | ||
167 | nmtoken64 True '+' = '.' | ||
168 | nmtoken64 True '/' = '-' | ||
169 | nmtoken64 _ c = c | ||
170 | |||
171 | -- | Parse 43-digit base64 token into 32-byte bytestring. | ||
172 | parseToken32 :: String -> Either String ByteString | ||
173 | parseToken32 str = fmap (BA.drop 1) $ Base64.decode $ C8.pack $ 'A':map (nmtoken64 False) (take 43 str) | ||
174 | |||
175 | -- | Encode 32-byte bytestring as 43-digit base64 token. | ||
176 | showToken32 :: ByteArrayAccess bin => bin -> String | ||
177 | showToken32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs | ||
178 | |||
179 | instance Read NodeId where | ||
180 | readsPrec _ str | ||
181 | | (bs,_) <- Base16.decode (C8.pack $ take 64 str) | ||
182 | , CryptoPassed pub <- publicKey bs -- B.length bs == 32 | ||
183 | = [ (key2id pub, drop (2 * B.length bs) str) ] | ||
184 | | Right bs <- parseToken32 str | ||
185 | , CryptoPassed pub <- publicKey bs -- B.length bs == 32 | ||
186 | = [ (key2id pub, drop 43 str) ] | ||
187 | | otherwise = [] | ||
188 | |||
189 | instance Show NodeId where | ||
190 | show nid = showToken32 $ id2key nid | ||
191 | |||
192 | instance S.Serialize NodeId where | ||
193 | get = key2id <$> getPublicKey | ||
194 | put nid = putPublicKey $ id2key nid | ||
195 | |||
196 | instance Hashable NodeId where | ||
197 | hashWithSalt salt (NodeId ws _) = hashWithSalt salt (head ws) | ||
198 | |||
199 | testNodeIdBit :: NodeId -> Word -> Bool | ||
200 | testNodeIdBit (NodeId ws _) i -- TODO: Optmize: use ByteArray key if it's available. | ||
201 | | fromIntegral i < 256 -- 256 bits | ||
202 | , (q, r) <- quotRem (fromIntegral i) 64 | ||
203 | = testBit (ws !! q) (63 - r) | ||
204 | | otherwise = False | ||
205 | |||
206 | xorNodeId :: NodeId -> NodeId -> NodeId | ||
207 | xorNodeId (NodeId xs _) (NodeId ys _) = NodeId (zipWith xor xs ys) Nothing | ||
208 | |||
209 | sampleNodeId :: Applicative m => (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId | ||
210 | sampleNodeId gen (NodeId self k) (q,m,b) | ||
211 | | q <= 0 = bs2id <$> gen 32 | ||
212 | | q >= 32 = pure (NodeId self k) | ||
213 | | let (qw,r) = (q+7) `divMod` 8 -- How many Word64 to prepend? | ||
214 | bw = shiftL (fromIntegral b) (8*(7-r)) | ||
215 | mw = bw - 1 :: Word64 | ||
216 | (hd, t0 : _) = splitAt (qw-1) self | ||
217 | h = xor bw (complement mw .&. t0) | ||
218 | = flip fmap (gen $ 8 * (4 - (qw-1)) ) $ \bs -> | ||
219 | let (w:ws) = unpackPublicKey bs | ||
220 | in NodeId (hd ++ (h .|. (w .&. mw)) : ws) Nothing | ||
221 | |||
222 | data NodeInfo = NodeInfo | ||
223 | { nodeId :: NodeId | ||
224 | , nodeIP :: IP | ||
225 | , nodePort :: PortNumber | ||
226 | } | ||
227 | deriving (Eq,Ord) | ||
228 | |||
229 | nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo | ||
230 | nodeInfo nid saddr | ||
231 | | Just ip <- fromSockAddr saddr | ||
232 | , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port | ||
233 | | otherwise = Left "Address family not supported." | ||
234 | |||
235 | |||
236 | instance ToJSON NodeInfo where | ||
237 | toJSON (NodeInfo nid (IPv4 ip) port) | ||
238 | = JSON.object [ "public_key" .= show nid | ||
239 | , "ipv4" .= show ip | ||
240 | , "port" .= (fromIntegral port :: Int) | ||
241 | ] | ||
242 | toJSON (NodeInfo nid (IPv6 ip6) port) | ||
243 | | Just ip <- un4map ip6 | ||
244 | = JSON.object [ "public_key" .= show nid | ||
245 | , "ipv4" .= show ip | ||
246 | , "port" .= (fromIntegral port :: Int) | ||
247 | ] | ||
248 | | otherwise | ||
249 | = JSON.object [ "public_key" .= show nid | ||
250 | , "ipv6" .= show ip6 | ||
251 | , "port" .= (fromIntegral port :: Int) | ||
252 | ] | ||
253 | instance FromJSON NodeInfo where | ||
254 | parseJSON (JSON.Object v) = do | ||
255 | nidstr <- v JSON..: "public_key" | ||
256 | ip6str <- v JSON..:? "ipv6" | ||
257 | ip4str <- v JSON..:? "ipv4" | ||
258 | portnum <- v JSON..: "port" | ||
259 | ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) | ||
260 | <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) | ||
261 | let (bs,_) = Base16.decode (C8.pack nidstr) | ||
262 | enid = Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr) | ||
263 | idbs <- (guard (B.length bs == 32) >> return bs) | ||
264 | <|> either fail (return . B.drop 1) enid | ||
265 | return $ NodeInfo (bs2id idbs) ip (fromIntegral (portnum :: Word16)) | ||
266 | |||
267 | getIP :: Word8 -> S.Get IP | ||
268 | getIP 0x02 = IPv4 <$> S.get | ||
269 | getIP 0x0a = IPv6 <$> S.get | ||
270 | getIP 0x82 = IPv4 <$> S.get -- TODO: TCP | ||
271 | getIP 0x8a = IPv6 <$> S.get -- TODO: TCP | ||
272 | getIP x = fail ("unsupported address family ("++show x++")") | ||
273 | |||
274 | instance Sized NodeInfo where | ||
275 | size = VarSize $ \(NodeInfo nid ip port) -> | ||
276 | case ip of | ||
277 | IPv4 _ -> 39 -- 35 + 4 = 1 + 4 + 2 + 32 | ||
278 | IPv6 _ -> 51 -- 35 + 16 = 1 + 16 + 2 + 32 | ||
279 | |||
280 | instance S.Serialize NodeInfo where | ||
281 | get = do | ||
282 | addrfam <- S.get :: S.Get Word8 | ||
283 | let fallback = do -- FIXME: Handle unrecognized address families. | ||
284 | IPv6 <$> S.get | ||
285 | return $ IPv6 (read "::" :: IPv6) | ||
286 | ip <- getIP addrfam <|> fallback | ||
287 | port <- S.get :: S.Get PortNumber | ||
288 | nid <- S.get | ||
289 | return $ NodeInfo nid ip port | ||
290 | |||
291 | put (NodeInfo nid ip port) = do | ||
292 | case ip of | ||
293 | IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 | ||
294 | IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 | ||
295 | S.put port | ||
296 | S.put nid | ||
297 | |||
298 | hexdigit :: Char -> Bool | ||
299 | hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') | ||
300 | |||
301 | b64digit :: Char -> Bool | ||
302 | b64digit '.' = True | ||
303 | b64digit '+' = True | ||
304 | b64digit '-' = True | ||
305 | b64digit '/' = True | ||
306 | b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z') | ||
307 | |||
308 | ip_w_port :: Int -> RP.ReadP (IP, PortNumber) | ||
309 | ip_w_port i = do | ||
310 | ip <- RP.between (RP.char '[') (RP.char ']') | ||
311 | (IPv6 <$> RP.readS_to_P (readsPrec i)) | ||
312 | RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) | ||
313 | _ <- RP.char ':' | ||
314 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
315 | return (ip, port) | ||
316 | |||
317 | |||
318 | instance Read NodeInfo where | ||
319 | readsPrec i = RP.readP_to_S $ do | ||
320 | RP.skipSpaces | ||
321 | let n = 43 -- characters in node id. | ||
322 | parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) | ||
323 | RP.+++ RP.munch (\c -> not (isSpace c) && not (c `elem` ("{}()"::[Char]))) | ||
324 | nodeidAt = do (is64,hexhash) <- | ||
325 | fmap (True,) (sequence $ replicate n (RP.satisfy b64digit)) | ||
326 | RP.+++ fmap (False,) (sequence $ replicate 64 (RP.satisfy isHexDigit)) | ||
327 | RP.char '@' RP.+++ RP.satisfy isSpace | ||
328 | addrstr <- parseAddr | ||
329 | nid <- if is64 | ||
330 | then case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of | ||
331 | Right bs | B.length bs - 1==32 -> return (bs2id $ BA.drop 1 bs) | ||
332 | _ -> fail "Bad node id." | ||
333 | else case Base16.decode $ C8.pack hexhash of | ||
334 | (bs,rem) | B.length bs == 32 && B.null rem -> return (bs2id bs) | ||
335 | _ -> fail "Bad node id." | ||
336 | return (nid,addrstr) | ||
337 | (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) | ||
338 | (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of | ||
339 | [] -> fail "Bad address." | ||
340 | ((ip,port),_):_ -> return (ip,port) | ||
341 | return $ NodeInfo nid ip port | ||
342 | |||
343 | -- The Hashable instance depends only on the IP address and port number. | ||
344 | -- | ||
345 | -- TODO: Why is the node id excluded? | ||
346 | instance Hashable NodeInfo where | ||
347 | hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) | ||
348 | {-# INLINE hashWithSalt #-} | ||
349 | |||
350 | |||
351 | instance Show NodeInfo where | ||
352 | showsPrec _ (NodeInfo nid ip port) = | ||
353 | shows nid . ('@' :) . showsip . (':' :) . shows port | ||
354 | where | ||
355 | showsip | ||
356 | | IPv4 ip4 <- ip = shows ip4 | ||
357 | | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 | ||
358 | | otherwise = ('[' :) . shows ip . (']' :) | ||
359 | |||
360 | |||
361 | |||
362 | |||
363 | {- | ||
364 | type NodeId = PubKey | ||
365 | |||
366 | pattern NodeId bs = PubKey bs | ||
367 | |||
368 | -- TODO: This should probably be represented by Curve25519.PublicKey, but | ||
369 | -- ByteString has more instances... | ||
370 | newtype PubKey = PubKey ByteString | ||
371 | deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable) | ||
372 | |||
373 | instance Serialize PubKey where | ||
374 | get = PubKey <$> getBytes 32 | ||
375 | put (PubKey bs) = putByteString bs | ||
376 | |||
377 | instance Show PubKey where | ||
378 | show (PubKey bs) = C8.unpack $ Base16.encode bs | ||
379 | |||
380 | instance FiniteBits PubKey where | ||
381 | finiteBitSize _ = 256 | ||
382 | |||
383 | instance Read PubKey where | ||
384 | readsPrec _ str | ||
385 | | (bs, xs) <- Base16.decode $ C8.pack str | ||
386 | , B.length bs == 32 | ||
387 | = [ (PubKey bs, drop 64 str) ] | ||
388 | | otherwise = [] | ||
389 | |||
390 | |||
391 | |||
392 | |||
393 | data NodeInfo = NodeInfo | ||
394 | { nodeId :: NodeId | ||
395 | , nodeIP :: IP | ||
396 | , nodePort :: PortNumber | ||
397 | } | ||
398 | deriving (Eq,Ord,Data) | ||
399 | |||
400 | instance Data PortNumber where | ||
401 | dataTypeOf _ = mkNoRepType "PortNumber" | ||
402 | toConstr _ = error "PortNumber.toConstr" | ||
403 | gunfold _ _ = error "PortNumber.gunfold" | ||
404 | |||
405 | instance ToJSON NodeInfo where | ||
406 | toJSON (NodeInfo nid (IPv4 ip) port) | ||
407 | = JSON.object [ "public_key" .= show nid | ||
408 | , "ipv4" .= show ip | ||
409 | , "port" .= (fromIntegral port :: Int) | ||
410 | ] | ||
411 | toJSON (NodeInfo nid (IPv6 ip6) port) | ||
412 | | Just ip <- un4map ip6 | ||
413 | = JSON.object [ "public_key" .= show nid | ||
414 | , "ipv4" .= show ip | ||
415 | , "port" .= (fromIntegral port :: Int) | ||
416 | ] | ||
417 | | otherwise | ||
418 | = JSON.object [ "public_key" .= show nid | ||
419 | , "ipv6" .= show ip6 | ||
420 | , "port" .= (fromIntegral port :: Int) | ||
421 | ] | ||
422 | instance FromJSON NodeInfo where | ||
423 | parseJSON (JSON.Object v) = do | ||
424 | nidstr <- v JSON..: "public_key" | ||
425 | ip6str <- v JSON..:? "ipv6" | ||
426 | ip4str <- v JSON..:? "ipv4" | ||
427 | portnum <- v JSON..: "port" | ||
428 | ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) | ||
429 | <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) | ||
430 | let (bs,_) = Base16.decode (C8.pack nidstr) | ||
431 | guard (B.length bs == 32) | ||
432 | return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16)) | ||
433 | |||
434 | getIP :: Word8 -> S.Get IP | ||
435 | getIP 0x02 = IPv4 <$> S.get | ||
436 | getIP 0x0a = IPv6 <$> S.get | ||
437 | getIP 0x82 = IPv4 <$> S.get -- TODO: TCP | ||
438 | getIP 0x8a = IPv6 <$> S.get -- TODO: TCP | ||
439 | getIP x = fail ("unsupported address family ("++show x++")") | ||
440 | |||
441 | instance S.Serialize NodeInfo where | ||
442 | get = do | ||
443 | addrfam <- S.get :: S.Get Word8 | ||
444 | ip <- getIP addrfam | ||
445 | port <- S.get :: S.Get PortNumber | ||
446 | nid <- S.get | ||
447 | return $ NodeInfo nid ip port | ||
448 | |||
449 | put (NodeInfo nid ip port) = do | ||
450 | case ip of | ||
451 | IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 | ||
452 | IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 | ||
453 | S.put port | ||
454 | S.put nid | ||
455 | |||
456 | -- node format: | ||
457 | -- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)] | ||
458 | -- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6] | ||
459 | -- [port (in network byte order), length=2 bytes] | ||
460 | -- [char array (node_id), length=32 bytes] | ||
461 | -- | ||
462 | |||
463 | |||
464 | hexdigit :: Char -> Bool | ||
465 | hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') | ||
466 | |||
467 | instance Read NodeInfo where | ||
468 | readsPrec i = RP.readP_to_S $ do | ||
469 | RP.skipSpaces | ||
470 | let n = 64 -- characters in node id. | ||
471 | parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) | ||
472 | RP.+++ RP.munch (not . isSpace) | ||
473 | nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit) | ||
474 | RP.char '@' RP.+++ RP.satisfy isSpace | ||
475 | addrstr <- parseAddr | ||
476 | nid <- case Base16.decode $ C8.pack hexhash of | ||
477 | (bs,_) | B.length bs==32 -> return (PubKey bs) | ||
478 | _ -> fail "Bad node id." | ||
479 | return (nid,addrstr) | ||
480 | (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) | ||
481 | let raddr = do | ||
482 | ip <- RP.between (RP.char '[') (RP.char ']') | ||
483 | (IPv6 <$> RP.readS_to_P (readsPrec i)) | ||
484 | RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) | ||
485 | _ <- RP.char ':' | ||
486 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
487 | return (ip, port) | ||
488 | |||
489 | (ip,port) <- case RP.readP_to_S raddr addrstr of | ||
490 | [] -> fail "Bad address." | ||
491 | ((ip,port),_):_ -> return (ip,port) | ||
492 | return $ NodeInfo nid ip port | ||
493 | |||
494 | |||
495 | -- The Hashable instance depends only on the IP address and port number. | ||
496 | instance Hashable NodeInfo where | ||
497 | hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) | ||
498 | {-# INLINE hashWithSalt #-} | ||
499 | |||
500 | |||
501 | instance Show NodeInfo where | ||
502 | showsPrec _ (NodeInfo nid ip port) = | ||
503 | shows nid . ('@' :) . showsip . (':' :) . shows port | ||
504 | where | ||
505 | showsip | ||
506 | | IPv4 ip4 <- ip = shows ip4 | ||
507 | | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 | ||
508 | | otherwise = ('[' :) . shows ip . (']' :) | ||
509 | |||
510 | nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo | ||
511 | nodeInfo nid saddr | ||
512 | | Just ip <- fromSockAddr saddr | ||
513 | , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port | ||
514 | | otherwise = Left "Address family not supported." | ||
515 | |||
516 | zeroID :: NodeId | ||
517 | zeroID = PubKey $ B.replicate 32 0 | ||
518 | |||
519 | -} | ||
520 | |||
521 | nodeAddr :: NodeInfo -> SockAddr | ||
522 | nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip | ||
523 | |||
524 | |||
525 | newtype ForwardPath (n::Nat) = ForwardPath ByteString | ||
526 | deriving (Eq, Ord,Data) | ||
527 | |||
528 | {- | ||
529 | class KnownNat n => OnionPacket n where | ||
530 | mkOnion :: ReturnPath n -> Packet -> Packet | ||
531 | instance OnionPacket 0 where mkOnion _ = id | ||
532 | instance OnionPacket 3 where mkOnion = OnionResponse3 | ||
533 | -} | ||
534 | |||
535 | data NoSpam = NoSpam !Word32 !(Maybe Word16) | ||
536 | deriving (Eq,Ord,Show) | ||
537 | |||
538 | instance Serialize NoSpam where | ||
539 | get = NoSpam <$> get <*> get | ||
540 | put (NoSpam w32 w16) = do | ||
541 | put w32 | ||
542 | put w16 | ||
543 | |||
544 | -- Utilizes Data.Serialize format for Word32 nospam and Word16 checksum. | ||
545 | instance Read NoSpam where | ||
546 | readsPrec d s = case break isSpace s of | ||
547 | ('$':ws ,rs) | (length ws == 8) -> base64decode rs (NoSpam <$> get <*> (Just <$> get)) ws | ||
548 | ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws | ||
549 | _ -> [] | ||
550 | |||
551 | base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1) | ||
552 | base64decode rs getter s = | ||
553 | either fail (\a -> return (a,rs)) | ||
554 | $ runGet getter | ||
555 | =<< Base64.decode (C8.pack $ map (nmtoken64 False) s) | ||
556 | |||
557 | base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1) | ||
558 | base16decode rs getter s = | ||
559 | either fail (\a -> return (a,rs)) | ||
560 | $ runGet getter | ||
561 | $ fst | ||
562 | $ Base16.decode (C8.pack s) | ||
563 | |||
564 | verifyChecksum :: PublicKey -> Word16 -> Either String () | ||
565 | verifyChecksum _ _ = return () -- TODO | ||
566 | |||
567 | data NoSpamId = NoSpamId NoSpam PublicKey | ||
568 | deriving (Eq,Ord) | ||
569 | |||
570 | noSpamIdToHex :: NoSpamId -> String | ||
571 | noSpamIdToHex (NoSpamId nspam pub) = C8.unpack (Base16.encode $ BA.convert pub) | ||
572 | ++ nospam16 nspam | ||
573 | |||
574 | nospam16 :: NoSpam -> String | ||
575 | nospam16 (NoSpam w32 Nothing) = n ++ "????" | ||
576 | where n = take 8 $ nospam16 (NoSpam w32 (Just 0)) | ||
577 | nospam16 (NoSpam w32 (Just w16)) = C8.unpack $ Base16.encode $ runPut $ do | ||
578 | put w32 | ||
579 | put w16 | ||
580 | |||
581 | nospam64 :: NoSpam -> String | ||
582 | nospam64 (NoSpam w32 Nothing) = n ++ "???" | ||
583 | where n = take 5 $ nospam64 (NoSpam w32 (Just 0)) | ||
584 | nospam64 (NoSpam w32 (Just w16)) = map (nmtoken64 True) $ C8.unpack $ Base64.encode $ runPut $ do | ||
585 | put w32 | ||
586 | put w16 | ||
587 | |||
588 | instance Show NoSpamId where | ||
589 | show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox" | ||
590 | |||
591 | instance Read NoSpamId where | ||
592 | readsPrec d s = either fail id $ do | ||
593 | (jid,xs) <- Right $ break isSpace s | ||
594 | nsid <- parseNoSpamId $ Text.pack jid | ||
595 | return [(nsid,xs)] | ||
596 | |||
597 | parseNoSpamHex :: Text -> Either String NoSpamId | ||
598 | parseNoSpamHex hex = Right $ NoSpamId (read $ "0x"++nospamsum) (id2key $ read hkey) | ||
599 | where | ||
600 | (hkey,nospamsum) = splitAt 64 $ Text.unpack hex | ||
601 | |||
602 | parseNoSpamId :: Text -> Either String NoSpamId | ||
603 | parseNoSpamId spec | Text.length spec == 76 | ||
604 | , Text.all isHexDigit spec = parseNoSpamHex spec | ||
605 | | otherwise = parseNoSpamJID spec | ||
606 | |||
607 | parseNoSpamJID :: Text -> Either String NoSpamId | ||
608 | parseNoSpamJID jid = do | ||
609 | (u,h) <- maybe (Left "Invalid JID.") Right | ||
610 | $ let (mu,h,_) = splitJID jid | ||
611 | in fmap (, h) mu | ||
612 | base64 <- case splitAt 43 $ Text.unpack h of | ||
613 | (base64,".tox") -> Right base64 | ||
614 | _ -> Left "Hostname should be 43 base64 digits followed by .tox." | ||
615 | pub <- id2key <$> readEither base64 | ||
616 | let ustr = Text.unpack u | ||
617 | case ustr of | ||
618 | '$' : b64digits -> solveBase64NoSpamID b64digits pub | ||
619 | '0' : 'x' : hexdigits -> do nospam <- readEither ('0':'x':hexdigits) | ||
620 | return $ NoSpamId nospam pub | ||
621 | _ -> Left "Missing nospam." | ||
622 | |||
623 | solveBase64NoSpamID :: String -> PublicKey -> Either String NoSpamId | ||
624 | solveBase64NoSpamID b64digits pub = do | ||
625 | NoSpam nospam mx <- readEither $ '$' : map (\case; '?' -> '0'; c -> c) b64digits | ||
626 | maybe (const $ Left "missing checksum") (flip ($)) mx $ \x -> do | ||
627 | let nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 | ||
628 | nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 | ||
629 | sum = x `xor` nlo `xor` nhi `xor` xorsum pub | ||
630 | -- Find any question mark indices. | ||
631 | qs = catMaybes $ zipWith (\case; '?' -> Just ; _ -> const Nothing) b64digits [0..7] | ||
632 | -- Break up the /sum/ into a numbered list of two-bit non-zero nibbles. | ||
633 | ns = filter (\case; (_,0) -> False; _ -> True) | ||
634 | $ zip [0..7] | ||
635 | $ unfoldr (\s -> Just (s .&. 0xC000, s `shiftL` 2)) sum | ||
636 | -- Represent the nospam value as a Word64 | ||
637 | n64 = shiftL (fromIntegral nospam) 32 .|. shiftL (fromIntegral x) 16 :: Word64 | ||
638 | |||
639 | -- q=0 1 2 3 4 5 6 7 | ||
640 | -- 012 345 670 123 456 701 234 567 | ||
641 | nibblePlace n q = case mod (n - 3 * q) 8 of | ||
642 | p | p < 3 -> Just (q,p) | ||
643 | _ -> Nothing | ||
644 | |||
645 | solve [] !ac = Right ac | ||
646 | solve ((n,b):ns) !ac = do | ||
647 | -- Find nibble p of question-digit q that corresponds to nibble n. | ||
648 | (q,p) <- maybe (Left "Unsolvable nospam.") Right | ||
649 | $ foldr (<|>) Nothing $ map (nibblePlace n) qs | ||
650 | let bitpos = q * 6 + p * 2 | ||
651 | ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos | ||
652 | solve ns ac' | ||
653 | n64' <- solve ns n64 | ||
654 | let nospam' = fromIntegral (n64' `shiftR` 32) | ||
655 | cksum' = fromIntegral (n64' `shiftR` 16) | ||
656 | return $ NoSpamId (NoSpam nospam' (Just cksum')) pub | ||
657 | |||
658 | -- | This type indicates a roster-link relationship between a local toxid and a | ||
659 | -- remote toxid. Note that these toxids are represented as the type 'NodeId' | ||
660 | -- even though they are long-term keys rather than the public keys of Tox DHT | ||
661 | -- nodes. | ||
662 | data ToxContact = ToxContact NodeId{-me-} NodeId{-them-} | ||
663 | deriving (Eq,Ord) | ||
664 | |||
665 | instance Show ToxContact where show = show . showToxContact_ | ||
666 | |||
667 | showToxContact_ :: ToxContact -> String | ||
668 | showToxContact_ (ToxContact me them) = show me ++ ":" ++ show them | ||
669 | |||
670 | -- | This type indicates the progress of a tox encrypted friend link | ||
671 | -- connection. Two scenarios are illustrated below. The parenthesis show the | ||
672 | -- current 'G.Status' 'ToxProgress' of the session. | ||
673 | -- | ||
674 | -- | ||
675 | -- Perfect handshake scenario: | ||
676 | -- | ||
677 | -- Peer 1 Peer 2 | ||
678 | -- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie) | ||
679 | -- Cookie request -> | ||
680 | -- <- Cookie response | ||
681 | -- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie) | ||
682 | -- Handshake packet -> | ||
683 | -- * accepts connection | ||
684 | -- (InProgress AwaitingSessionPacket) | ||
685 | -- <- Handshake packet | ||
686 | -- *accepts connection | ||
687 | -- (InProgress AwaitingSessionPacket) | ||
688 | -- Encrypted packet -> <- Encrypted packet | ||
689 | -- *confirms connection *confirms connection | ||
690 | -- (Established) (Established) | ||
691 | -- | ||
692 | -- Connection successful. | ||
693 | -- | ||
694 | -- Encrypted packets -> <- Encrypted packets | ||
695 | -- | ||
696 | -- | ||
697 | -- | ||
698 | -- | ||
699 | -- More realistic handshake scenario: | ||
700 | -- Peer 1 Peer 2 | ||
701 | -- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie) | ||
702 | -- Cookie request -> *packet lost* | ||
703 | -- Cookie request -> | ||
704 | -- <- Cookie response | ||
705 | -- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie) | ||
706 | -- | ||
707 | -- *Peer 2 randomly starts new connection to peer 1 | ||
708 | -- (InProgress AcquiringCookie) | ||
709 | -- <- Cookie request | ||
710 | -- Cookie response -> | ||
711 | -- (InProgress AwaitingHandshake) | ||
712 | -- | ||
713 | -- Handshake packet -> <- Handshake packet | ||
714 | -- *accepts connection * accepts connection | ||
715 | -- (InProgress AwaitingSessionPacket) (InProgress AwaitingSessionPacket) | ||
716 | -- | ||
717 | -- Encrypted packet -> <- Encrypted packet | ||
718 | -- *confirms connection *confirms connection | ||
719 | -- (Established) (Established) | ||
720 | -- | ||
721 | -- Connection successful. | ||
722 | -- | ||
723 | -- Encrypted packets -> <- Encrypted packets | ||
724 | data ToxProgress | ||
725 | = AwaitingDHTKey -- ^ Waiting to receive their DHT key. | ||
726 | | AcquiringIPAddress -- ^ Searching DHT to obtain their node's IP & port. | ||
727 | | AcquiringCookie -- ^ Attempting to obtain a cookie. | ||
728 | | AwaitingHandshake -- ^ Waiting to receive a handshake. | ||
729 | | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed". | ||
730 | deriving (Eq,Ord,Enum,Show) | ||
731 | |||
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs new file mode 100644 index 00000000..f44dd79c --- /dev/null +++ b/dht/src/Network/Tox/Onion/Handlers.hs | |||
@@ -0,0 +1,369 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | {-# LANGUAGE LambdaCase #-} | ||
3 | {-# LANGUAGE PatternSynonyms #-} | ||
4 | module Network.Tox.Onion.Handlers where | ||
5 | |||
6 | import Network.Kademlia.Search | ||
7 | import Network.Tox.DHT.Transport | ||
8 | import Network.Tox.DHT.Handlers hiding (Message,Client) | ||
9 | import Network.Tox.Onion.Transport | ||
10 | import Network.QueryResponse as QR hiding (Client) | ||
11 | import qualified Network.QueryResponse as QR (Client) | ||
12 | import Crypto.Tox | ||
13 | import qualified Data.Wrapper.PSQ as PSQ | ||
14 | ;import Data.Wrapper.PSQ (PSQ,pattern (:->)) | ||
15 | import Control.Arrow | ||
16 | |||
17 | import Data.Function | ||
18 | import qualified Data.MinMaxPSQ as MinMaxPSQ | ||
19 | ;import Data.MinMaxPSQ (MinMaxPSQ') | ||
20 | import Network.BitTorrent.DHT.Token as Token | ||
21 | |||
22 | import Control.Exception hiding (Handler) | ||
23 | import Control.Monad | ||
24 | #ifdef THREAD_DEBUG | ||
25 | import Control.Concurrent.Lifted.Instrument | ||
26 | #else | ||
27 | import Control.Concurrent | ||
28 | import GHC.Conc (labelThread) | ||
29 | #endif | ||
30 | import Control.Concurrent.STM | ||
31 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) | ||
32 | import Network.Socket | ||
33 | #if MIN_VERSION_iproute(1,7,4) | ||
34 | import Data.IP hiding (fromSockAddr) | ||
35 | #else | ||
36 | import Data.IP | ||
37 | #endif | ||
38 | import Data.Maybe | ||
39 | import Data.Functor.Identity | ||
40 | import DPut | ||
41 | import DebugTag | ||
42 | |||
43 | type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message | ||
44 | type Message = OnionMessage Identity | ||
45 | |||
46 | classify :: Message -> MessageClass String PacketKind TransactionId (OnionDestination r) Message | ||
47 | classify msg = go msg | ||
48 | where | ||
49 | go (OnionAnnounce announce) = IsQuery AnnounceType | ||
50 | $ TransactionId (snd $ runIdentity $ asymmData announce) | ||
51 | (asymmNonce announce) | ||
52 | go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24) | ||
53 | go (OnionToRoute {}) = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24)) | ||
54 | go (OnionToRouteResponse {}) = IsResponse (TransactionId (Nonce8 0) (Nonce24 zeros24)) | ||
55 | |||
56 | -- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time, | ||
57 | -- some secret bytes generated when the instance is created, the current time | ||
58 | -- divided by a 20 second timeout, the public key of the requester and the source | ||
59 | -- ip/port that the packet was received from. Since the ip/port that the packet | ||
60 | -- was received from is in the `ping_id`, the announce packets being sent with a | ||
61 | -- ping id must be sent using the same path as the packet that we received the | ||
62 | -- `ping_id` from or announcing will fail. | ||
63 | -- | ||
64 | -- The reason for this 20 second timeout in toxcore is that it gives a reasonable | ||
65 | -- time (20 to 40 seconds) for a peer to announce himself while taking in count | ||
66 | -- all the possible delays with some extra seconds. | ||
67 | announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse | ||
68 | announceH routing toks keydb oaddr req = do | ||
69 | case () of | ||
70 | _ | announcePingId req == zeros32 | ||
71 | -> go False | ||
72 | |||
73 | _ -> let Nonce32 bs = announcePingId req | ||
74 | tok = fromPaddedByteString 32 bs | ||
75 | in checkToken toks (onionNodeInfo oaddr) tok >>= go | ||
76 | `catch` (\(SomeException e) -> dput XAnnounce ("announceH Exception! "++show e) >> throw e) | ||
77 | where | ||
78 | go withTok = do | ||
79 | let naddr = onionNodeInfo oaddr | ||
80 | ns <- getNodesH routing naddr (GetNodes (announceSeeking req)) | ||
81 | tm <- getPOSIXTime | ||
82 | |||
83 | let storing = case oaddr of | ||
84 | OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth | ||
85 | _ -> Nothing | ||
86 | dput XAnnounce $ unlines [ "announceH: nodeId = " ++ show (nodeId naddr) | ||
87 | , " announceSeeking = " ++ show (announceSeeking req) | ||
88 | , " withTok = " ++ show withTok | ||
89 | , " storing = " ++ maybe "False" (const "True") storing | ||
90 | ] | ||
91 | record <- atomically $ do | ||
92 | forM_ storing $ \retpath -> when withTok $ do | ||
93 | let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath | ||
94 | -- Note: The following distance calculation assumes that | ||
95 | -- our nodeid doesn't change and is the same for both | ||
96 | -- routing4 and routing6. | ||
97 | d = xorNodeId (nodeId (tentativeId routing)) | ||
98 | (announceSeeking req) | ||
99 | modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d) | ||
100 | ks <- readTVar keydb | ||
101 | return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks) | ||
102 | newtok <- maybe (return $ zeros32) | ||
103 | (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr) | ||
104 | storing | ||
105 | let k = case record of | ||
106 | Nothing -> NotStored newtok | ||
107 | Just _ | isJust storing -> Acknowledged newtok | ||
108 | Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni) | ||
109 | let response = AnnounceResponse k ns | ||
110 | dput XAnnounce $ unwords ["Announce:", show req, "-reply->", show response] | ||
111 | return response | ||
112 | |||
113 | dataToRouteH :: | ||
114 | TVar AnnouncedKeys | ||
115 | -> Transport err (OnionDestination r) (OnionMessage f) | ||
116 | -> addr | ||
117 | -> OnionMessage f | ||
118 | -> IO () | ||
119 | dataToRouteH keydb udp _ (OnionToRoute pub asymm) = do | ||
120 | let k = key2id pub | ||
121 | dput XOnion $ "dataToRouteH "++ show k | ||
122 | mb <- atomically $ do | ||
123 | ks <- readTVar keydb | ||
124 | forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do | ||
125 | writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) } | ||
126 | return rpath | ||
127 | dput XOnion $ "dataToRouteH "++ show (fmap (const ()) mb) | ||
128 | forM_ mb $ \rpath -> do | ||
129 | -- forward | ||
130 | dput XOnion $ "dataToRouteH sendMessage" | ||
131 | sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse asymm | ||
132 | dput XOnion $ "Forwarding data-to-route -->"++show k | ||
133 | |||
134 | type NodeDistance = NodeId | ||
135 | |||
136 | data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3) | ||
137 | |||
138 | toOnionDestination :: AnnouncedRoute -> OnionDestination r | ||
139 | toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath | ||
140 | |||
141 | -- | | ||
142 | -- The type 'NodeId' was originally made for the DHT key, but here | ||
143 | -- we reuse it for user keys (public key/real key). | ||
144 | -- | ||
145 | -- To find someone using their user (public) key, you search for it on | ||
146 | -- kademlia. At each iteration of the search, you get a response with | ||
147 | -- closest known nodes(DHT keys) to the key you are searching for. | ||
148 | -- | ||
149 | -- To do an 'Announce' so your friends can find you, you do a search to | ||
150 | -- find the closest nodes to your own user(public) key. At those nodes, | ||
151 | -- you store a route back to yourself (using Announce message) so your | ||
152 | -- friends can contact you. This means each node needs to store the | ||
153 | -- saved routes, and that is the purpose of the 'AnnouncedKeys' data | ||
154 | -- structure. | ||
155 | -- | ||
156 | data AnnouncedKeys = AnnouncedKeys | ||
157 | { keyByAge :: !(PSQ NodeId (POSIXTime{-Time at which they announced to you-})) | ||
158 | , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute)) | ||
159 | -- ^ PSQ using NodeId(user/public key) as Key | ||
160 | -- and using 'NodeDistance' as priority. | ||
161 | -- (smaller number is higher priority) | ||
162 | -- | ||
163 | -- Keeping in a MinMaxPSQ will help us later when we want to make the structure | ||
164 | -- bounded. (We simply throw away the most NodeDistant keys. | ||
165 | } | ||
166 | |||
167 | |||
168 | insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys | ||
169 | insertKey tm pub toxpath d keydb = AnnouncedKeys | ||
170 | { keyByAge = PSQ.insert pub tm (keyByAge keydb) | ||
171 | , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of | ||
172 | Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb) | ||
173 | Nothing -> MinMaxPSQ.insert' pub (0 ,toxpath) d (keyAssoc keydb) | ||
174 | } | ||
175 | |||
176 | -- | Forks a thread to garbage-collect old key announcements. Keys may be | ||
177 | -- discarded after 5 minutes. | ||
178 | forkAnnouncedKeysGC :: TVar AnnouncedKeys -> IO ThreadId | ||
179 | forkAnnouncedKeysGC db = forkIO $ do | ||
180 | myThreadId >>= flip labelThread "gc:toxids" | ||
181 | fix $ \loop -> do | ||
182 | cutoff <- getPOSIXTime | ||
183 | threadDelay 300000000 -- 300 seconds | ||
184 | join $ atomically $ do | ||
185 | fix $ \gc -> do | ||
186 | keys <- readTVar db | ||
187 | case PSQ.minView (keyByAge keys) of | ||
188 | Nothing -> return loop | ||
189 | Just (pub :-> tm,kba') | ||
190 | | tm > cutoff -> return loop | ||
191 | | otherwise -> do writeTVar db keys | ||
192 | { keyByAge = kba' | ||
193 | , keyAssoc = MinMaxPSQ.delete pub (keyAssoc keys) | ||
194 | } | ||
195 | gc | ||
196 | |||
197 | areq :: Message -> Either String AnnounceRequest | ||
198 | areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm | ||
199 | areq _ = Left "Unexpected non-announce OnionMessage" | ||
200 | |||
201 | handlers :: Transport err (OnionDestination r) Message | ||
202 | -> Routing | ||
203 | -> TVar SessionTokens | ||
204 | -> TVar AnnouncedKeys | ||
205 | -> PacketKind | ||
206 | -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message) | ||
207 | handlers net routing toks keydb AnnounceType | ||
208 | = Just | ||
209 | $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity) | ||
210 | $ announceH routing toks keydb | ||
211 | handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net | ||
212 | |||
213 | |||
214 | toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
215 | -> TransportCrypto | ||
216 | -> Client r | ||
217 | -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous | ||
218 | toxidSearch getTimeout crypto client = Search | ||
219 | { searchSpace = toxSpace | ||
220 | , searchNodeAddress = nodeIP &&& nodePort | ||
221 | , searchQuery = Right $ asyncGetRendezvous getTimeout crypto client | ||
222 | , searchAlpha = 3 | ||
223 | , searchK = 6 | ||
224 | } | ||
225 | |||
226 | announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
227 | -> MethodSerializer | ||
228 | TransactionId | ||
229 | (OnionDestination r) | ||
230 | (OnionMessage Identity) | ||
231 | PacketKind | ||
232 | AnnounceRequest | ||
233 | (Maybe AnnounceResponse) | ||
234 | announceSerializer getTimeout = MethodSerializer | ||
235 | { methodTimeout = getTimeout | ||
236 | , method = AnnounceType | ||
237 | , wrapQuery = \(TransactionId n8 n24) src dst req -> | ||
238 | -- :: tid -> addr -> addr -> a -> OnionMessage Identity | ||
239 | OnionAnnounce $ Asymm | ||
240 | { -- The public key is our real long term public key if we want to | ||
241 | -- announce ourselves, a temporary one if we are searching for | ||
242 | -- friends. | ||
243 | senderKey = onionKey src | ||
244 | , asymmNonce = n24 | ||
245 | , asymmData = Identity (req, n8) | ||
246 | } | ||
247 | , unwrapResponse = \case -- :: OnionMessage Identity -> b | ||
248 | OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp | ||
249 | _ -> Nothing | ||
250 | } | ||
251 | |||
252 | unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32) | ||
253 | unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns)) | ||
254 | = case is_stored of | ||
255 | NotStored n32 -> ( ns , [] , Just n32) | ||
256 | SendBackKey k -> ( ns , [Rendezvous k ni] , Nothing ) | ||
257 | Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32) | ||
258 | |||
259 | -- TODO Announce key to announce peers. | ||
260 | -- | ||
261 | -- Announce Peers are only put in the 8 closest peers array if they respond | ||
262 | -- to an announce request. If the peers fail to respond to 3 announce | ||
263 | -- requests they are deemed timed out and removed. | ||
264 | -- | ||
265 | -- ... | ||
266 | -- | ||
267 | -- For this reason, after the peer is announced successfully for 17 seconds, | ||
268 | -- announce packets are sent aggressively every 3 seconds to each known close | ||
269 | -- peer (in the list of 8 peers) to search aggressively for peers that know | ||
270 | -- the peer we are searching for. | ||
271 | |||
272 | -- TODO | ||
273 | -- If toxcore goes offline (no onion traffic for 20 seconds) toxcore will | ||
274 | -- aggressively reannounce itself and search for friends as if it was just | ||
275 | -- started. | ||
276 | |||
277 | |||
278 | sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
279 | -> Client r | ||
280 | -> AnnounceRequest | ||
281 | -> OnionDestination r | ||
282 | -> (NodeInfo -> AnnounceResponse -> t) | ||
283 | -> IO (Maybe t) | ||
284 | sendOnion getTimeout client req oaddr unwrap = | ||
285 | -- Four tries and then we tap out. | ||
286 | flip fix 4 $ \loop n -> do | ||
287 | mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr | ||
288 | forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r | ||
289 | maybe (if n>0 then loop $! n - 1 else return Nothing) | ||
290 | (return . Just . unwrap (onionNodeInfo oaddr)) | ||
291 | $ join mb | ||
292 | |||
293 | asyncOnion :: (TransactionId | ||
294 | -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
295 | -> QR.Client | ||
296 | err | ||
297 | PacketKind | ||
298 | TransactionId | ||
299 | (OnionDestination r) | ||
300 | (OnionMessage Identity) | ||
301 | -> AnnounceRequest | ||
302 | -> OnionDestination r | ||
303 | -> (NodeInfo -> AnnounceResponse -> a) | ||
304 | -> (Maybe a -> IO ()) | ||
305 | -> IO () | ||
306 | asyncOnion getTimeout client req oaddr unwrap go = | ||
307 | -- Four tries and then we tap out. | ||
308 | flip fix 4 $ \loop n -> do | ||
309 | QR.asyncQuery client (announceSerializer getTimeout) req oaddr | ||
310 | $ \mb -> do | ||
311 | forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r | ||
312 | maybe (if n>0 then loop $! n - 1 else go Nothing) | ||
313 | (go . Just . unwrap (onionNodeInfo oaddr)) | ||
314 | $ join mb | ||
315 | |||
316 | |||
317 | -- | Lookup the secret counterpart for a given alias key. | ||
318 | getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
319 | -> TransportCrypto | ||
320 | -> Client r | ||
321 | -> NodeId | ||
322 | -> NodeInfo | ||
323 | -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32)) | ||
324 | getRendezvous getTimeout crypto client nid ni = do | ||
325 | asel <- atomically $ selectAlias crypto nid | ||
326 | let oaddr = OnionDestination asel ni Nothing | ||
327 | rkey = case asel of | ||
328 | SearchingAlias -> Nothing | ||
329 | _ -> Just $ key2id $ rendezvousPublic crypto | ||
330 | sendOnion getTimeout client | ||
331 | (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey) | ||
332 | oaddr | ||
333 | (unwrapAnnounceResponse rkey) | ||
334 | |||
335 | asyncGetRendezvous | ||
336 | :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
337 | -> TransportCrypto | ||
338 | -> Client r | ||
339 | -> NodeId | ||
340 | -> NodeInfo | ||
341 | -> (Maybe ([NodeInfo], [Rendezvous], Maybe Nonce32) -> IO ()) | ||
342 | -> IO () | ||
343 | asyncGetRendezvous getTimeout crypto client nid ni go = do | ||
344 | asel <- atomically $ selectAlias crypto nid | ||
345 | let oaddr = OnionDestination asel ni Nothing | ||
346 | rkey = case asel of | ||
347 | SearchingAlias -> Nothing | ||
348 | _ -> Just $ key2id $ rendezvousPublic crypto | ||
349 | asyncOnion getTimeout client | ||
350 | (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey) | ||
351 | oaddr | ||
352 | (unwrapAnnounceResponse rkey) | ||
353 | go | ||
354 | |||
355 | putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int)) | ||
356 | -> TransportCrypto | ||
357 | -> Client r | ||
358 | -> PublicKey | ||
359 | -> Nonce32 | ||
360 | -> NodeInfo | ||
361 | -> IO (Maybe (Rendezvous, AnnounceResponse)) | ||
362 | putRendezvous getTimeout crypto client pubkey nonce32 ni = do | ||
363 | let longTermKey = key2id pubkey | ||
364 | rkey = rendezvousPublic crypto | ||
365 | rendezvousKey = key2id rkey | ||
366 | asel <- atomically $ selectAlias crypto longTermKey | ||
367 | let oaddr = OnionDestination asel ni Nothing | ||
368 | sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr | ||
369 | $ \ni resp -> (Rendezvous rkey ni, resp) | ||
diff --git a/dht/src/Network/Tox/Onion/Transport.hs b/dht/src/Network/Tox/Onion/Transport.hs new file mode 100644 index 00000000..e746c414 --- /dev/null +++ b/dht/src/Network/Tox/Onion/Transport.hs | |||
@@ -0,0 +1,119 @@ | |||
1 | module Network.Tox.Onion.Transport | ||
2 | ( parseOnionAddr | ||
3 | , encodeOnionAddr | ||
4 | , parseDataToRoute | ||
5 | , encodeDataToRoute | ||
6 | , forwardOnions | ||
7 | , AliasSelector(..) | ||
8 | , OnionDestination(..) | ||
9 | , OnionMessage(..) | ||
10 | , Rendezvous(..) | ||
11 | , DataToRoute(..) | ||
12 | , OnionData(..) | ||
13 | , AnnouncedRendezvous(..) | ||
14 | , AnnounceResponse(..) | ||
15 | , AnnounceRequest(..) | ||
16 | , Forwarding(..) | ||
17 | , ReturnPath(..) | ||
18 | , OnionRequest(..) | ||
19 | , OnionResponse(..) | ||
20 | , Addressed(..) | ||
21 | , UDPTransport | ||
22 | , KeyRecord(..) | ||
23 | , encrypt | ||
24 | , decrypt | ||
25 | , peelSymmetric | ||
26 | , OnionRoute(..) | ||
27 | , N0 | ||
28 | , N1 | ||
29 | , N2 | ||
30 | , N3 | ||
31 | , onionKey | ||
32 | , onionAliasSelector | ||
33 | , selectAlias | ||
34 | , RouteId(..) | ||
35 | , routeId | ||
36 | , putRequest | ||
37 | , wrapForRoute | ||
38 | , wrapSymmetric | ||
39 | , wrapOnion | ||
40 | , wrapOnionPure | ||
41 | ) where | ||
42 | |||
43 | import Data.ByteString (ByteString) | ||
44 | import Data.Serialize | ||
45 | import Network.Socket | ||
46 | |||
47 | import Crypto.Tox hiding (encrypt,decrypt) | ||
48 | import qualified Data.Tox.Relay as TCP | ||
49 | import Data.Tox.Onion | ||
50 | import Network.Tox.NodeId | ||
51 | |||
52 | {- | ||
53 | encodeOnionAddr :: TransportCrypto | ||
54 | -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) | ||
55 | -> (OnionMessage Encrypted,OnionDestination RouteId) | ||
56 | -> IO (Maybe (ByteString, SockAddr)) | ||
57 | -} | ||
58 | encodeOnionAddr :: TransportCrypto | ||
59 | -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) | ||
60 | -> (OnionMessage Encrypted, OnionDestination RouteId) | ||
61 | -> IO (Maybe | ||
62 | (Either (TCP.RelayPacket, TCP.NodeInfo) (ByteString, SockAddr))) | ||
63 | encodeOnionAddr crypto _ (msg,OnionToOwner ni p) = | ||
64 | return $ Just $ Right ( runPut $ putResponse (OnionResponse p msg) | ||
65 | , nodeAddr ni ) | ||
66 | encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do | ||
67 | encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) | ||
68 | -- dput XMisc $ "ONION encode missing routeid" | ||
69 | -- return Nothing | ||
70 | encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do | ||
71 | let go route = do | ||
72 | mreq <- wrapForRoute crypto msg ni route | ||
73 | case mreq of | ||
74 | Right req -> return $ Right ( runPut $ putRequest req , nodeAddr $ routeNodeA route) | ||
75 | Left o | Just port <- routeRelayPort route | ||
76 | -> return $ Left ( o, TCP.NodeInfo (routeNodeA route) port) | ||
77 | m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid | ||
78 | x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m | ||
79 | return x | ||
80 | |||
81 | -- wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0) | ||
82 | wrapForRoute :: TransportCrypto | ||
83 | -> OnionMessage Encrypted | ||
84 | -> NodeInfo | ||
85 | -> OnionRoute | ||
86 | -> IO (Either TCP.RelayPacket (OnionRequest N0)) | ||
87 | wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort=Nothing} = do | ||
88 | -- We needn't use the same nonce value here, but I think it is safe to do so. | ||
89 | let nonce = msgNonce msg | ||
90 | fwd <- wrapOnion crypto (routeAliasA r) | ||
91 | nonce | ||
92 | (id2key . nodeId $ routeNodeA r) | ||
93 | (nodeAddr $ routeNodeB r) | ||
94 | =<< wrapOnion crypto (routeAliasB r) | ||
95 | nonce | ||
96 | (id2key . nodeId $ routeNodeB r) | ||
97 | (nodeAddr $ routeNodeC r) | ||
98 | =<< wrapOnion crypto (routeAliasC r) | ||
99 | nonce | ||
100 | (id2key . nodeId $ routeNodeC r) | ||
101 | (nodeAddr ni) | ||
102 | (NotForwarded msg) | ||
103 | return $ Right OnionRequest | ||
104 | { onionNonce = nonce | ||
105 | , onionForward = fwd | ||
106 | , pathFromOwner = NoReturnPath | ||
107 | } | ||
108 | wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort = Just tcpport} = do | ||
109 | let nonce = msgNonce msg | ||
110 | fwd <- wrapOnion crypto (routeAliasB r) | ||
111 | nonce | ||
112 | (id2key . nodeId $ routeNodeB r) | ||
113 | (nodeAddr $ routeNodeC r) | ||
114 | =<< wrapOnion crypto (routeAliasC r) | ||
115 | nonce | ||
116 | (id2key . nodeId $ routeNodeC r) | ||
117 | (nodeAddr ni) | ||
118 | (NotForwarded msg) | ||
119 | return $ Left $ TCP.OnionPacket nonce $ Addressed (nodeAddr $ routeNodeB r) fwd | ||
diff --git a/dht/src/Network/Tox/Relay.hs b/dht/src/Network/Tox/Relay.hs new file mode 100644 index 00000000..2842fcc2 --- /dev/null +++ b/dht/src/Network/Tox/Relay.hs | |||
@@ -0,0 +1,235 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | ||
2 | {-# LANGUAGE RecordWildCards #-} | ||
3 | {-# LANGUAGE ScopedTypeVariables #-} | ||
4 | module Network.Tox.Relay (tcpRelay) where | ||
5 | |||
6 | import Control.Concurrent.MVar | ||
7 | import Control.Concurrent.STM | ||
8 | import Control.Exception | ||
9 | import Control.Monad | ||
10 | import qualified Data.ByteString as B | ||
11 | import Data.Function | ||
12 | import Data.Functor.Identity | ||
13 | import qualified Data.IntMap as IntMap | ||
14 | ;import Data.IntMap (IntMap) | ||
15 | import qualified Data.Map as Map | ||
16 | ;import Data.Map (Map) | ||
17 | import Data.Serialize | ||
18 | import Data.Word | ||
19 | import Network.Socket (SockAddr) | ||
20 | import System.IO | ||
21 | import System.IO.Error | ||
22 | import System.Timeout | ||
23 | |||
24 | import Crypto.Tox | ||
25 | import qualified Data.IntervalSet as IntSet | ||
26 | ;import Data.IntervalSet (IntSet) | ||
27 | import Data.Tox.Relay | ||
28 | import Network.Address (getBindAddress) | ||
29 | import Network.SocketLike | ||
30 | import Network.StreamServer | ||
31 | import Network.Tox.Onion.Transport hiding (encrypt,decrypt) | ||
32 | |||
33 | |||
34 | |||
35 | hGetPrefixed :: Serialize a => Handle -> IO (Either String a) | ||
36 | hGetPrefixed h = do | ||
37 | mlen <- runGet getWord16be <$> B.hGet h 2 | ||
38 | -- We treat parse-fail the same as EOF. | ||
39 | fmap join $ forM mlen $ \len -> runGet get <$> B.hGet h (fromIntegral len) | ||
40 | |||
41 | hGetSized :: forall x. (Sized x, Serialize x) => Handle -> IO (Either String x) | ||
42 | hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF. | ||
43 | where | ||
44 | ConstSize len = size :: Size x | ||
45 | |||
46 | data RelaySession = RelaySession | ||
47 | { indexPool :: IntSet -- ^ Ints that are either solicited or associated. | ||
48 | , solicited :: Map PublicKey Int -- ^ Reserved ids, not yet in associated. | ||
49 | , associated :: IntMap ((ConId -> RelayPacket) -> IO ()) -- ^ Peers this session is connected to. | ||
50 | } | ||
51 | |||
52 | freshSession :: RelaySession | ||
53 | freshSession = RelaySession | ||
54 | { indexPool = IntSet.empty | ||
55 | , solicited = Map.empty | ||
56 | , associated = IntMap.empty | ||
57 | } | ||
58 | |||
59 | disconnect :: TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession)) | ||
60 | -> PublicKey | ||
61 | -> IO () | ||
62 | disconnect cons who = join $ atomically $ do | ||
63 | Map.lookup who <$> readTVar cons | ||
64 | >>= \case | ||
65 | Nothing -> return $ return () | ||
66 | Just (_,session) -> do | ||
67 | modifyTVar' cons $ Map.delete who | ||
68 | RelaySession { associated = cs } <- readTVar session | ||
69 | return $ let notifyPeer i send = ((send DisconnectNotification) >>) | ||
70 | in IntMap.foldrWithKey notifyPeer (return ()) cs | ||
71 | |||
72 | relaySession :: TransportCrypto | ||
73 | -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession)) | ||
74 | -> (SockAddr -> OnionRequest N1 -> IO ()) | ||
75 | -> sock | ||
76 | -> Int | ||
77 | -> Handle | ||
78 | -> IO () | ||
79 | relaySession crypto cons sendOnion _ conid h = do | ||
80 | -- atomically $ modifyTVar' cons $ IntMap.insert conid h | ||
81 | |||
82 | -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h | ||
83 | |||
84 | (hGetSized h >>=) $ mapM_ $ \helloE -> do | ||
85 | |||
86 | let me = transportSecret crypto | ||
87 | them = helloFrom helloE | ||
88 | |||
89 | noncef <- lookupNonceFunction crypto me them | ||
90 | let mhello = decryptPayload (noncef $ helloNonce helloE) helloE | ||
91 | forM_ mhello $ \hello -> do | ||
92 | let _ = hello :: Hello Identity | ||
93 | |||
94 | (me',welcome) <- atomically $ do | ||
95 | skey <- transportNewKey crypto | ||
96 | dta <- HelloData (toPublic skey) <$> transportNewNonce crypto | ||
97 | w24 <- transportNewNonce crypto | ||
98 | return (skey, Welcome w24 $ pure dta) | ||
99 | |||
100 | B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome | ||
101 | |||
102 | noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello) | ||
103 | in lookupNonceFunction crypto me' them' | ||
104 | |||
105 | let readPacket n24 = (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h | ||
106 | base = sessionBaseNonce $ runIdentity $ helloData hello | ||
107 | |||
108 | -- You get 3 seconds to send a session packet. | ||
109 | mpkt0 <- join <$> timeout 3000000 (either (const Nothing) Just <$> readPacket base) | ||
110 | forM_ mpkt0 $ \pkt0 -> do | ||
111 | |||
112 | disconnect cons (helloFrom hello) | ||
113 | (sendPacket,session) <- do | ||
114 | session <- atomically $ newTVar freshSession | ||
115 | sendPacket <- do | ||
116 | v <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome) | ||
117 | return $ \p -> do | ||
118 | case p of | ||
119 | DisconnectNotification con -> atomically $ do | ||
120 | modifyTVar' session $ \s -> s | ||
121 | { indexPool = maybe id IntSet.delete (c2key con) (indexPool s) | ||
122 | , associated = maybe id IntMap.delete (c2key con) (associated s) | ||
123 | } | ||
124 | _ -> return () | ||
125 | n24 <- takeMVar v | ||
126 | let bs = encode $ encrypt (noncef' n24) $ encodePlain (p :: RelayPacket) | ||
127 | do B.hPut h $ encode (fromIntegral (B.length bs) :: Word16) | ||
128 | B.hPut h bs | ||
129 | `catchIOError` \_ -> return () | ||
130 | putMVar v (incrementNonce24 n24) | ||
131 | atomically $ modifyTVar' cons $ Map.insert (helloFrom hello) (sendPacket,session) | ||
132 | return (sendPacket,session) | ||
133 | |||
134 | handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0 | ||
135 | |||
136 | flip fix (incrementNonce24 base) $ \loop n24 -> do | ||
137 | m <- readPacket n24 | ||
138 | forM_ m $ \p -> do | ||
139 | handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p | ||
140 | loop (incrementNonce24 n24) | ||
141 | `finally` | ||
142 | disconnect cons (helloFrom hello) | ||
143 | |||
144 | handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession)) | ||
145 | -> Int | ||
146 | -> PublicKey | ||
147 | -> TransportCrypto | ||
148 | -> (SockAddr -> OnionRequest N1 -> IO ()) | ||
149 | -> (RelayPacket -> IO ()) | ||
150 | -> TVar RelaySession | ||
151 | -> RelayPacket | ||
152 | -> IO () | ||
153 | handlePacket cons thistcp me crypto sendOnion sendToMe session = \case | ||
154 | RoutingRequest them -> join $ atomically $ do | ||
155 | mySession <- readTVar session | ||
156 | mi <- case Map.lookup them (solicited mySession) of | ||
157 | Nothing -> fmap join $ forM (IntSet.nearestOutsider 0 (indexPool mySession)) $ \i -> do | ||
158 | if -120 <= i && i <= 119 | ||
159 | then do | ||
160 | writeTVar session mySession | ||
161 | { indexPool = IntSet.insert i (indexPool mySession) | ||
162 | , solicited = Map.insert them i (solicited mySession) | ||
163 | } | ||
164 | return $ Just i | ||
165 | else return Nothing -- No more slots available. | ||
166 | Just i -> return $ Just i | ||
167 | notifyConnect <- fmap (join . join) $ forM mi $ \i -> do | ||
168 | mp <- Map.lookup them <$> readTVar cons | ||
169 | forM mp $ \(sendToThem,peer) -> do | ||
170 | theirSession <- readTVar peer | ||
171 | forM (Map.lookup me $ solicited theirSession) $ \reserved_id -> do | ||
172 | let sendToThem' f = sendToThem $ f $ key2c reserved_id | ||
173 | sendToMe' f = sendToMe $ f $ key2c i | ||
174 | writeTVar peer theirSession | ||
175 | { solicited = Map.delete me (solicited theirSession) | ||
176 | , associated = IntMap.insert reserved_id sendToMe' (associated theirSession) | ||
177 | } | ||
178 | writeTVar session mySession | ||
179 | { solicited = Map.delete them (solicited mySession) | ||
180 | , associated = IntMap.insert i sendToThem' (associated mySession) | ||
181 | } | ||
182 | return $ do sendToThem' ConnectNotification | ||
183 | sendToMe' ConnectNotification | ||
184 | return $ do sendToMe $ RoutingResponse (maybe badcon key2c mi) them | ||
185 | sequence_ notifyConnect | ||
186 | |||
187 | RelayPing x -> sendToMe $ RelayPong x -- TODO x==0 is invalid. Do we care? | ||
188 | |||
189 | OOBSend them bs -> do | ||
190 | m <- atomically $ Map.lookup them <$> readTVar cons | ||
191 | forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv me bs | ||
192 | |||
193 | RelayData bs con -> join $ atomically $ do | ||
194 | -- Data: Data packets can only be sent and received if the | ||
195 | -- corresponding connection_id is connection (a Connect notification | ||
196 | -- has been received from it) if the server receives a Data packet for | ||
197 | -- a non connected or existent connection it will discard it. | ||
198 | mySession <- readTVar session | ||
199 | return $ sequence_ $ do | ||
200 | i <- c2key con | ||
201 | sendToThem' <- IntMap.lookup i $ associated mySession | ||
202 | return $ sendToThem' $ RelayData bs | ||
203 | |||
204 | OnionPacket n24 (Addressed addr req) -> do | ||
205 | rpath <- atomically $ do | ||
206 | sym <- transportSymmetric crypto | ||
207 | n <- transportNewNonce crypto | ||
208 | return $ wrapSymmetric sym n (TCPIndex thistcp) NoReturnPath | ||
209 | sendOnion addr $ OnionRequest n24 req rpath | ||
210 | |||
211 | _ -> return () | ||
212 | |||
213 | |||
214 | sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionMessage Encrypted -> IO () | ||
215 | sendTCP_ st addr x = join $ atomically | ||
216 | $ IntMap.lookup addr <$> readTVar st >>= \case | ||
217 | Nothing -> return $ return () | ||
218 | Just send -> return $ send $ OnionPacketResponse x | ||
219 | |||
220 | tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionMessage Encrypted -> IO ()) | ||
221 | tcpRelay udp_addr sendOnion = do | ||
222 | crypto <- newCrypto | ||
223 | cons <- newTVarIO Map.empty | ||
224 | clients <- newTVarIO IntMap.empty | ||
225 | b443 <- getBindAddress "443" True | ||
226 | b80 <- getBindAddress "80" True | ||
227 | b33445 <- getBindAddress "33445" True | ||
228 | bany <- getBindAddress "" True | ||
229 | h <- streamServer ServerConfig | ||
230 | { serverWarn = hPutStrLn stderr | ||
231 | , serverSession = relaySession crypto cons sendOnion | ||
232 | } | ||
233 | [b443,b80,udp_addr,b33445,bany] | ||
234 | return (h,sendTCP_ clients) | ||
235 | |||
diff --git a/dht/src/Network/Tox/Session.hs b/dht/src/Network/Tox/Session.hs new file mode 100644 index 00000000..189967fa --- /dev/null +++ b/dht/src/Network/Tox/Session.hs | |||
@@ -0,0 +1,243 @@ | |||
1 | -- | This module implements the lossless Tox session protocol. | ||
2 | {-# LANGUAGE TupleSections #-} | ||
3 | module Network.Tox.Session | ||
4 | ( SessionParams(..) | ||
5 | , SessionKey | ||
6 | , Session(..) | ||
7 | , sTheirUserKey | ||
8 | , sClose | ||
9 | , handshakeH | ||
10 | ) where | ||
11 | |||
12 | import Control.Concurrent.STM | ||
13 | import Control.Monad | ||
14 | import Control.Exception | ||
15 | import Data.Dependent.Sum | ||
16 | import Data.Functor.Identity | ||
17 | import Data.Word | ||
18 | import Network.Socket (SockAddr) | ||
19 | |||
20 | import Crypto.Tox | ||
21 | import Data.PacketBuffer (PacketInboundEvent (..)) | ||
22 | import Data.Tox.Msg | ||
23 | import DPut | ||
24 | import DebugTag | ||
25 | import Network.Lossless | ||
26 | import Network.QueryResponse | ||
27 | import Network.SessionTransports | ||
28 | import Network.Tox.Crypto.Transport | ||
29 | import Network.Tox.DHT.Transport (Cookie (..), key2id, longTermKey) | ||
30 | import Network.Tox.Handshake | ||
31 | |||
32 | -- | Alias for 'SecretKey' to document that it is used as the temporary Tox | ||
33 | -- session key corresponding to the 'PublicKey' we sent in the handshake. | ||
34 | type SessionKey = SecretKey | ||
35 | |||
36 | -- | These inputs to 'handshakeH' indicate how to respond to handshakes, how to | ||
37 | -- assign packets to sessions, and what to do with established sessions after | ||
38 | -- they are made lossless by queuing packets and appending sequence numbers. | ||
39 | data SessionParams = SessionParams | ||
40 | { -- | The database of secret keys necessary to encrypt handshake packets. | ||
41 | spCrypto :: TransportCrypto | ||
42 | -- | This is used to create sessions and dispatch packets to them. | ||
43 | , spSessions :: Sessions (CryptoPacket Encrypted) | ||
44 | -- | This method returns the session information corresponding to the | ||
45 | -- cookie pair for the remote address. If no handshake was sent, this | ||
46 | -- should send one immediately. It should return 'Nothing' if anything | ||
47 | -- goes wrong. | ||
48 | , spGetSentHandshake :: SecretKey -> SockAddr | ||
49 | -> Cookie Identity | ||
50 | -> Cookie Encrypted | ||
51 | -> IO (Maybe (SessionKey, HandshakeData)) | ||
52 | -- | This method is invoked on each new session and is responsible for | ||
53 | -- launching any threads necessary to keep the session alive. | ||
54 | , spOnNewSession :: Session -> IO () | ||
55 | } | ||
56 | |||
57 | -- | After a session is established, this information is given to the | ||
58 | -- 'spOnNewSession' callback. | ||
59 | data Session = Session | ||
60 | { -- | This is the secret user (toxid) key that corresponds to the | ||
61 | -- local-end of this session. | ||
62 | sOurKey :: SecretKey | ||
63 | -- | The remote address for this session. (Not unique, see 'sSessionID'). | ||
64 | , sTheirAddr :: SockAddr | ||
65 | -- | The information we sent in the handshake for this session. | ||
66 | , sSentHandshake :: HandshakeData | ||
67 | -- | The information we received in a handshake for this session. | ||
68 | , sReceivedHandshake :: Handshake Identity | ||
69 | -- | This method can be used to trigger packets to be re-sent given a | ||
70 | -- list of their sequence numbers. It should be used when the remote end | ||
71 | -- indicates they lost packets. | ||
72 | , sResendPackets :: [Word32] -> IO () | ||
73 | -- | This list of sequence numbers should be periodically polled and if | ||
74 | -- it is not empty, we should request they re-send these packets. For | ||
75 | -- convenience, a lower bound for the numbers in the list is also | ||
76 | -- returned. Suggested polling interval: a few seconds. | ||
77 | , sMissingInbound :: IO ([Word32],Word32) | ||
78 | -- | A lossless transport for sending and receiving packets in this | ||
79 | -- session. It is up to the caller to spawn the await-loop to handle | ||
80 | -- inbound packets. | ||
81 | , sTransport :: Transport String () CryptoMessage | ||
82 | -- | A unique small integer that identifies this session for as long as | ||
83 | -- it is established. | ||
84 | , sSessionID :: Int | ||
85 | } | ||
86 | |||
87 | -- | Helper to obtain the remote ToxID key from the locally-issued cookie | ||
88 | -- associated with the session. | ||
89 | sTheirUserKey :: Session -> PublicKey | ||
90 | sTheirUserKey s = longTermKey $ runIdentity cookie | ||
91 | where | ||
92 | Cookie _ cookie = handshakeCookie (sReceivedHandshake s) | ||
93 | |||
94 | -- | Helper to close the 'Transport' associated with a session. | ||
95 | sClose :: Session -> IO () | ||
96 | sClose s = closeTransport (sTransport s) | ||
97 | |||
98 | |||
99 | -- | Call this whenever a new handshake arrives so that a session is | ||
100 | -- negotiated. It always returns Nothing which makes it convenient to use with | ||
101 | -- 'Network.QueryResponse.addHandler'. | ||
102 | handshakeH :: SessionParams | ||
103 | -> SockAddr | ||
104 | -> Handshake Encrypted | ||
105 | -> IO (Maybe a) | ||
106 | handshakeH sp saddr handshake = do | ||
107 | decryptHandshake (spCrypto sp) handshake | ||
108 | >>= either (\err -> return ()) | ||
109 | (uncurry $ plainHandshakeH sp saddr) | ||
110 | return Nothing | ||
111 | |||
112 | |||
113 | plainHandshakeH :: SessionParams | ||
114 | -> SockAddr | ||
115 | -> SecretKey | ||
116 | -> Handshake Identity | ||
117 | -> IO () | ||
118 | plainHandshakeH sp saddr skey handshake = do | ||
119 | let hd = runIdentity $ handshakeData handshake | ||
120 | prelude = show saddr ++ " --> " | ||
121 | dput XNetCrypto $ unlines $ map (prelude ++) | ||
122 | [ "handshake: auth=" ++ show (handshakeCookie handshake) | ||
123 | , " : issuing=" ++ show (otherCookie hd) | ||
124 | , " : baseNonce=" ++ show (baseNonce hd) | ||
125 | ] | ||
126 | sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd) | ||
127 | -- TODO: this is always returning sent = Nothing | ||
128 | dput XNetCrypto $ " <-- (cached) handshake baseNonce " ++ show (fmap (baseNonce . snd) sent) | ||
129 | forM_ sent $ \(hd_skey,hd_sent) -> do | ||
130 | sk <- SessionKeys (spCrypto sp) | ||
131 | hd_skey | ||
132 | (sessionKey hd) | ||
133 | <$> atomically (newTVar $ baseNonce hd) | ||
134 | <*> atomically (newTVar $ baseNonce hd_sent) | ||
135 | m <- newSession (spSessions sp) (\() p -> return p) (decryptPacket sk) saddr | ||
136 | dput XNetCrypto $ prelude ++ "plainHandshakeH: session " ++ maybe "Nothing" (const "Just") m | ||
137 | forM_ m $ \(sid, t) -> do | ||
138 | (t2,resend,getMissing) | ||
139 | <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp) | ||
140 | (\seqno p@(Pkt m :=> _) _ -> do | ||
141 | y <- encryptPacket sk $ bookKeeping seqno p | ||
142 | return OutgoingInfo | ||
143 | { oIsLossy = lossyness m == Lossy | ||
144 | , oEncoded = y | ||
145 | , oHandleException = Just $ \e -> do | ||
146 | dput XUnexpected $ unlines | ||
147 | [ "<-- " ++ show e | ||
148 | , "<-- while sending " ++ show (seqno,p) ] | ||
149 | throwIO e | ||
150 | }) | ||
151 | () | ||
152 | t | ||
153 | let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted) | ||
154 | _ = t2 :: Transport String () CryptoMessage | ||
155 | sendMessage t2 () $ (Pkt ONLINE ==> ()) | ||
156 | spOnNewSession sp Session | ||
157 | { sOurKey = skey | ||
158 | , sTheirAddr = saddr | ||
159 | , sSentHandshake = hd_sent | ||
160 | , sReceivedHandshake = handshake | ||
161 | , sResendPackets = resend | ||
162 | , sMissingInbound = getMissing | ||
163 | , sTransport = t2 | ||
164 | , sSessionID = sid | ||
165 | } | ||
166 | return () | ||
167 | |||
168 | |||
169 | -- | The per-session nonce and key state maintained by 'decryptPacket' and | ||
170 | -- 'encryptPacket'. | ||
171 | data SessionKeys = SessionKeys | ||
172 | { skCrypto :: TransportCrypto -- ^ Cache of shared-secrets. | ||
173 | , skMe :: SessionKey -- ^ My session key | ||
174 | , skThem :: PublicKey -- ^ Their session key | ||
175 | , skNonceIncoming :: TVar Nonce24 -- ^ +21845 when a threshold is reached. | ||
176 | , skNonceOutgoing :: TVar Nonce24 -- ^ +1 on every packet | ||
177 | } | ||
178 | |||
179 | -- | Decrypt an inbound session packet and update the nonce for the next one. | ||
180 | decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ())) | ||
181 | decryptPacket sk saddr (CryptoPacket n16 ciphered) = do | ||
182 | (n24,δ) <- atomically $ do | ||
183 | n <- readTVar (skNonceIncoming sk) | ||
184 | let δ = n16 - nonce24ToWord16 n | ||
185 | return ( n `addtoNonce24` fromIntegral δ, δ ) | ||
186 | secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 | ||
187 | case decodePlain =<< decrypt secret ciphered of | ||
188 | Left e -> return Nothing | ||
189 | Right x -> do | ||
190 | when ( δ > 43690 ) | ||
191 | $ atomically $ writeTVar (skNonceIncoming sk) (n24 `addtoNonce24` 21845) | ||
192 | |||
193 | do let them = key2id $ skThem sk | ||
194 | CryptoData ack seqno _ = x | ||
195 | cm = decodeRawCryptoMsg x | ||
196 | dput XNetCrypto $ unwords [take 8 (show them),"-->",show (msgID cm),show (n24,ack,seqno)] | ||
197 | |||
198 | return $ Just ( CryptoPacket n16 (pure x), () ) | ||
199 | |||
200 | -- | Encrypt an outbound session packet and update the nonce for the next one. | ||
201 | encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted) | ||
202 | encryptPacket sk plain = do | ||
203 | n24 <- atomically $ do | ||
204 | n24 <- readTVar (skNonceOutgoing sk) | ||
205 | modifyTVar' (skNonceOutgoing sk) incrementNonce24 | ||
206 | return n24 | ||
207 | secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 | ||
208 | let ciphered = encrypt secret $ encodePlain $ plain | ||
209 | |||
210 | do let them = key2id $ skThem sk | ||
211 | CryptoData ack seqno cm = plain | ||
212 | dput XNetCrypto $ unwords [take 8 (show them),"<--",show (msgID cm),show (n24,ack,seqno)] | ||
213 | |||
214 | return $ CryptoPacket (nonce24ToWord16 n24) ciphered | ||
215 | |||
216 | |||
217 | -- | Add sequence information to an outbound packet. | ||
218 | -- | ||
219 | -- From spec.md: | ||
220 | -- | ||
221 | -- Data in the encrypted packets: | ||
222 | -- | ||
223 | -- [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)] | ||
224 | -- [uint32_t packet number if lossless, sendbuffer buffer_end if lossy, (big endian)] | ||
225 | -- [data] | ||
226 | bookKeeping :: SequenceInfo -> CryptoMessage -> CryptoData | ||
227 | bookKeeping (SequenceInfo seqno ack) m = CryptoData | ||
228 | { bufferStart = ack :: Word32 | ||
229 | , bufferEnd = seqno :: Word32 | ||
230 | , bufferData = m | ||
231 | } | ||
232 | |||
233 | -- | Classify an inbound packet as lossy or lossless based on its id byte. | ||
234 | checkLossless :: CryptoData -> PacketInboundEvent CryptoMessage | ||
235 | checkLossless cd@CryptoData{ bufferStart = ack | ||
236 | , bufferEnd = no | ||
237 | , bufferData = x } = tag no x' ack | ||
238 | where | ||
239 | x' = decodeRawCryptoMsg cd | ||
240 | tag = case someLossyness (msgID x') of Lossy -> PacketReceivedLossy | ||
241 | _ -> PacketReceived | ||
242 | |||
243 | |||
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs new file mode 100644 index 00000000..13da804f --- /dev/null +++ b/dht/src/Network/Tox/TCP.hs | |||
@@ -0,0 +1,313 @@ | |||
1 | {-# LANGUAGE RecursiveDo #-} | ||
2 | {-# LANGUAGE PartialTypeSignatures #-} | ||
3 | {-# LANGUAGE LambdaCase #-} | ||
4 | {-# LANGUAGE FlexibleContexts #-} | ||
5 | module Network.Tox.TCP | ||
6 | ( module Network.Tox.TCP | ||
7 | , NodeInfo(..) | ||
8 | ) where | ||
9 | |||
10 | import Debug.Trace | ||
11 | import Control.Arrow | ||
12 | import Control.Concurrent | ||
13 | import Control.Concurrent.STM | ||
14 | import Control.Exception | ||
15 | import Control.Monad | ||
16 | import Crypto.Random | ||
17 | import Data.Aeson (ToJSON(..),FromJSON(..)) | ||
18 | import qualified Data.Aeson as JSON | ||
19 | import Data.Functor.Contravariant | ||
20 | import Data.Functor.Identity | ||
21 | import Data.Hashable | ||
22 | import qualified Data.HashMap.Strict as HashMap | ||
23 | import Data.IP | ||
24 | import Data.Maybe | ||
25 | import Data.Monoid | ||
26 | import Data.Serialize | ||
27 | import Data.Word | ||
28 | import qualified Data.Vector as Vector | ||
29 | import Network.Socket (SockAddr(..)) | ||
30 | import qualified Text.ParserCombinators.ReadP as RP | ||
31 | import System.IO.Error | ||
32 | import System.Timeout | ||
33 | |||
34 | import ControlMaybe | ||
35 | import Crypto.Tox | ||
36 | import Data.ByteString (hPut,hGet,ByteString,length) | ||
37 | import Data.TableMethods | ||
38 | import Data.Tox.Relay | ||
39 | import qualified Data.Word64Map | ||
40 | import DebugTag | ||
41 | import DPut | ||
42 | import Network.Address (setPort,PortNumber,localhost4,fromSockAddr) | ||
43 | import Network.Kademlia.Routing | ||
44 | import Network.Kademlia.Search hiding (sendQuery) | ||
45 | import Network.QueryResponse | ||
46 | import Network.QueryResponse.TCP | ||
47 | import Network.Tox.DHT.Handlers (toxSpace) | ||
48 | import Network.Tox.Onion.Transport hiding (encrypt,decrypt) | ||
49 | import Network.Tox.Onion.Handlers (unwrapAnnounceResponse) | ||
50 | import qualified Network.Tox.NodeId as UDP | ||
51 | |||
52 | |||
53 | withSize :: Sized x => (Size x -> m (p x)) -> m (p x) | ||
54 | withSize f = case size of len -> f len | ||
55 | |||
56 | |||
57 | type NodeId = UDP.NodeId | ||
58 | |||
59 | -- example: | ||
60 | -- KEyW2Bm.S-DpIGp72380BAfgintUWX1KX.6ZU.4m5Ex@80.99.99.99:33400{tcp:443} | ||
61 | instance Show NodeInfo where | ||
62 | show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}" | ||
63 | |||
64 | nodeId :: NodeInfo -> NodeId | ||
65 | nodeId ni = UDP.nodeId $ udpNodeInfo ni | ||
66 | |||
67 | nodeAddr :: NodeInfo -> SockAddr | ||
68 | nodeAddr ni = setPort (tcpPort ni) $ UDP.nodeAddr $ udpNodeInfo ni | ||
69 | |||
70 | nodeIP :: NodeInfo -> IP | ||
71 | nodeIP ni = UDP.nodeIP $ udpNodeInfo ni | ||
72 | |||
73 | tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) => | ||
74 | TransportCrypto -> StreamHandshake NodeInfo x y | ||
75 | tcpStream crypto = StreamHandshake | ||
76 | { streamHello = \addr h -> do | ||
77 | (skey, hello) <- atomically $ do | ||
78 | n24 <- transportNewNonce crypto | ||
79 | skey <- transportNewKey crypto | ||
80 | base24 <- transportNewNonce crypto | ||
81 | return $ (,) skey $ Hello $ Asymm | ||
82 | { senderKey = transportPublic crypto | ||
83 | , asymmNonce = n24 | ||
84 | , asymmData = pure HelloData | ||
85 | { sessionPublicKey = toPublic $ skey | ||
86 | , sessionBaseNonce = base24 | ||
87 | } | ||
88 | } | ||
89 | noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr) | ||
90 | dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello | ||
91 | hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello | ||
92 | welcomeE <- withSize $ fmap decode . hGet h . constSize | ||
93 | let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w | ||
94 | nil = SessionProtocol | ||
95 | { streamGoodbye = return () | ||
96 | , streamDecode = return Nothing | ||
97 | , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y | ||
98 | } | ||
99 | either (\_ -> return nil) id $ mwelcome <&> \welcome -> do | ||
100 | dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome | ||
101 | noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome) | ||
102 | nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello) | ||
103 | nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome) | ||
104 | let them = sessionPublicKey $ runIdentity $ welcomeData welcome | ||
105 | hvar <- newMVar h | ||
106 | return SessionProtocol | ||
107 | { streamGoodbye = do | ||
108 | dput XTCP $ "Closing " ++ show addr | ||
109 | return () -- No goodbye packet? Seems rude. | ||
110 | , streamDecode = | ||
111 | let go h = decode <$> hGet h 2 >>= \case | ||
112 | Left e -> do | ||
113 | dput XTCP $ "TCP: (" ++ show addr ++ ") Failed to get length: " ++ e | ||
114 | return Nothing | ||
115 | Right len -> do | ||
116 | decode <$> hGet h (fromIntegral (len :: Word16)) >>= \case | ||
117 | Left e -> do | ||
118 | dput XTCP $ "TCP: Failed to decode packet." | ||
119 | return Nothing | ||
120 | Right x -> do | ||
121 | m24 <- timeout 1000000 (takeMVar nread) | ||
122 | fmap join $ forM m24 $ \n24 -> do | ||
123 | let r = decrypt (noncef' n24) x >>= decodePlain | ||
124 | putMVar nread (incrementNonce24 n24) | ||
125 | either (dput XTCP . ("TCP decryption: " ++)) | ||
126 | (\x' -> do | ||
127 | dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x' | ||
128 | return ()) | ||
129 | r | ||
130 | return $ either (const Nothing) Just r | ||
131 | in bracket (takeMVar hvar) (putMVar hvar) | ||
132 | $ \h -> go h `catchIOError` \e -> do | ||
133 | dput XTCP $ "TCP exception: " ++ show e | ||
134 | return Nothing | ||
135 | , streamEncode = \y -> do | ||
136 | dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y | ||
137 | n24 <- takeMVar nsend | ||
138 | dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y | ||
139 | let bs = encode $ encrypt (noncef' n24) $ encodePlain y | ||
140 | ($ h) -- bracket (takeMVar hvar) (putMVar hvar) | ||
141 | $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs) | ||
142 | `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e | ||
143 | dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y | ||
144 | putMVar nsend (incrementNonce24 n24) | ||
145 | dput XTCP $ "TCP(finished): " ++ show addr ++ " <-- " ++ show y | ||
146 | } | ||
147 | , streamAddr = nodeAddr | ||
148 | } | ||
149 | |||
150 | toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol RelayPacket RelayPacket) | ||
151 | , TransportA err NodeInfo RelayPacket (Bool,RelayPacket) ) | ||
152 | toxTCP crypto = tcpTransport 30 (tcpStream crypto) | ||
153 | |||
154 | tcpSpace :: KademliaSpace NodeId NodeInfo | ||
155 | tcpSpace = contramap udpNodeInfo toxSpace | ||
156 | |||
157 | {- | ||
158 | nodeSearch :: TCPClient err () Nonce8 -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo | ||
159 | nodeSearch tcp = Search | ||
160 | { searchSpace = tcpSpace | ||
161 | , searchNodeAddress = nodeIP &&& tcpPort | ||
162 | , searchQuery = getNodes tcp | ||
163 | } | ||
164 | -} | ||
165 | |||
166 | data TCPClient err tid = TCPClient | ||
167 | { tcpCrypto :: TransportCrypto | ||
168 | , tcpClient :: Client err PacketNumber tid NodeInfo (Bool,RelayPacket) | ||
169 | , tcpGetGateway :: UDP.NodeInfo -> STM (Maybe NodeInfo) | ||
170 | } | ||
171 | |||
172 | {- | ||
173 | getTCPNodes :: TCPClient err () Nonce8 -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | ||
174 | getTCPNodes tcp seeking dst = do | ||
175 | r <- getUDPNodes' tcp seeking (udpNodeInfo dst) | ||
176 | let tcps (ns,_,mb) = (ns',ns',mb) | ||
177 | where ns' = do | ||
178 | n <- ns | ||
179 | [ NodeInfo n (fromIntegral 443) , NodeInfo n (fromIntegral 80) , NodeInfo n (UDP.nodePort n) ] | ||
180 | fmap join $ forM r $ \(ns,gw) -> do | ||
181 | let ts = tcps ns | ||
182 | {- | ||
183 | if nodeId gw == nodeId dst | ||
184 | then return $ Just ts | ||
185 | else do | ||
186 | forkIO $ void $ tcpPing (tcpClient tcp) dst | ||
187 | return $ Just ts | ||
188 | -} | ||
189 | forM_ ((\(xs,_,_) -> xs) ts) (forkIO . void . tcpPing (tcpClient tcp)) | ||
190 | return $ Just ts | ||
191 | -} | ||
192 | |||
193 | getUDPNodes :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ())) | ||
194 | getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst | ||
195 | |||
196 | getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo)) | ||
197 | getUDPNodes' tcp seeking dst0 = do | ||
198 | mgateway <- atomically $ tcpGetGateway tcp dst0 | ||
199 | fmap join $ forM mgateway $ \gateway -> do | ||
200 | (b,c,n24) <- atomically $ do | ||
201 | b <- transportNewKey (tcpCrypto tcp) | ||
202 | c <- transportNewKey (tcpCrypto tcp) | ||
203 | n24 <- transportNewNonce (tcpCrypto tcp) | ||
204 | return (b,c,n24) | ||
205 | let (dst,gateway') = if UDP.nodeId dst0 == nodeId gateway | ||
206 | then ( dst0 { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 } | ||
207 | , gateway { udpNodeInfo = (udpNodeInfo gateway) | ||
208 | { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 }}) | ||
209 | else (dst0,gateway) | ||
210 | wrap2 <- lookupNonceFunction (tcpCrypto tcp) b (UDP.id2key $ UDP.nodeId dst) | ||
211 | wrap1 <- lookupNonceFunction (tcpCrypto tcp) c (UDP.id2key $ nodeId gateway) | ||
212 | wrap0 <- lookupNonceFunction (tcpCrypto tcp) (transportSecret $ tcpCrypto tcp) (UDP.id2key $ UDP.nodeId dst) | ||
213 | let meth :: MethodSerializer | ||
214 | Nonce8 | ||
215 | a -- NodeInfo | ||
216 | (Bool, RelayPacket) | ||
217 | PacketNumber | ||
218 | AnnounceRequest | ||
219 | (Either String AnnounceResponse) | ||
220 | meth = MethodSerializer | ||
221 | { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout | ||
222 | , method = OnionPacketID -- meth | ||
223 | , wrapQuery = \n8 src gateway x -> (,) True $ | ||
224 | OnionPacket n24 $ Addressed (UDP.nodeAddr dst) | ||
225 | $ wrapOnionPure b (wrap2 n24) (nodeAddr gateway') | ||
226 | $ wrapOnionPure c (wrap1 n24) (UDP.nodeAddr dst) | ||
227 | $ NotForwarded $ encryptPayload (wrap0 n24) | ||
228 | $ OnionAnnounce Asymm | ||
229 | { senderKey = transportPublic (tcpCrypto tcp) | ||
230 | , asymmNonce = n24 | ||
231 | , asymmData = pure (x,n8) | ||
232 | } | ||
233 | , unwrapResponse = \case | ||
234 | (_,OnionPacketResponse (OnionAnnounceResponse _ n24' r)) | ||
235 | -> decrypt (wrap0 n24') r >>= decodePlain | ||
236 | x -> Left $ "getUDPNodes: unwrapResponse fail " ++ show x | ||
237 | } | ||
238 | r <- sendQuery (tcpClient tcp) meth (AnnounceRequest zeros32 seeking UDP.zeroID) gateway | ||
239 | forM r $ \response -> do | ||
240 | let (ns,_,mb) = either (const ([],[],Nothing)) (unwrapAnnounceResponse Nothing dst) $ response | ||
241 | return ( (ns,ns, const () <$> mb), gateway ) | ||
242 | |||
243 | |||
244 | handleOOB :: PublicKey -> ByteString -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x)) | ||
245 | handleOOB k bs src dst = do | ||
246 | dput XMisc $ "TODO: handleOOB " ++ show src | ||
247 | return Nothing | ||
248 | |||
249 | handle2route :: OnionMessage Encrypted -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x)) | ||
250 | handle2route o src dst = do | ||
251 | dput XMisc $ "TODO: handle2route " ++ show src | ||
252 | return Nothing | ||
253 | |||
254 | tcpPing :: Show addr => Client err PacketNumber Nonce8 addr (Bool,RelayPacket) -> addr -> IO (Maybe ()) | ||
255 | tcpPing client dst = do | ||
256 | dput XTCP $ "tcpPing " ++ show dst | ||
257 | sendQuery client meth () dst | ||
258 | where meth = MethodSerializer | ||
259 | { wrapQuery = \n8 src dst () -> (True,RelayPing n8) | ||
260 | , unwrapResponse = \_ -> () | ||
261 | , methodTimeout = \n8 dst -> return (dst,5000000) | ||
262 | , method = PingPacket | ||
263 | } | ||
264 | |||
265 | type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket) | ||
266 | |||
267 | -- | Create a new TCP relay client. Because polymorphic existential record | ||
268 | -- updates are currently hard with GHC, this function accepts parameters for | ||
269 | -- generalizing the table-entry type for pending transactions. Safe trivial | ||
270 | -- defaults are 'id' and 'tryPutMVar'. The resulting customized table state | ||
271 | -- will be returned to the caller along with the new client. | ||
272 | newClient :: TransportCrypto | ||
273 | -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a) -- ^ store mvar for query | ||
274 | -> (a -> RelayPacket -> IO void) -- ^ load mvar for query | ||
275 | -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a) | ||
276 | , TCPCache (SessionProtocol RelayPacket RelayPacket) ) | ||
277 | , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)) | ||
278 | newClient crypto store load = do | ||
279 | (tcpcache,net) <- toxTCP crypto | ||
280 | drg <- drgNew | ||
281 | map_var <- atomically $ newTVar (drg, Data.Word64Map.empty) | ||
282 | return $ (,) (map_var,tcpcache) Client | ||
283 | { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net | ||
284 | , clientDispatcher = DispatchMethods | ||
285 | { classifyInbound = (. snd) $ \case | ||
286 | RelayPing n -> IsQuery PingPacket n | ||
287 | RelayPong n -> IsResponse n | ||
288 | OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8 | ||
289 | OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o | ||
290 | OOBRecv k bs -> IsUnsolicited $ handleOOB k bs | ||
291 | wut -> IsUnknown (show wut) | ||
292 | , lookupHandler = \case | ||
293 | PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler | ||
294 | { methodParse = \case (_,RelayPing n8) -> Right () | ||
295 | _ -> trace ("tcp-non-ping") $ Left "TCP: Non-ping?" | ||
296 | , methodSerialize = \n8 src dst () -> trace ("tcp-made-pong-"++show n8) (False, RelayPong n8) | ||
297 | , methodAction = \src () -> dput XTCP $ "TCP pinged by "++show src | ||
298 | } | ||
299 | w -> trace ("tcp-lookupHandler: "++show w) $ Just NoReply | ||
300 | { methodParse = \x -> Left "tcp-lookuphandler?" -- :: x -> Either err a | ||
301 | , noreplyAction = \addr a -> dput XTCP $ "tcp-lookupHandler: "++show w | ||
302 | } | ||
303 | , tableMethods = transactionMethods' store (\x -> mapM_ (load x . snd)) (contramap (\(Nonce8 w64) -> w64) w64MapMethods) | ||
304 | $ first (either error Nonce8 . decode) . randomBytesGenerate 8 | ||
305 | } | ||
306 | , clientErrorReporter = logErrors | ||
307 | , clientPending = map_var | ||
308 | , clientAddress = \_ -> return $ NodeInfo | ||
309 | { udpNodeInfo = either error id $ UDP.nodeInfo (UDP.key2id $ transportPublic crypto) (SockAddrInet 0 0) | ||
310 | , tcpPort = 0 | ||
311 | } | ||
312 | , clientResponseId = return | ||
313 | } | ||
diff --git a/dht/src/Network/Tox/Transport.hs b/dht/src/Network/Tox/Transport.hs new file mode 100644 index 00000000..217d5b1d --- /dev/null +++ b/dht/src/Network/Tox/Transport.hs | |||
@@ -0,0 +1,86 @@ | |||
1 | {-# LANGUAGE DataKinds #-} | ||
2 | {-# LANGUAGE GADTs #-} | ||
3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
4 | {-# LANGUAGE KindSignatures #-} | ||
5 | {-# LANGUAGE LambdaCase #-} | ||
6 | {-# LANGUAGE ScopedTypeVariables #-} | ||
7 | {-# LANGUAGE TupleSections #-} | ||
8 | {-# LANGUAGE TypeOperators #-} | ||
9 | module Network.Tox.Transport (toxTransport, RouteId) where | ||
10 | |||
11 | import Network.QueryResponse | ||
12 | import Crypto.Tox | ||
13 | import Data.Tox.Relay as TCP | ||
14 | import Network.Tox.DHT.Transport as UDP | ||
15 | import Network.Tox.Onion.Transport | ||
16 | import Network.Tox.Crypto.Transport | ||
17 | import OnionRouter | ||
18 | |||
19 | import Network.Socket | ||
20 | |||
21 | toxTransport :: | ||
22 | TransportCrypto | ||
23 | -> OnionRouter | ||
24 | -> (PublicKey -> IO (Maybe UDP.NodeInfo)) | ||
25 | -> UDPTransport | ||
26 | -> (TCP.NodeInfo -> RelayPacket -> IO ()) -- ^ TCP server-bound callback. | ||
27 | -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback. | ||
28 | -> IO ( Transport String SockAddr (CryptoPacket Encrypted) | ||
29 | , Transport String UDP.NodeInfo (DHTMessage Encrypted8) | ||
30 | , Transport String (OnionDestination RouteId) (OnionMessage Encrypted) | ||
31 | , Transport String AnnouncedRendezvous (PublicKey,OnionData) | ||
32 | , Transport String SockAddr (Handshake Encrypted)) | ||
33 | toxTransport crypto orouter closeLookup udp tcp2server tcp2client = do | ||
34 | (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp | ||
35 | (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) | ||
36 | $ forwardOnions crypto udp0 tcp2client | ||
37 | (onion1,udp2) <- partitionAndForkTransport tcp2server | ||
38 | (parseOnionAddr $ lookupSender orouter) | ||
39 | (encodeOnionAddr crypto $ lookupRoute orouter) | ||
40 | udp1 | ||
41 | (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1 | ||
42 | let handshakes = layerTransport parseHandshakes encodeHandshakes udp2 | ||
43 | return ( netcrypto | ||
44 | , forwardDHTRequests crypto closeLookup dht | ||
45 | , onion | ||
46 | , dta | ||
47 | , handshakes | ||
48 | ) | ||
49 | |||
50 | |||
51 | -- instance (Sized a, Sized b) => Sized (a,b) where size = _todo | ||
52 | |||
53 | |||
54 | -- Byte value Packet Kind Return address | ||
55 | -- :----------- :-------------------- | ||
56 | -- `0x00` Ping Request DHTNode | ||
57 | -- `0x01` Ping Response - | ||
58 | -- `0x02` Nodes Request DHTNode | ||
59 | -- `0x04` Nodes Response - | ||
60 | -- `0x18` Cookie Request DHTNode, but without sending pubkey in response | ||
61 | -- `0x19` Cookie Response - (no pubkey) | ||
62 | -- | ||
63 | -- `0x21` LAN Discovery DHTNode (No reply, port 33445, trigger Nodes Request/Response) | ||
64 | -- | ||
65 | -- `0x20` DHT Request DHTNode/-forward | ||
66 | -- | ||
67 | -- `0x1a` Crypto Handshake CookieAddress | ||
68 | -- | ||
69 | -- `0x1b` Crypto Data SessionAddress | ||
70 | -- | ||
71 | -- `0x83` Announce Request OnionToOwner | ||
72 | -- `0x84` Announce Response - | ||
73 | -- `0x85` Onion Data Request OnionToOwner | ||
74 | -- `0x86` Onion Data Response - | ||
75 | -- | ||
76 | -- `0xf0` Bootstrap Info SockAddr? | ||
77 | -- | ||
78 | -- `0x80` Onion Request 0 -forward | ||
79 | -- `0x81` Onion Request 1 -forward | ||
80 | -- `0x82` Onion Request 2 -forward | ||
81 | -- `0x8c` Onion Response 3 -return | ||
82 | -- `0x8d` Onion Response 2 -return | ||
83 | -- `0x8e` Onion Response 1 -return | ||
84 | |||
85 | |||
86 | |||
diff --git a/dht/src/Network/UPNP.hs b/dht/src/Network/UPNP.hs new file mode 100644 index 00000000..01d222bf --- /dev/null +++ b/dht/src/Network/UPNP.hs | |||
@@ -0,0 +1,40 @@ | |||
1 | module Network.UPNP where | ||
2 | |||
3 | import Data.Maybe | ||
4 | import Network.Address (sockAddrPort) | ||
5 | import Network.Socket | ||
6 | import System.Directory | ||
7 | import System.Process as Process | ||
8 | import DPut | ||
9 | import DebugTag | ||
10 | |||
11 | protocols :: SocketType -> [String] | ||
12 | protocols Stream = ["tcp"] | ||
13 | protocols Datagram = ["udp"] | ||
14 | protocols _ = ["udp","tcp"] | ||
15 | |||
16 | upnpc :: FilePath | ||
17 | upnpc = "/usr/bin/upnpc" | ||
18 | |||
19 | -- | Invokes the miniupnpc command line program to request ports from a UPNP | ||
20 | -- wifi router. Returns the process handle on success. | ||
21 | requestPorts :: String -- ^ Description stored on router. | ||
22 | -> [(SocketType, SockAddr)] -- ^ Protocol-port pairs to request. | ||
23 | -> IO (Maybe ProcessHandle) | ||
24 | requestPorts description binds = do | ||
25 | let requests = do | ||
26 | (stype,saddr) <- binds | ||
27 | proto <- protocols stype | ||
28 | port <- maybeToList (sockAddrPort saddr) | ||
29 | [ show port, proto ] | ||
30 | bail = return Nothing | ||
31 | case requests of | ||
32 | [] -> bail | ||
33 | _ -> do | ||
34 | gotMiniUPNPC <- doesFileExist upnpc | ||
35 | if gotMiniUPNPC then do | ||
36 | phandle <- spawnProcess upnpc $ "-e": description : "-r" : requests | ||
37 | return $ Just phandle | ||
38 | else do | ||
39 | dput XMisc $ "Warning: unable to find miniupnpc client at "++upnpc++"." | ||
40 | bail | ||