summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/DHT
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent/DHT')
-rw-r--r--src/Network/BitTorrent/DHT/ContactInfo.hs254
-rw-r--r--src/Network/BitTorrent/DHT/Readme.md13
-rw-r--r--src/Network/BitTorrent/DHT/Token.hs201
3 files changed, 0 insertions, 468 deletions
diff --git a/src/Network/BitTorrent/DHT/ContactInfo.hs b/src/Network/BitTorrent/DHT/ContactInfo.hs
deleted file mode 100644
index ec7e6658..00000000
--- a/src/Network/BitTorrent/DHT/ContactInfo.hs
+++ /dev/null
@@ -1,254 +0,0 @@
1{-# LANGUAGE BangPatterns #-}
2module 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
12import Control.Applicative
13import Data.Default
14import Data.List as L
15import Data.Maybe
16import Data.HashMap.Strict as HM
17import Data.Serialize
18import Data.Semigroup
19import Data.Wrapper.PSQ as PSQ
20import Data.Time.Clock.POSIX
21import Data.ByteString (ByteString)
22import Data.Word
23
24import Data.Torrent
25import 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.
121newtype PeerStore = PeerStore (HashMap InfoHash SwarmData)
122
123type Timestamp = POSIXTime
124
125data 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.
134newtype SerializeAddress a = SerializeAddress { unserializeAddress :: a }
135
136instance 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
153instance 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
169knownSwarms :: PeerStore -> [ (InfoHash, Int, Maybe ByteString) ]
170knownSwarms (PeerStore m) = L.map (\(ih,SwarmData q n) -> (ih,PSQ.size q,n)) $ HM.toList m
171
172swarmSingleton :: PeerAddr -> SwarmData
173swarmSingleton a = SwarmData
174 { peers = PSQ.singleton a 0
175 , name = Nothing }
176
177swarmInsert :: SwarmData -> SwarmData -> SwarmData
178swarmInsert 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
185isSwarmOccupied :: SwarmData -> Bool
186isSwarmOccupied SwarmData{..} = not $ PSQ.null peers
187
188-- | Empty store.
189instance Default (PeerStore) where
190 def = PeerStore HM.empty
191 {-# INLINE def #-}
192
193instance Semigroup PeerStore where
194 PeerStore a <> PeerStore b =
195 PeerStore (HM.unionWith swarmInsert a b)
196 {-# INLINE (<>) #-}
197
198-- | Monoid under union operation.
199instance 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.
209instance 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.
214lookup :: InfoHash -> PeerStore -> [PeerAddr]
215lookup ih (PeerStore m) = maybe [] (PSQ.keys . peers) $ HM.lookup ih m
216
217batchSize :: Int
218batchSize = 64
219
220-- | Used in 'get_peers' DHT queries.
221freshPeers :: InfoHash -> Timestamp -> PeerStore -> ([PeerAddr], PeerStore)
222freshPeers 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
232incomp :: (x -> Maybe (r,x)) -> x -> Maybe ((r,x),x)
233incomp !f !x = do
234 (result,x') <- f x
235 pure $! ( (result,x'), x' )
236
237-- | Used in 'announce_peer' DHT queries.
238insertPeer :: InfoHash -> Maybe ByteString -> PeerAddr -> PeerStore -> PeerStore
239insertPeer !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
244deleteOlderThan :: POSIXTime -> PeerStore -> PeerStore
245deleteOlderThan 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/src/Network/BitTorrent/DHT/Readme.md b/src/Network/BitTorrent/DHT/Readme.md
deleted file mode 100644
index e2352f10..00000000
--- a/src/Network/BitTorrent/DHT/Readme.md
+++ /dev/null
@@ -1,13 +0,0 @@
1References
2==========
3
4Some 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/src/Network/BitTorrent/DHT/Token.hs b/src/Network/BitTorrent/DHT/Token.hs
deleted file mode 100644
index 171cc8be..00000000
--- a/src/Network/BitTorrent/DHT/Token.hs
+++ /dev/null
@@ -1,201 +0,0 @@
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 #-}
21module 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
47import Control.Arrow
48import Control.Monad.State
49#ifdef VERSION_bencoding
50import Data.BEncode (BEncode)
51#endif
52import Data.ByteString as BS
53import Data.ByteString.Char8 as B8
54import Data.ByteString.Lazy as BL
55import Data.ByteString.Lazy.Builder as BS
56import qualified Data.ByteString.Base16 as Base16
57import Data.Default
58import Data.List as L
59import Data.Hashable
60import Data.String
61import Data.Time
62import System.Random
63import Control.Concurrent.STM
64
65-- TODO use ShortByteString
66
67-- | An opaque value.
68newtype Token = Token BS.ByteString
69 deriving ( Eq, IsString
70#ifdef VERSION_bencoding
71 , BEncode
72#endif
73 )
74
75instance Show Token where
76 show (Token bs) = B8.unpack $ Base16.encode bs
77
78instance Read Token where
79 readsPrec i s = pure $ (Token *** B8.unpack) $ Base16.decode (B8.pack s)
80
81-- | Meaningless token, for testing purposes only.
82instance 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.
89toPaddedByteString :: Int -> Token -> BS.ByteString
90toPaddedByteString n (Token bs) = BS.append (BS.replicate (n - BS.length bs) 0x20) bs
91
92fromPaddedByteString :: Int -> BS.ByteString -> Token
93fromPaddedByteString 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.
98type Secret = Int
99
100-- The BitTorrent implementation uses the SHA1 hash of the IP address
101-- concatenated onto a secret, we use hashable instead.
102makeToken :: Hashable a => a -> Secret -> Token
103makeToken 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.
109data 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.
120tokens :: Int -> TokenMap
121tokens 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.
130lookup :: Hashable a => a -> TokenMap -> Token
131lookup 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.
138member :: Hashable a => a -> Token -> TokenMap -> Bool
139member 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.
144defaultUpdateInterval :: NominalDiffTime
145defaultUpdateInterval = 5 * 60
146
147-- | Update current tokens.
148update :: TokenMap -> TokenMap
149update TokenMap {..} = TokenMap
150 { prevSecret = curSecret
151 , curSecret = newSecret
152 , generator = newGen
153 }
154 where
155 (newSecret, newGen) = next generator
156
157data SessionTokens = SessionTokens
158 { tokenMap :: !TokenMap
159 , lastUpdate :: !UTCTime
160 , maxInterval :: !NominalDiffTime
161 }
162
163nullSessionTokens :: IO SessionTokens
164nullSessionTokens = SessionTokens
165 <$> (tokens <$> randomIO)
166 <*> getCurrentTime
167 <*> pure defaultUpdateInterval
168
169-- TODO invalidate *twice* if needed
170invalidateTokens :: UTCTime -> SessionTokens -> SessionTokens
171invalidateTokens 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
183tryUpdateSecret :: TVar SessionTokens -> IO ()
184tryUpdateSecret toks = do
185 curTime <- getCurrentTime
186 atomically $ modifyTVar' toks (invalidateTokens curTime)
187
188grantToken :: Hashable addr => TVar SessionTokens -> addr -> IO Token
189grantToken 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.
196checkToken :: Hashable addr => TVar SessionTokens -> addr -> Token -> IO Bool
197checkToken sessionTokens addr questionableToken = do
198 tryUpdateSecret sessionTokens
199 toks <- readTVarIO sessionTokens
200 return $ member addr questionableToken (tokenMap toks)
201
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-13 17:36:32 +0000