diff options
-rw-r--r-- | bittorrent.cabal | 2 | ||||
-rw-r--r-- | tests/Network/BitTorrent/DHT/MessageSpec.hs | 38 | ||||
-rw-r--r-- | tests/Network/BitTorrent/DHT/QuerySpec.hs | 6 | ||||
-rw-r--r-- | tests/Network/BitTorrent/DHT/RoutingSpec.hs | 15 | ||||
-rw-r--r-- | tests/Network/BitTorrent/DHT/SessionSpec.hs | 11 | ||||
-rw-r--r-- | tests/Network/BitTorrent/DHTSpec.hs | 6 |
6 files changed, 40 insertions, 38 deletions
diff --git a/bittorrent.cabal b/bittorrent.cabal index b82599b8..0fddf5d0 100644 --- a/bittorrent.cabal +++ b/bittorrent.cabal | |||
@@ -298,7 +298,6 @@ test-suite spec | |||
298 | 298 | ||
299 | -- * Bittorrent | 299 | -- * Bittorrent |
300 | , bencoding | 300 | , bencoding |
301 | , krpc >= 0.6.1 | ||
302 | , bittorrent | 301 | , bittorrent |
303 | , temporary | 302 | , temporary |
304 | if flag(network-uri) | 303 | if flag(network-uri) |
@@ -335,7 +334,6 @@ benchmark bench | |||
335 | , mtl | 334 | , mtl |
336 | , monad-logger | 335 | , monad-logger |
337 | , criterion | 336 | , criterion |
338 | , krpc | ||
339 | ghc-options: -O2 -fforce-recomp | 337 | ghc-options: -O2 -fforce-recomp |
340 | 338 | ||
341 | -- Utility to work with torrent files. | 339 | -- Utility to work with torrent files. |
diff --git a/tests/Network/BitTorrent/DHT/MessageSpec.hs b/tests/Network/BitTorrent/DHT/MessageSpec.hs index ae9ab487..3b1f5acd 100644 --- a/tests/Network/BitTorrent/DHT/MessageSpec.hs +++ b/tests/Network/BitTorrent/DHT/MessageSpec.hs | |||
@@ -61,16 +61,16 @@ spec = do | |||
61 | running <- retry 5 $ timeout (100 * 1000) $ do | 61 | running <- retry 5 $ timeout (100 * 1000) $ do |
62 | nid <- genNodeId | 62 | nid <- genNodeId |
63 | Response _remoteAddr Ping <- | 63 | Response _remoteAddr Ping <- |
64 | rpc (query remoteAddr (Query nid Ping)) | 64 | rpc (query remoteAddr (Query nid False Ping)) |
65 | return () | 65 | return () |
66 | running `shouldSatisfy` isJust | 66 | running `shouldSatisfy` isJust |
67 | 67 | ||
68 | describe "ping" $ do | 68 | describe "ping" $ do |
69 | it "properly bencoded" $ do | 69 | it "properly bencoded" $ do |
70 | BE.decode "d2:id20:abcdefghij0123456789e" | 70 | BE.decode "d2:id20:abcdefghij0123456789e" |
71 | `shouldBe` Right (Query "abcdefghij0123456789" Ping) | 71 | `shouldBe` Right (Query "abcdefghij0123456789" False Ping) |
72 | 72 | ||
73 | BE.encode (Query "abcdefghij0123456789" Ping) | 73 | BE.encode (Query "abcdefghij0123456789" False Ping) |
74 | `shouldBe` "d2:id20:abcdefghij0123456789e" | 74 | `shouldBe` "d2:id20:abcdefghij0123456789e" |
75 | 75 | ||
76 | BE.decode "d2:id20:mnopqrstuvwxyz123456e" | 76 | BE.decode "d2:id20:mnopqrstuvwxyz123456e" |
@@ -80,22 +80,22 @@ spec = do | |||
80 | `shouldBe` "d2:id20:mnopqrstuvwxyz123456e" | 80 | `shouldBe` "d2:id20:mnopqrstuvwxyz123456e" |
81 | 81 | ||
82 | it "properly bencoded (iso)" $ property $ \ nid -> do | 82 | it "properly bencoded (iso)" $ property $ \ nid -> do |
83 | prop_bencode (Query nid Ping) | 83 | prop_bencode (Query nid False Ping) |
84 | prop_bencode (Response nid Ping) | 84 | prop_bencode (Response nid Ping) |
85 | 85 | ||
86 | it "does compatible with existing DHT" $ do | 86 | it "does compatible with existing DHT" $ do |
87 | nid <- genNodeId | 87 | nid <- genNodeId |
88 | Response _remoteAddr Ping <- rpc (query remoteAddr (Query nid Ping)) | 88 | Response _remoteAddr Ping <- rpc (query remoteAddr (Query nid False Ping)) |
89 | return () | 89 | return () |
90 | 90 | ||
91 | describe "find_node" $ do | 91 | describe "find_node" $ do |
92 | it "properly bencoded" $ do | 92 | it "properly bencoded" $ do |
93 | BE.decode "d2:id20:abcdefghij0123456789\ | 93 | BE.decode "d2:id20:abcdefghij0123456789\ |
94 | \6:target20:mnopqrstuvwxyz123456e" | 94 | \6:target20:mnopqrstuvwxyz123456e" |
95 | `shouldBe` Right (Query "abcdefghij0123456789" | 95 | `shouldBe` Right (Query "abcdefghij0123456789" False |
96 | (FindNode "mnopqrstuvwxyz123456")) | 96 | (FindNode "mnopqrstuvwxyz123456")) |
97 | 97 | ||
98 | BE.encode (Query "abcdefghij0123456789" | 98 | BE.encode (Query "abcdefghij0123456789" False |
99 | (FindNode "mnopqrstuvwxyz123456")) | 99 | (FindNode "mnopqrstuvwxyz123456")) |
100 | `shouldBe` | 100 | `shouldBe` |
101 | "d2:id20:abcdefghij01234567896:target20:mnopqrstuvwxyz123456e" | 101 | "d2:id20:abcdefghij01234567896:target20:mnopqrstuvwxyz123456e" |
@@ -109,13 +109,13 @@ spec = do | |||
109 | `shouldBe` Right (Response nid (NodeFound [NodeInfo nid' naddr])) | 109 | `shouldBe` Right (Response nid (NodeFound [NodeInfo nid' naddr])) |
110 | 110 | ||
111 | it "properly bencoded (iso)" $ property $ \ nid x xs -> do | 111 | it "properly bencoded (iso)" $ property $ \ nid x xs -> do |
112 | prop_bencode (Query nid (FindNode x)) | 112 | prop_bencode (Query nid False (FindNode x)) |
113 | prop_bencode (Response nid (NodeFound (xs :: [NodeInfo IPv4] ))) | 113 | prop_bencode (Response nid (NodeFound (xs :: [NodeInfo IPv4] ))) |
114 | 114 | ||
115 | it "does compatible with existing DHT" $ do | 115 | it "does compatible with existing DHT" $ do |
116 | nid <- genNodeId | 116 | nid <- genNodeId |
117 | Response _remoteAddr (NodeFound xs) <- rpc $ do | 117 | Response _remoteAddr (NodeFound xs) <- rpc $ do |
118 | query remoteAddr (Query nid (FindNode nid)) | 118 | query remoteAddr (Query nid False (FindNode nid)) |
119 | L.length (xs :: [NodeInfo IPv4]) `shouldSatisfy` (> 0) | 119 | L.length (xs :: [NodeInfo IPv4]) `shouldSatisfy` (> 0) |
120 | 120 | ||
121 | describe "get_peers" $ do | 121 | describe "get_peers" $ do |
@@ -123,7 +123,7 @@ spec = do | |||
123 | BE.decode "d2:id20:abcdefghij0123456789\ | 123 | BE.decode "d2:id20:abcdefghij0123456789\ |
124 | \9:info_hash20:mnopqrstuvwxyz123456\ | 124 | \9:info_hash20:mnopqrstuvwxyz123456\ |
125 | \e" | 125 | \e" |
126 | `shouldBe` Right (Query "abcdefghij0123456789" | 126 | `shouldBe` Right (Query "abcdefghij0123456789" False |
127 | (GetPeers "mnopqrstuvwxyz123456")) | 127 | (GetPeers "mnopqrstuvwxyz123456")) |
128 | 128 | ||
129 | BE.decode "d2:id20:abcdefghij0123456789\ | 129 | BE.decode "d2:id20:abcdefghij0123456789\ |
@@ -147,7 +147,7 @@ spec = do | |||
147 | })) | 147 | })) |
148 | 148 | ||
149 | it "properly bencoded (iso)" $ property $ \ nid topic exs token -> do | 149 | it "properly bencoded (iso)" $ property $ \ nid topic exs token -> do |
150 | prop_bencode (Query nid (GetPeers topic)) | 150 | prop_bencode (Query nid False (GetPeers topic)) |
151 | let _ = exs :: Either [NodeInfo IPv4] [PeerAddr IPv4] | 151 | let _ = exs :: Either [NodeInfo IPv4] [PeerAddr IPv4] |
152 | let nullPeerId paddr = paddr {peerId = Nothing} | 152 | let nullPeerId paddr = paddr {peerId = Nothing} |
153 | let nullPeerIds = either Left (Right . L.map nullPeerId) | 153 | let nullPeerIds = either Left (Right . L.map nullPeerId) |
@@ -156,7 +156,7 @@ spec = do | |||
156 | it "does compatible with existing DHT" $ do | 156 | it "does compatible with existing DHT" $ do |
157 | nid <- genNodeId | 157 | nid <- genNodeId |
158 | Response _remoteId (GotPeers {..}) | 158 | Response _remoteId (GotPeers {..}) |
159 | <- rpc $ query remoteAddr (Query nid (GetPeers def)) | 159 | <- rpc $ query remoteAddr (Query nid False (GetPeers def)) |
160 | let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4] | 160 | let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4] |
161 | either L.length L.length peers `shouldSatisfy` (> 0) | 161 | either L.length L.length peers `shouldSatisfy` (> 0) |
162 | 162 | ||
@@ -167,7 +167,7 @@ spec = do | |||
167 | \4:porti6881e\ | 167 | \4:porti6881e\ |
168 | \5:token8:aoeusnth\ | 168 | \5:token8:aoeusnth\ |
169 | \e" `shouldBe` Right | 169 | \e" `shouldBe` Right |
170 | (Query "abcdefghij0123456789" | 170 | (Query "abcdefghij0123456789" False |
171 | (Announce False "mnopqrstuvwxyz123456" 6881 "aoeusnth")) | 171 | (Announce False "mnopqrstuvwxyz123456" 6881 "aoeusnth")) |
172 | 172 | ||
173 | BE.decode "d2:id20:abcdefghij0123456789\ | 173 | BE.decode "d2:id20:abcdefghij0123456789\ |
@@ -176,7 +176,7 @@ spec = do | |||
176 | \4:porti6881e\ | 176 | \4:porti6881e\ |
177 | \5:token8:aoeusnth\ | 177 | \5:token8:aoeusnth\ |
178 | \e" `shouldBe` Right | 178 | \e" `shouldBe` Right |
179 | (Query "abcdefghij0123456789" | 179 | (Query "abcdefghij0123456789" False |
180 | (Announce True "mnopqrstuvwxyz123456" 6881 "aoeusnth")) | 180 | (Announce True "mnopqrstuvwxyz123456" 6881 "aoeusnth")) |
181 | 181 | ||
182 | 182 | ||
@@ -185,27 +185,27 @@ spec = do | |||
185 | (Response "mnopqrstuvwxyz123456" Announced) | 185 | (Response "mnopqrstuvwxyz123456" Announced) |
186 | 186 | ||
187 | it "properly bencoded (iso)" $ property $ \ nid flag topic port token -> do | 187 | it "properly bencoded (iso)" $ property $ \ nid flag topic port token -> do |
188 | prop_bencode (Query nid (Announce flag topic port token)) | 188 | prop_bencode (Query nid False (Announce flag topic port token)) |
189 | prop_bencode (Response nid (Announced)) | 189 | prop_bencode (Response nid (Announced)) |
190 | 190 | ||
191 | 191 | ||
192 | it "does compatible with existing DHT" $ do | 192 | it "does compatible with existing DHT" $ do |
193 | nid <- genNodeId | 193 | nid <- genNodeId |
194 | Response _remoteId Announced <- rpc $ do | 194 | Response _remoteId Announced <- rpc $ do |
195 | Response _ GotPeers {..} <- query remoteAddr (Query nid (GetPeers def)) | 195 | Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def)) |
196 | let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4] | 196 | let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4] |
197 | query remoteAddr (Query nid (Announce False def thisPort grantedToken)) | 197 | query remoteAddr (Query nid False (Announce False def thisPort grantedToken)) |
198 | return () | 198 | return () |
199 | 199 | ||
200 | it "does fail on invalid token" $ do | 200 | it "does fail on invalid token" $ do |
201 | nid <- genNodeId | 201 | nid <- genNodeId |
202 | (rpc $ do | 202 | (rpc $ do |
203 | Response _ GotPeers {..} <- query remoteAddr (Query nid (GetPeers def)) | 203 | Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def)) |
204 | let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4] | 204 | let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4] |
205 | let invalidToken = "" | 205 | let invalidToken = "" |
206 | let q :: MonadKRPC h m => SockAddr -> Query Announce | 206 | let q :: MonadKRPC h m => SockAddr -> Query Announce |
207 | -> m (Response Announced) | 207 | -> m (Response Announced) |
208 | q = query | 208 | q = query |
209 | q remoteAddr (Query nid (Announce False def thisPort invalidToken))) | 209 | q remoteAddr (Query nid False (Announce False def thisPort invalidToken))) |
210 | `shouldThrow` isQueryError | 210 | `shouldThrow` isQueryError |
211 | return () | 211 | return () |
diff --git a/tests/Network/BitTorrent/DHT/QuerySpec.hs b/tests/Network/BitTorrent/DHT/QuerySpec.hs index 6b3b5485..93f78263 100644 --- a/tests/Network/BitTorrent/DHT/QuerySpec.hs +++ b/tests/Network/BitTorrent/DHT/QuerySpec.hs | |||
@@ -34,7 +34,7 @@ simpleDHT hs m = | |||
34 | getBootInfo :: IO (NodeInfo IPv4) | 34 | getBootInfo :: IO (NodeInfo IPv4) |
35 | getBootInfo = do | 35 | getBootInfo = do |
36 | startAddr <- resolveHostName (L.head defaultBootstrapNodes) | 36 | startAddr <- resolveHostName (L.head defaultBootstrapNodes) |
37 | simpleDHT [] $ pingQ startAddr | 37 | simpleDHT [] $ fmap fst (pingQ startAddr) |
38 | 38 | ||
39 | spec :: Spec | 39 | spec :: Spec |
40 | spec = parallel $ do | 40 | spec = parallel $ do |
@@ -55,14 +55,14 @@ spec = parallel $ do | |||
55 | it "findNode" $ do | 55 | it "findNode" $ do |
56 | startInfo <- getBootInfo | 56 | startInfo <- getBootInfo |
57 | _ <- simpleDHT [] $ do | 57 | _ <- simpleDHT [] $ do |
58 | nid <- asks thisNodeId | 58 | nid <- myNodeIdAccordingTo (read "8.8.8.8:6881") |
59 | findNodeQ nid startInfo | 59 | findNodeQ nid startInfo |
60 | return () | 60 | return () |
61 | 61 | ||
62 | it "getPeers" $ do | 62 | it "getPeers" $ do |
63 | startInfo <- getBootInfo | 63 | startInfo <- getBootInfo |
64 | peers <- simpleDHT [] $ do | 64 | peers <- simpleDHT [] $ do |
65 | nid <- asks thisNodeId | 65 | nid <- myNodeIdAccordingTo (read "8.8.8.8:6881") |
66 | 66 | ||
67 | -- we should not run getPeers query on boot node, because | 67 | -- we should not run getPeers query on boot node, because |
68 | -- it may not support it | 68 | -- it may not support it |
diff --git a/tests/Network/BitTorrent/DHT/RoutingSpec.hs b/tests/Network/BitTorrent/DHT/RoutingSpec.hs index 3077a52a..6c0caad5 100644 --- a/tests/Network/BitTorrent/DHT/RoutingSpec.hs +++ b/tests/Network/BitTorrent/DHT/RoutingSpec.hs | |||
@@ -46,14 +46,17 @@ instance (Arbitrary ip, Eq ip) => Arbitrary (Table ip) where | |||
46 | -- nodes <- vector nodeN | 46 | -- nodes <- vector nodeN |
47 | 47 | ||
48 | node <- arbitrary | 48 | node <- arbitrary |
49 | mt <- runSimulation <$> arbitrary | 49 | mt <- do |
50 | <*> pure (T.insert node table) | 50 | env <- arbitrary |
51 | return $ runSimulation env $ do | ||
52 | (_,t') <- T.insert (currentTime env) (TryInsert node) table | ||
53 | return t' :: Routing ip (Table ip) | ||
51 | --(foldM (flip fillTable) table nodes) | 54 | --(foldM (flip fillTable) table nodes) |
52 | return (fromJust mt) | 55 | return (fromJust mt) |
53 | where | 56 | -- where |
54 | fillTable x t = do | 57 | -- fillTable x t = do |
55 | t' <- T.insert x t | 58 | -- t' <- T.insert x t |
56 | return $ if T.full t' then t else t' | 59 | -- return $ if T.full t' then t else t' |
57 | 60 | ||
58 | spec :: Spec | 61 | spec :: Spec |
59 | spec = do | 62 | spec = do |
diff --git a/tests/Network/BitTorrent/DHT/SessionSpec.hs b/tests/Network/BitTorrent/DHT/SessionSpec.hs index ef844b31..32e4c158 100644 --- a/tests/Network/BitTorrent/DHT/SessionSpec.hs +++ b/tests/Network/BitTorrent/DHT/SessionSpec.hs | |||
@@ -15,6 +15,7 @@ import Network.BitTorrent.Address | |||
15 | import Network.BitTorrent.DHT | 15 | import Network.BitTorrent.DHT |
16 | import Network.BitTorrent.DHT.Message | 16 | import Network.BitTorrent.DHT.Message |
17 | import Network.BitTorrent.DHT.Session | 17 | import Network.BitTorrent.DHT.Session |
18 | import Network.BitTorrent.DHT.Query | ||
18 | 19 | ||
19 | import Data.TorrentSpec () | 20 | import Data.TorrentSpec () |
20 | import Network.BitTorrent.CoreSpec () | 21 | import Network.BitTorrent.CoreSpec () |
@@ -68,7 +69,7 @@ spec = do | |||
68 | property $ \ (nid :: NodeId) -> do | 69 | property $ \ (nid :: NodeId) -> do |
69 | let info = NodeInfo nid myAddr | 70 | let info = NodeInfo nid myAddr |
70 | closest <- simpleDHT $ do | 71 | closest <- simpleDHT $ do |
71 | _ <- insertNode info | 72 | _ <- insertNode info Nothing |
72 | liftIO $ yield | 73 | liftIO $ yield |
73 | getClosest nid | 74 | getClosest nid |
74 | closest `shouldSatisfy` L.elem info | 75 | closest `shouldSatisfy` L.elem info |
@@ -93,15 +94,15 @@ spec = do | |||
93 | it "should always ping this node" $ do | 94 | it "should always ping this node" $ do |
94 | (rid, tid) <- simpleDHT $ do | 95 | (rid, tid) <- simpleDHT $ do |
95 | (remoteId, Ping) <- queryNode myAddr Ping | 96 | (remoteId, Ping) <- queryNode myAddr Ping |
96 | thisId <- asks thisNodeId | 97 | thisId <- myNodeIdAccordingTo (read "8.8.8.8:6881") |
97 | return (remoteId, thisId) | 98 | return (remoteId, thisId) |
98 | rid `shouldBe` tid | 99 | rid `shouldBe` tid |
99 | 100 | ||
100 | describe "queryParallel" $ do | 101 | describe "queryParallel" $ do |
101 | it "should handle parallel requests" $ do | 102 | it "should handle parallel requests" $ do |
102 | (nid, resps) <- simpleDHT $ (,) | 103 | (nid, resps) <- simpleDHT $ do |
103 | <$> asks thisNodeId | 104 | me <- myNodeIdAccordingTo (read "8.8.8.8:6881") |
104 | <*> queryParallel (L.replicate 100 $ queryNode myAddr Ping) | 105 | ( (,) me ) <$> queryParallel (L.replicate 100 $ queryNode myAddr Ping) |
105 | resps `shouldSatisfy` L.all (== (nid, Ping)) | 106 | resps `shouldSatisfy` L.all (== (nid, Ping)) |
106 | 107 | ||
107 | describe "(<@>) operator" $ do | 108 | describe "(<@>) operator" $ do |
diff --git a/tests/Network/BitTorrent/DHTSpec.hs b/tests/Network/BitTorrent/DHTSpec.hs index 30abc867..77160eb5 100644 --- a/tests/Network/BitTorrent/DHTSpec.hs +++ b/tests/Network/BitTorrent/DHTSpec.hs | |||
@@ -36,8 +36,8 @@ spec = do | |||
36 | it "partial bootstrapping should finish in less than 10 seconds" $ do | 36 | it "partial bootstrapping should finish in less than 10 seconds" $ do |
37 | node <- resolveHostName (L.head defaultBootstrapNodes) | 37 | node <- resolveHostName (L.head defaultBootstrapNodes) |
38 | res <- timeout partialBootstrapTimeout $ do | 38 | res <- timeout partialBootstrapTimeout $ do |
39 | dht opts def $ do | 39 | dht opts def fullLogging $ do |
40 | bootstrap [node] | 40 | bootstrap Nothing [node] |
41 | isBootstrapped | 41 | isBootstrapped |
42 | res `shouldBe` Just True | 42 | res `shouldBe` Just True |
43 | 43 | ||
@@ -57,4 +57,4 @@ spec = do | |||
57 | pending | 57 | pending |
58 | 58 | ||
59 | describe "delete" $ do | 59 | describe "delete" $ do |
60 | return () \ No newline at end of file | 60 | return () |