summaryrefslogtreecommitdiff
path: root/bittorrent/tests/Network/BitTorrent
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2017-09-15 06:22:10 -0400
committerjoe <joe@jerkface.net>2017-09-15 06:22:10 -0400
commit12cbb3af2413dc28838ed271351dda16df8f7bdb (patch)
tree2db77a787e18a81a8369a8d73fee369d8826f064 /bittorrent/tests/Network/BitTorrent
parent362357c6d08cbd8dffa627a1e80199dcb9ba231f (diff)
Separating dht-client library from bittorrent package.
Diffstat (limited to 'bittorrent/tests/Network/BitTorrent')
-rw-r--r--bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs19
-rw-r--r--bittorrent/tests/Network/BitTorrent/CoreSpec.hs305
-rw-r--r--bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs221
-rw-r--r--bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs105
-rw-r--r--bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs77
-rw-r--r--bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs110
-rw-r--r--bittorrent/tests/Network/BitTorrent/DHT/TestData.hs45
-rw-r--r--bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs42
-rw-r--r--bittorrent/tests/Network/BitTorrent/DHTSpec.hs60
-rw-r--r--bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs14
-rw-r--r--bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs35
-rw-r--r--bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs58
-rw-r--r--bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs59
-rw-r--r--bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs102
-rw-r--r--bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs64
-rw-r--r--bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs7
-rw-r--r--bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs13
-rw-r--r--bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs40
-rw-r--r--bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs173
-rw-r--r--bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs95
-rw-r--r--bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs144
-rw-r--r--bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs79
-rw-r--r--bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs61
-rw-r--r--bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs93
24 files changed, 2021 insertions, 0 deletions
diff --git a/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs b/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs
new file mode 100644
index 00000000..d51bab02
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs
@@ -0,0 +1,19 @@
1module Network.BitTorrent.Client.HandleSpec (spec) where
2import Data.Default
3import Test.Hspec
4
5import Data.Torrent
6import Network.BitTorrent.Client
7import Network.BitTorrent.Client.Handle
8
9data_dir :: FilePath
10data_dir = "data"
11
12spec :: Spec
13spec = do
14 describe "openMagnet" $ do
15 it "should add new infohash to index" $ do
16 simpleClient $ do
17 _ <- openMagnet data_dir (nullMagnet def)
18 _ <- getHandle def
19 return ()
diff --git a/bittorrent/tests/Network/BitTorrent/CoreSpec.hs b/bittorrent/tests/Network/BitTorrent/CoreSpec.hs
new file mode 100644
index 00000000..5bf900b2
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/CoreSpec.hs
@@ -0,0 +1,305 @@
1{-# LANGUAGE FlexibleInstances #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Network.BitTorrent.CoreSpec (spec) where
4import Control.Applicative
5import Data.BEncode as BE
6import Data.ByteString.Lazy as BL
7import Data.IP
8import Data.Serialize as S
9import Data.String
10import Data.Text.Encoding as T
11import Data.Word
12import Network
13import Test.Hspec
14import Test.QuickCheck
15import Test.QuickCheck.Instances ()
16
17import Network.BitTorrent.Address
18
19
20instance Arbitrary IPv4 where
21 arbitrary = do
22 a <- choose (0, 255)
23 b <- choose (0, 255)
24 c <- choose (0, 255)
25 d <- choose (0, 255)
26 return $ toIPv4 [a, b, c, d]
27
28instance Arbitrary IPv6 where
29 arbitrary = do
30 a <- choose (0, fromIntegral (maxBound :: Word16))
31 b <- choose (0, fromIntegral (maxBound :: Word16))
32 c <- choose (0, fromIntegral (maxBound :: Word16))
33 d <- choose (0, fromIntegral (maxBound :: Word16))
34 e <- choose (0, fromIntegral (maxBound :: Word16))
35 f <- choose (0, fromIntegral (maxBound :: Word16))
36 g <- choose (0, fromIntegral (maxBound :: Word16))
37 h <- choose (0, fromIntegral (maxBound :: Word16))
38 return $ toIPv6 [a, b, c, d, e, f, g, h]
39
40instance Arbitrary IP where
41 arbitrary = frequency
42 [ (1, IPv4 <$> arbitrary)
43 , (1, IPv6 <$> arbitrary)
44 ]
45
46instance Arbitrary PortNumber where
47 arbitrary = fromIntegral <$> (arbitrary :: Gen Word16)
48
49instance Arbitrary PeerId where
50 arbitrary = oneof
51 [ azureusStyle defaultClientId defaultVersionNumber
52 <$> (T.encodeUtf8 <$> arbitrary)
53 , shadowStyle 'X' defaultVersionNumber
54 <$> (T.encodeUtf8 <$> arbitrary)
55 ]
56
57instance Arbitrary a => Arbitrary (PeerAddr a) where
58 arbitrary = PeerAddr <$> arbitrary <*> arbitrary <*> arbitrary
59
60instance Arbitrary NodeId where
61 arbitrary = fromString <$> vector 20
62
63instance Arbitrary a => Arbitrary (NodeAddr a) where
64 arbitrary = NodeAddr <$> arbitrary <*> arbitrary
65
66instance Arbitrary a => Arbitrary (NodeInfo a) where
67 arbitrary = NodeInfo <$> arbitrary <*> arbitrary
68
69spec :: Spec
70spec = do
71 describe "PeerId" $ do
72 it "properly bencoded" $ do
73 BE.decode "20:01234567890123456789"
74 `shouldBe` Right ("01234567890123456789" :: PeerId)
75
76 describe "PortNumber" $ do
77 it "properly serialized" $ do
78 S.decode "\x1\x2" `shouldBe` Right (258 :: PortNumber)
79 S.encode (258 :: PortNumber) `shouldBe` "\x1\x2"
80
81 it "properly bencoded" $ do
82 BE.decode "i80e" `shouldBe` Right (80 :: PortNumber)
83
84 it "fail if port number is invalid" $ do
85 (BE.decode "i-10e" :: BE.Result PortNumber)
86 `shouldBe`
87 Left "fromBEncode: unable to decode PortNumber: -10"
88
89 (BE.decode "i70000e" :: BE.Result PortNumber)
90 `shouldBe`
91 Left "fromBEncode: unable to decode PortNumber: 70000"
92
93 describe "Peer IPv4" $ do
94 it "properly serialized" $ do
95 S.decode "\x1\x2\x3\x4" `shouldBe` Right (toIPv4 [1, 2, 3, 4])
96 S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4"
97
98 it "properly serialized (iso)" $ property $ \ ip -> do
99 S.decode (S.encode ip) `shouldBe` Right (ip :: IPv4)
100
101 it "properly bencoded" $ do
102 BE.decode "11:168.192.0.1" `shouldBe` Right (toIPv4 [168, 192, 0, 1])
103 BE.encode (toIPv4 [168, 192, 0, 1]) `shouldBe` "11:168.192.0.1"
104
105 it "properly bencoded (iso)" $ property $ \ ip ->
106 BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4)
107
108 it "fail gracefully on invalid strings" $ do
109 BE.decode "3:1.1" `shouldBe`
110 (Left "fromBEncode: unable to decode IP: 1.1" :: BE.Result IPv4)
111
112 it "fail gracefully on invalid bencode" $ do
113 BE.decode "i10e" `shouldBe`
114 (Left "fromBEncode: unable to decode IP: addr should be a bstring"
115 :: BE.Result IPv4)
116
117 describe "Peer IPv6" $ do
118 it "properly serialized" $ do
119 S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
120 `shouldBe`
121 Right ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6)
122
123 S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6)
124 `shouldBe`
125 "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
126
127 it "properly serialized (iso)" $ property $ \ ip ->
128 S.decode (S.encode ip) `shouldBe` Right (ip :: IPv6)
129
130 it "properly bencoded" $ do
131 BE.decode "3:::1" `shouldBe` Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])
132 BE.encode (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) `shouldBe`
133 "23:00:00:00:00:00:00:00:01"
134
135 BE.decode "23:00:00:00:00:00:00:00:01"
136 `shouldBe`
137 Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])
138
139 it "properly bencoded iso" $ property $ \ ip ->
140 BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4)
141
142 it "fail gracefully on invalid strings" $ do
143 BE.decode "4:g::1" `shouldBe`
144 (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IPv6)
145
146 it "fail gracefully on invalid bencode" $ do
147 BE.decode "i10e" `shouldBe`
148 (Left "fromBEncode: unable to decode IP: addr should be a bstring"
149 :: BE.Result IPv6)
150
151
152 describe "Peer IP" $ do
153 it "properly serialized IPv6" $ do
154 S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
155 `shouldBe`
156 Right ("102:304:506:708:90a:b0c:d0e:f10" :: IP)
157
158 S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IP)
159 `shouldBe`
160 "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
161
162 it "properly serialized (iso) IPv6" $ property $ \ ip ->
163 S.decode (S.encode ip) `shouldBe` Right (ip :: IP)
164
165 it "properly serialized IPv4" $ do
166 S.decode "\x1\x2\x3\x4" `shouldBe` Right (IPv4 $ toIPv4 [1, 2, 3, 4])
167 S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4"
168
169 it "properly serialized (iso) IPv4" $ property $ \ ip -> do
170 S.decode (S.encode ip) `shouldBe` Right (ip :: IP)
171
172 it "properly bencoded" $ do
173 BE.decode "11:168.192.0.1" `shouldBe`
174 Right (IPv4 (toIPv4 [168, 192, 0, 1]))
175
176 BE.decode "3:::1" `shouldBe` Right
177 (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]))
178
179 BE.encode (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) `shouldBe`
180 "23:00:00:00:00:00:00:00:01"
181
182 BE.decode "23:00:00:00:00:00:00:00:01"
183 `shouldBe`
184 Right (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]))
185
186 it "properly bencoded iso" $ property $ \ ip ->
187 BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IP)
188
189 it "fail gracefully on invalid strings" $ do
190 BE.decode "4:g::1" `shouldBe`
191 (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IP)
192
193 it "fail gracefully on invalid bencode" $ do
194 BE.decode "i10e" `shouldBe`
195 (Left "fromBEncode: unable to decode IP: addr should be a bstring"
196 :: BE.Result IP)
197
198 describe "PeerAddr" $ do
199 it "IsString" $ do
200 ("127.0.0.1:80" :: PeerAddr IP)
201 `shouldBe` PeerAddr Nothing "127.0.0.1" 80
202
203 ("127.0.0.1:80" :: PeerAddr IPv4)
204 `shouldBe` PeerAddr Nothing "127.0.0.1" 80
205
206 ("[::1]:80" :: PeerAddr IP)
207 `shouldBe` PeerAddr Nothing "::1" 80
208
209 ("[::1]:80" :: PeerAddr IPv6)
210 `shouldBe` PeerAddr Nothing "::1" 80
211
212 it "properly bencoded (iso)" $ property $ \ addr ->
213 BE.decode (BL.toStrict (BE.encode addr))
214 `shouldBe` Right (addr :: PeerAddr IP)
215
216
217 it "properly bencoded (ipv4)" $ do
218 BE.decode "d2:ip11:168.192.0.1\
219 \7:peer id20:01234567890123456789\
220 \4:porti6881e\
221 \e"
222 `shouldBe`
223 Right (PeerAddr (Just "01234567890123456789")
224 (IPv4 (toIPv4 [168, 192, 0, 1]))
225 6881)
226
227 it "properly bencoded (ipv6)" $ do
228 BE.decode "d2:ip3:::1\
229 \7:peer id20:01234567890123456789\
230 \4:porti6881e\
231 \e"
232 `shouldBe`
233 Right (PeerAddr (Just "01234567890123456789")
234 (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]))
235 6881)
236
237 it "peer id is optional" $ do
238 BE.decode "d2:ip11:168.192.0.1\
239 \4:porti6881e\
240 \e"
241 `shouldBe`
242 Right (PeerAddr Nothing (IPv4 (toIPv4 [168, 192, 0, 1])) 6881)
243
244 it "has sock addr for both ipv4 and ipv6" $ do
245 show (peerSockAddr "128.0.0.1:80") `shouldBe` "128.0.0.1:80"
246 show (peerSockAddr "[::1]:8080" ) `shouldBe` "[::1]:8080"
247
248 describe "NodeId" $ do
249 it "properly serialized" $ do
250 S.decode "mnopqrstuvwxyz123456"
251 `shouldBe` Right ("mnopqrstuvwxyz123456" :: NodeId)
252
253 S.encode ("mnopqrstuvwxyz123456" :: NodeId)
254 `shouldBe` "mnopqrstuvwxyz123456"
255
256 it "properly serialized (iso)" $ property $ \ nid ->
257 S.decode (S.encode nid) `shouldBe`
258 Right (nid :: NodeId)
259
260 describe "NodeAddr" $ do
261 it "properly serialized" $ do
262 S.decode "\127\0\0\1\1\2" `shouldBe`
263 Right ("127.0.0.1:258" :: NodeAddr IPv4)
264
265 it "properly serialized (iso)" $ property $ \ nid ->
266 S.decode (S.encode nid) `shouldBe`
267 Right (nid :: NodeAddr IPv4)
268
269 describe "NodeInfo" $ do
270 it "properly serialized" $ do
271 S.decode "mnopqrstuvwxyz123456\
272 \\127\0\0\1\1\2" `shouldBe` Right
273 (NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258" :: NodeInfo IPv4)
274
275 it "properly serialized (iso)" $ property $ \ nid ->
276 S.decode (S.encode nid) `shouldBe`
277 Right (nid :: NodeInfo IPv4)
278
279 -- see <http://bittorrent.org/beps/bep_0020.html>
280 describe "Fingerprint" $ do
281 it "decode mainline encoded peer id" $ do
282 fingerprint "M4-3-6--xxxxxxxxxxxx" `shouldBe` "Mainline-4.3.6"
283 fingerprint "M4-20-8-xxxxxxxxxxxx" `shouldBe` "Mainline-4.20.8"
284
285 it "decode azureus encoded peer id" $ do
286 fingerprint "-AZ2060-xxxxxxxxxxxx" `shouldBe` "Azureus-2060"
287 fingerprint "-BS0000-xxxxxxxxxxxx" `shouldBe` "BTSlave-0"
288
289 it "decode Shad0w style peer id" $ do
290 fingerprint "S58B-----xxxxxxxxxxx" `shouldBe` "Shadow-5.8.11"
291 fingerprint "T58B-----xxxxxxxxxxx" `shouldBe` "BitTornado-5.8.11"
292
293 it "decode bitcomet style peer id" $ do
294 fingerprint "exbc01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49"
295 fingerprint "FUTB01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49"
296 fingerprint "exbc01LORDxxxxxxxxxx" `shouldBe` "BitLord-48.49"
297
298 it "decode opera style peer id" $ do
299 fingerprint "OP0123xxxxxxxxxxxxxx" `shouldBe` "Opera-123"
300
301 it "decode ML donkey style peer id" $ do
302 fingerprint "-ML2.7.2-xxxxxxxxxxx" `shouldBe` "MLdonkey-0"
303
304-- TODO XBT, Bits on Wheels, Queen Bee, BitTyrant, TorrenTopia,
305-- BitSpirit, Rufus, G3 Torrent, FlashGet \ No newline at end of file
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs
new file mode 100644
index 00000000..6f3c7489
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs
@@ -0,0 +1,221 @@
1{-# LANGUAGE RecordWildCards #-}
2module Network.BitTorrent.DHT.MessageSpec (spec) where
3import Control.Monad.Reader
4import Control.Monad.Logger
5import Control.Concurrent
6import Data.BEncode as BE
7import Data.ByteString.Lazy as BL
8import Data.Default
9import Data.List as L
10import Data.Maybe
11import Network.BitTorrent.Address
12import Network.BitTorrent.DHT.Message
13import qualified Network.KRPC as KRPC (def)
14import Network.KRPC hiding (def)
15import Network.Socket (PortNumber)
16import Test.Hspec
17import Test.QuickCheck
18import System.Timeout
19
20import Data.TorrentSpec ()
21import Network.BitTorrent.CoreSpec ()
22import Network.BitTorrent.DHT.TokenSpec ()
23
24-- Arbitrary queries and responses.
25instance Arbitrary Ping where arbitrary = pure Ping
26instance Arbitrary FindNode where arbitrary = FindNode <$> arbitrary
27instance Arbitrary ip => Arbitrary (NodeFound ip) where arbitrary = NodeFound <$> arbitrary
28instance Arbitrary GetPeers where arbitrary = GetPeers <$> arbitrary
29instance Arbitrary ip => Arbitrary (GotPeers ip) where arbitrary = GotPeers <$> arbitrary <*> arbitrary
30instance Arbitrary Announce where arbitrary = Announce <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
31instance Arbitrary Announced where arbitrary = pure Announced
32instance Arbitrary x => Arbitrary (Query x) where arbitrary = Query <$> arbitrary <*> arbitrary <*> arbitrary
33instance Arbitrary x => Arbitrary (Response x) where arbitrary = Response <$> arbitrary <*> arbitrary
34
35instance MonadLogger IO where
36 monadLoggerLog _ _ _ _ = return ()
37
38remoteAddr :: SockAddr
39remoteAddr = SockAddrInet 6881 (256 * 256 * 256 + 127)
40
41thisAddr :: SockAddr
42thisAddr = SockAddrInet 60000 (256 * 256 * 256 + 127)
43
44thisPort :: PortNumber
45thisPort = 60001
46
47rpc :: ReaderT (Manager IO) IO a -> IO a
48rpc action = do
49 withManager KRPC.def thisAddr [] $ runReaderT $ do
50 listen
51 action
52
53isQueryError :: QueryFailure -> Bool
54isQueryError _ = True
55
56prop_bencode :: Eq a => Show a => BEncode a => a -> Expectation
57prop_bencode x = BE.decode (BL.toStrict (BE.encode x)) `shouldBe` Right x
58
59retry :: Int -> IO (Maybe a) -> IO (Maybe a)
60retry 0 _ = return Nothing
61retry n a = do
62 res <- a
63 case res of
64 Just _ -> return res
65 Nothing -> threadDelay (100 * 1000) >> retry (n-1) a
66
67spec :: Spec
68spec = do
69 context ("you need running DHT node at " ++ show remoteAddr) $ do
70 it "is running" $ do
71 running <- retry 5 $ timeout (100 * 1000) $ do
72 nid <- genNodeId
73 Response _remoteAddr Ping <-
74 rpc (query remoteAddr (Query nid False Ping))
75 return ()
76 running `shouldSatisfy` isJust
77
78 describe "ping" $ do
79 it "properly bencoded" $ do
80 BE.decode "d2:id20:abcdefghij0123456789e"
81 `shouldBe` Right (Query "abcdefghij0123456789" False Ping)
82
83 BE.encode (Query "abcdefghij0123456789" False Ping)
84 `shouldBe` "d2:id20:abcdefghij0123456789e"
85
86 BE.decode "d2:id20:mnopqrstuvwxyz123456e"
87 `shouldBe` Right (Response "mnopqrstuvwxyz123456" Ping)
88
89 BE.encode (Response "mnopqrstuvwxyz123456" Ping)
90 `shouldBe` "d2:id20:mnopqrstuvwxyz123456e"
91
92 it "properly bencoded (iso)" $ property $ \ nid -> do
93 prop_bencode (Query nid False Ping)
94 prop_bencode (Response nid Ping)
95
96 it "does compatible with existing DHT" $ do
97 nid <- genNodeId
98 Response _remoteAddr Ping <- rpc (query remoteAddr (Query nid False Ping))
99 return ()
100
101 describe "find_node" $ do
102 it "properly bencoded" $ do
103 BE.decode "d2:id20:abcdefghij0123456789\
104 \6:target20:mnopqrstuvwxyz123456e"
105 `shouldBe` Right (Query "abcdefghij0123456789" False
106 (FindNode "mnopqrstuvwxyz123456"))
107
108 BE.encode (Query "abcdefghij0123456789" False
109 (FindNode "mnopqrstuvwxyz123456"))
110 `shouldBe`
111 "d2:id20:abcdefghij01234567896:target20:mnopqrstuvwxyz123456e"
112
113 let naddr = "127.0.0.1:258" :: NodeAddr IPv4
114 let nid = "0123456789abcdefghij"
115 let nid' = "mnopqrstuvwxyz123456"
116 BE.decode "d2:id20:0123456789abcdefghij\
117 \5:nodes26:mnopqrstuvwxyz123456\127\0\0\1\1\2\
118 \e"
119 `shouldBe` Right (Response nid (NodeFound [NodeInfo nid' naddr]))
120
121 it "properly bencoded (iso)" $ property $ \ nid x xs -> do
122 prop_bencode (Query nid False (FindNode x))
123 prop_bencode (Response nid (NodeFound (xs :: [NodeInfo IPv4] )))
124
125 it "does compatible with existing DHT" $ do
126 nid <- genNodeId
127 Response _remoteAddr (NodeFound xs) <- rpc $ do
128 query remoteAddr (Query nid False (FindNode nid))
129 L.length (xs :: [NodeInfo IPv4]) `shouldSatisfy` (> 0)
130
131 describe "get_peers" $ do
132 it "properly bencoded" $ do
133 BE.decode "d2:id20:abcdefghij0123456789\
134 \9:info_hash20:mnopqrstuvwxyz123456\
135 \e"
136 `shouldBe` Right (Query "abcdefghij0123456789" False
137 (GetPeers "mnopqrstuvwxyz123456"))
138
139 BE.decode "d2:id20:abcdefghij0123456789\
140 \5:token8:aoeusnth\
141 \6:valuesl6:\127\0\0\1\1\2\&6:\192\168\1\100\1\2e\
142 \e"
143 `shouldBe` Right (Response "abcdefghij0123456789"
144 (GotPeers (Right [ "127.0.0.1:258" :: PeerAddr IPv4
145 , "192.168.1.100:258"
146 ]) "aoeusnth"))
147
148 BE.decode "d2:id20:abcdefghij0123456789\
149 \5:nodes26:mnopqrstuvwxyz123456\127\0\0\1\1\2\
150 \5:token8:aoeusnth\
151 \e"
152 `shouldBe` Right (Response "abcdefghij0123456789"
153 (GotPeers
154 { peers = Left [NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258"
155 :: NodeInfo IPv4]
156 , grantedToken = "aoeusnth"
157 }))
158
159 it "properly bencoded (iso)" $ property $ \ nid topic exs token -> do
160 prop_bencode (Query nid False (GetPeers topic))
161 let _ = exs :: Either [NodeInfo IPv4] [PeerAddr IPv4]
162 let nullPeerId paddr = paddr {peerId = Nothing}
163 let nullPeerIds = either Left (Right . L.map nullPeerId)
164 prop_bencode (Response nid (GotPeers (nullPeerIds exs) token))
165
166 it "does compatible with existing DHT" $ do
167 nid <- genNodeId
168 Response _remoteId (GotPeers {..})
169 <- rpc $ query remoteAddr (Query nid False (GetPeers def))
170 let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4]
171 either L.length L.length peers `shouldSatisfy` (> 0)
172
173 describe "announce" $ do
174 it "properly bencoded" $ do
175 BE.decode "d2:id20:abcdefghij0123456789\
176 \9:info_hash20:mnopqrstuvwxyz123456\
177 \4:porti6881e\
178 \5:token8:aoeusnth\
179 \e" `shouldBe` Right
180 (Query "abcdefghij0123456789" False
181 (Announce False "mnopqrstuvwxyz123456" Nothing 6881 "aoeusnth"))
182
183 BE.decode "d2:id20:abcdefghij0123456789\
184 \12:implied_porti1e\
185 \9:info_hash20:mnopqrstuvwxyz123456\
186 \4:porti6881e\
187 \5:token8:aoeusnth\
188 \e" `shouldBe` Right
189 (Query "abcdefghij0123456789" False
190 (Announce True "mnopqrstuvwxyz123456" Nothing 6881 "aoeusnth"))
191
192
193 BE.decode "d2:id20:mnopqrstuvwxyz123456e"
194 `shouldBe` Right
195 (Response "mnopqrstuvwxyz123456" Announced)
196
197 it "properly bencoded (iso)" $ property $ \ nid flag topic port token -> do
198 prop_bencode (Query nid False (Announce flag topic Nothing port token))
199 prop_bencode (Response nid (Announced))
200
201
202 it "does compatible with existing DHT" $ do
203 nid <- genNodeId
204 Response _remoteId Announced <- rpc $ do
205 Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def))
206 let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4]
207 query remoteAddr (Query nid False (Announce False def Nothing thisPort grantedToken))
208 return ()
209
210 it "does fail on invalid token" $ do
211 nid <- genNodeId
212 (rpc $ do
213 Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def))
214 let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4]
215 let invalidToken = ""
216 let q :: MonadKRPC h m => SockAddr -> Query Announce
217 -> m (Response Announced)
218 q = query
219 q remoteAddr (Query nid False (Announce False def Nothing thisPort invalidToken)))
220 `shouldThrow` isQueryError
221 return ()
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs
new file mode 100644
index 00000000..93f78263
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs
@@ -0,0 +1,105 @@
1{-# LANGUAGE RecordWildCards #-}
2module Network.BitTorrent.DHT.QuerySpec (spec) where
3import Control.Applicative
4import Control.Exception
5import Control.Monad.Reader
6import Data.Conduit as C
7import Data.Conduit.List as CL
8import Data.Default
9import Data.List as L
10import Test.Hspec
11
12import Network.BitTorrent.Address
13import Network.BitTorrent.DHT
14import Network.BitTorrent.DHT.Session
15import Network.BitTorrent.DHT.Query
16
17import Network.BitTorrent.DHT.TestData
18
19
20myAddr :: NodeAddr IPv4
21myAddr = "0.0.0.0:0"
22
23nullLogger :: LogFun
24nullLogger _ _ _ _ = return ()
25
26--simpleLogger :: LogFun
27--simpleLogger _ t _ _ = print t
28
29simpleDHT :: [NodeHandler IPv4] -> DHT IPv4 a -> IO a
30simpleDHT hs m =
31 bracket (newNode hs def myAddr nullLogger Nothing) closeNode $ \ node ->
32 runDHT node m
33
34getBootInfo :: IO (NodeInfo IPv4)
35getBootInfo = do
36 startAddr <- resolveHostName (L.head defaultBootstrapNodes)
37 simpleDHT [] $ fmap fst (pingQ startAddr)
38
39spec :: Spec
40spec = parallel $ do
41 describe "environment" $ do
42 describe "test node" $ do
43 it "is alive" $ do
44 _ <- getBootInfo
45 return ()
46
47 describe "handlers" $ do
48 it "" $ pendingWith "need to setup 2 DHT locally"
49
50 describe "basic queries" $ do
51 it "ping" $ do
52 _ <- getBootInfo
53 return ()
54
55 it "findNode" $ do
56 startInfo <- getBootInfo
57 _ <- simpleDHT [] $ do
58 nid <- myNodeIdAccordingTo (read "8.8.8.8:6881")
59 findNodeQ nid startInfo
60 return ()
61
62 it "getPeers" $ do
63 startInfo <- getBootInfo
64 peers <- simpleDHT [] $ do
65 nid <- myNodeIdAccordingTo (read "8.8.8.8:6881")
66
67 -- we should not run getPeers query on boot node, because
68 -- it may not support it
69 Right infos <- findNodeQ nid startInfo
70
71 when (L.null infos) $
72 error "boot node malfunction"
73
74 -- at least one node should reply
75 queryParallel $ do
76 getPeersQ (entryHash (L.head testTorrents)) <$> infos
77
78 peers `shouldSatisfy` (not . L.null)
79
80 it "announce" $ do
81 bootNode <- getBootInfo
82 _ <- simpleDHT [] $ do
83 let ih = entryHash (L.head testTorrents)
84 Right nodes <- findNodeQ ih bootNode
85
86 when (L.null nodes) $
87 error "boot node malfunction"
88
89 queryParallel $ do
90 announceQ ih (nodePort myAddr) <$> nodes
91
92 return ()
93
94 describe "iterative queries" $ do
95 forM_ testTorrents $ \ TestEntry {..} -> do
96 context entryName $ do
97
98 it "get at least 10 unique peers for each infohash" $ do
99 bootNode <- getBootInfo
100 peers <- simpleDHT [] $ do
101 Right startNodes <- findNodeQ entryHash bootNode
102 sourceList [startNodes] $=
103 search entryHash (getPeersQ entryHash) $=
104 CL.concat $$ CL.take 10
105 L.length peers `shouldBe` 10
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs
new file mode 100644
index 00000000..07a906ba
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs
@@ -0,0 +1,77 @@
1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE FlexibleContexts #-}
3module Network.BitTorrent.DHT.RoutingSpec (spec) where
4import Control.Applicative
5import Control.Monad.State
6import Data.Default
7import Data.List as L
8import Data.Maybe
9import Test.Hspec
10import Test.QuickCheck
11
12import Network.BitTorrent.Address
13import Network.BitTorrent.DHT.Routing as T
14
15import Network.BitTorrent.CoreSpec hiding (spec)
16
17
18type Network ip = [NodeAddr ip]
19
20data Env ip = Env
21 { currentTime :: Timestamp
22 , network :: Network ip
23 } deriving Show
24
25type Simulation ip = State (Env ip)
26
27runSimulation :: Eq ip => Env ip -> Routing ip a -> Maybe a
28runSimulation e m = evalState (runRouting ping closest timestamp m) e
29 where
30 ping addr = gets (L.elem addr . network)
31 closest nid = error "runSimulation"
32 timestamp = gets currentTime
33
34instance Arbitrary ip => Arbitrary (Env ip) where
35 arbitrary = Env <$> arbitrary <*> (vector nodeCount)
36 where
37 nodeCount = 1000
38
39instance (Arbitrary ip, Eq ip) => Arbitrary (Table ip) where
40 arbitrary = do
41 thisId <- arbitrary
42 bucketN <- choose (1, 20)
43 let table = nullTable thisId bucketN
44
45-- nodeN <- (`mod` bucketN) <$> arbitrary
46-- nodes <- vector nodeN
47
48 node <- arbitrary
49 mt <- do
50 env <- arbitrary
51 return $ runSimulation env $ do
52 (_,t') <- T.insert (currentTime env) (TryInsert node) table
53 return t' :: Routing ip (Table ip)
54 --(foldM (flip fillTable) table nodes)
55 return (fromJust mt)
56-- where
57-- fillTable x t = do
58-- t' <- T.insert x t
59-- return $ if T.full t' then t else t'
60
61spec :: Spec
62spec = do
63 describe "size" $ do
64 it "null table is empty" $ do
65 T.size (nullTable def 2 :: Table IPv4) `shouldBe` 0
66
67 it "the same node never appear in different buckets" $ property $ \ t -> do
68 let xss = T.toList (t :: Table Int)
69 let justOnce x = L.length (L.filter (L.elem x) xss) == 1
70 L.all justOnce (L.concat xss)
71
72 it "insert is idemponent" $ property $ \ (e :: Env Int) n t -> do
73 let ins :: NodeInfo Int -> Table Int -> Routing Int (Table Int)
74 ins n t = snd <$> T.insert (currentTime e) (TryInsert n) t
75 let t1 = runSimulation e (ins n t)
76 let t2 = runSimulation e (ins n t >>= ins n)
77 t1 `shouldBe` t2
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs
new file mode 100644
index 00000000..32e4c158
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs
@@ -0,0 +1,110 @@
1{-# LANGUAGE ScopedTypeVariables #-}
2module Network.BitTorrent.DHT.SessionSpec (spec) where
3import Control.Applicative
4import Control.Concurrent
5import Control.Exception
6import Control.Monad.Reader
7import Control.Monad.Trans.Resource
8import Data.Conduit.Lazy
9import Data.Default
10import Data.List as L
11import Test.Hspec
12import Test.QuickCheck
13
14import Network.BitTorrent.Address
15import Network.BitTorrent.DHT
16import Network.BitTorrent.DHT.Message
17import Network.BitTorrent.DHT.Session
18import Network.BitTorrent.DHT.Query
19
20import Data.TorrentSpec ()
21import Network.BitTorrent.CoreSpec ()
22import Network.BitTorrent.DHT.TokenSpec ()
23
24
25myAddr :: NodeAddr IPv4
26myAddr = "127.0.0.1:60000"
27
28simpleDHT :: DHT IPv4 a -> IO a
29simpleDHT m =
30 bracket (newNode defaultHandlers def myAddr nullLogger Nothing) closeNode $ \ node ->
31 runDHT node m
32
33isRight :: Either a b -> Bool
34isRight (Left _) = False
35isRight (Right _) = True
36
37isLeft :: Either a b -> Bool
38isLeft = not . isRight
39
40nullLogger :: LogFun
41nullLogger _ _ _ _ = return ()
42
43spec :: Spec
44spec = do
45 describe "session" $ do
46 it "is active until closeNode called" $ do
47 node <- newNode [] def myAddr nullLogger Nothing
48 runDHT node monadActive `shouldReturn` True
49 runDHT node monadActive `shouldReturn` True
50 closeNode node
51 runDHT node monadActive `shouldReturn` False
52
53 describe "tokens" $ do
54 it "should not complain about valid token" $
55 property $ \ (addrs :: [NodeAddr IPv4]) -> do
56 isOks <- simpleDHT $ do
57 forM addrs $ \ addr -> do
58 token <- grantToken addr
59 checkToken addr token
60 L.and isOks `shouldBe` True
61
62 it "should complain about invalid token" $
63 property $ \ (addr :: NodeAddr IPv4) token -> do
64 isOk <- simpleDHT (checkToken addr token)
65 isOk `shouldBe` False
66
67 describe "routing table" $
68 it "accept any node entry when table is empty" $
69 property $ \ (nid :: NodeId) -> do
70 let info = NodeInfo nid myAddr
71 closest <- simpleDHT $ do
72 _ <- insertNode info Nothing
73 liftIO $ yield
74 getClosest nid
75 closest `shouldSatisfy` L.elem info
76
77 describe "peer storage" $ do
78 it "should return nodes, if there are no peers" $ property $ \ ih -> do
79 res <- simpleDHT $ do getPeerList ih
80 res `shouldSatisfy` isLeft
81
82 it "should return peers, if any" $ property $ \ ih addr -> do
83 res <- simpleDHT $ do
84 insertPeer ih addr
85 getPeerList ih
86 res `shouldSatisfy` isRight
87
88 describe "topic storage" $ do
89 it "should not grow indefinitely" $ do
90 pending
91
92 describe "messaging" $ do
93 describe "queryNode" $ do
94 it "should always ping this node" $ do
95 (rid, tid) <- simpleDHT $ do
96 (remoteId, Ping) <- queryNode myAddr Ping
97 thisId <- myNodeIdAccordingTo (read "8.8.8.8:6881")
98 return (remoteId, thisId)
99 rid `shouldBe` tid
100
101 describe "queryParallel" $ do
102 it "should handle parallel requests" $ do
103 (nid, resps) <- simpleDHT $ do
104 me <- myNodeIdAccordingTo (read "8.8.8.8:6881")
105 ( (,) me ) <$> queryParallel (L.replicate 100 $ queryNode myAddr Ping)
106 resps `shouldSatisfy` L.all (== (nid, Ping))
107
108 describe "(<@>) operator" $ do
109 it "" $
110 pending
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs b/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs
new file mode 100644
index 00000000..e9473cbb
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs
@@ -0,0 +1,45 @@
1module Network.BitTorrent.DHT.TestData
2 ( TestEntry (..)
3 , testTorrents
4 ) where
5
6import Data.Torrent
7
8data TestEntry = TestEntry
9 { entryName :: String
10 , entryHash :: InfoHash
11 , entryPeers :: Int -- ^ approximate number of peers, may change with time
12 }
13
14testTorrents :: [TestEntry]
15testTorrents =
16 [ TestEntry
17 { entryName = "Automate with Arduino, Android..."
18 , entryHash = "8c0433e541dc5d1cfc095799cef171cd4eb586f7"
19 , entryPeers = 300
20 }
21
22 , TestEntry
23 { entryName = "Beginning Programming with Java For Dummies"
24 , entryHash = "fd8967721731cc16c8b203a03e49ce839cecf184"
25 , entryPeers = 200
26 }
27
28 , TestEntry
29 { entryName = "The C Programming Language"
30 , entryHash = "146d13f090e50e97091dbbe5b37678dd1471cfad"
31 , entryPeers = 100
32 }
33
34 , TestEntry
35 { entryName = "The C++ Programming Language"
36 , entryHash = "8e8e8e6319031a22cff26d895afe050085c84a7f"
37 , entryPeers = 50
38 }
39
40 , TestEntry
41 { entryName = "Game and Graphics Programming for iOS..."
42 , entryHash = "703d0595b727fccbfaa3d03be25f57347ccfd6de"
43 , entryPeers = 30
44 }
45 ]
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs
new file mode 100644
index 00000000..a45d2212
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs
@@ -0,0 +1,42 @@
1{-# LANGUAGE ScopedTypeVariables #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Network.BitTorrent.DHT.TokenSpec (spec) where
4import Control.Applicative
5import Data.List as L
6import Data.String
7import Test.Hspec
8import Test.QuickCheck
9
10import Network.BitTorrent.Address
11import Network.BitTorrent.CoreSpec ()
12import Network.BitTorrent.DHT.Token as T
13
14
15instance Arbitrary Token where
16 arbitrary = fromString <$> arbitrary
17
18instance Arbitrary TokenMap where
19 arbitrary = tokens <$> arbitrary
20
21repeatN :: Int -> (a -> a) -> (a -> a)
22repeatN n f = L.foldr (.) id $ L.replicate n f
23
24spec :: Spec
25spec = do
26 describe "Token" $ do
27 return ()
28
29 describe "TokenMap" $ do
30 it "is keeping any granted token in current session" $
31 property $ \ (addr :: NodeAddr IPv4) m ->
32 T.member addr (T.lookup addr m) m
33
34 it "is keeping any granted token in next session" $
35 property $ \ (addr :: NodeAddr IPv4) m ->
36 T.member addr (T.lookup addr m) (T.update m)
37
38 -- can fail with some small probability
39 it "is rejecting any outdated tokens" $
40 property $ \ (addr :: NodeAddr IPv4) m k -> not $
41 let n = min 100 (abs k + 2) in
42 T.member addr (T.lookup addr m) (repeatN n T.update m) \ No newline at end of file
diff --git a/bittorrent/tests/Network/BitTorrent/DHTSpec.hs b/bittorrent/tests/Network/BitTorrent/DHTSpec.hs
new file mode 100644
index 00000000..77160eb5
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHTSpec.hs
@@ -0,0 +1,60 @@
1module Network.BitTorrent.DHTSpec (spec) where
2import Control.Exception
3import Control.Monad
4import Data.Default
5import Data.List as L
6import Test.Hspec
7import System.Timeout
8
9import Data.Torrent
10import Network.BitTorrent.DHT
11
12
13partialBootstrapTimeout :: Int
14partialBootstrapTimeout = 10 * 1000000
15
16opts :: Options
17opts = def { optBucketCount = 1 }
18
19-- NOTE to shorten test cases run time include only "good" infohashes
20-- with many nodes
21existingInfoHashes :: [InfoHash]
22existingInfoHashes =
23 [
24 ]
25
26-- TODO use Test.Hspec.parallel
27
28spec :: Spec
29spec = do
30 describe "bootstrapping" $ do
31 it "should resolve all default bootstrap nodes" $ do
32 nodes <- forM defaultBootstrapNodes resolveHostName
33 _ <- evaluate nodes
34 return ()
35
36 it "partial bootstrapping should finish in less than 10 seconds" $ do
37 node <- resolveHostName (L.head defaultBootstrapNodes)
38 res <- timeout partialBootstrapTimeout $ do
39 dht opts def fullLogging $ do
40 bootstrap Nothing [node]
41 isBootstrapped
42 res `shouldBe` Just True
43
44 describe "initialization" $ do
45 it "should be bootstrapped after restore process" $ do
46 pending
47
48 describe "lookup" $ do
49 describe "for any existing infohash" $ do
50 forM_ existingInfoHashes $ \ ih -> do
51 context (show ih) $ do
52 it "should find peers" $ do
53 pending
54
55 describe "insert" $ do
56 it "should return this peer if announced" $ do
57 pending
58
59 describe "delete" $ do
60 return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs
new file mode 100644
index 00000000..1ba772f6
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs
@@ -0,0 +1,14 @@
1{-# OPTIONS -fno-warn-orphans #-}
2module Network.BitTorrent.Exchange.BitfieldSpec (spec) where
3import Control.Applicative
4import Data.ByteString.Arbitrary
5import Test.Hspec
6import Test.QuickCheck
7
8import Network.BitTorrent.Exchange.Bitfield
9
10instance Arbitrary Bitfield where
11 arbitrary = fromBitmap . fromABS <$> arbitrary
12
13spec :: Spec
14spec = return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs
new file mode 100644
index 00000000..2dc8e0b8
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs
@@ -0,0 +1,35 @@
1module Network.BitTorrent.Exchange.BlockSpec (spec) where
2import Control.Applicative
3import Control.Exception
4import Data.Maybe
5import Test.Hspec
6import Test.QuickCheck
7import Test.QuickCheck.Instances ()
8
9import Network.BitTorrent.Exchange.Block as Block
10
11
12instance Arbitrary a => Arbitrary (Block a) where
13 arbitrary = Block <$> arbitrary <*> arbitrary <*> arbitrary
14
15instance Arbitrary BlockIx where
16 arbitrary = BlockIx <$> arbitrary <*> arbitrary <*> arbitrary
17
18instance Arbitrary Bucket where
19 arbitrary = do
20 s <- arbitrary `suchThat` (> 0)
21 chunks <- arbitrary
22 return $ Block.fromList s chunks
23
24isSomeException :: SomeException -> Bool
25isSomeException = const True
26
27spec :: Spec
28spec = do
29 describe "empty" $ do
30 it "should fail on bad size" $ do
31 evaluate (Block.empty (-1)) `shouldThrow` isSomeException
32
33 describe "toPiece" $ do
34 it "render to piece when it is full" $ property $ \ bkt ->
35 full bkt == isJust (toPiece bkt) \ No newline at end of file
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs
new file mode 100644
index 00000000..d654cda1
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs
@@ -0,0 +1,58 @@
1{-# LANGUAGE RecordWildCards #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Network.BitTorrent.Exchange.ConnectionSpec (spec) where
4import Control.Applicative
5import Control.Monad.Trans
6import Data.Default
7import Test.Hspec
8import Test.QuickCheck
9
10import Data.Torrent
11import Network.BitTorrent.Address
12import Network.BitTorrent.Exchange.Connection
13import Network.BitTorrent.Exchange.Message
14
15import Config
16import Network.BitTorrent.Exchange.MessageSpec ()
17
18nullSession :: InfoHash -> PeerId -> SessionLink ()
19nullSession ih pid = SessionLink ih pid Nothing Nothing ()
20
21instance Arbitrary Options where
22 arbitrary = return def
23
24instance Arbitrary ConnectionPrefs where
25 arbitrary = ConnectionPrefs <$> arbitrary <*> pure def
26 <*> arbitrary <*> arbitrary
27
28withWire :: ConnectionPrefs -> Wire () () -> IO ()
29withWire prefs wire =
30 withRemote $ \ ClientOpts {..} -> do
31 pid <- genPeerId
32 t <- getTestTorrent
33 let ih = idInfoHash (tInfoDict t)
34 let cfg = ConnectionConfig prefs (nullSession ih pid) (wire)
35 let addr = PeerAddr Nothing "127.0.0.1" peerPort
36 connectWire addr cfg
37
38spec :: Spec
39spec = do
40 describe "connectWire" $ do
41 it "can establish connection with all possible preferences" $
42 property $ \ prefs -> do
43 withWire prefs (return ())
44
45 it "must not connect with invalid topic" $ do
46 pending
47
48 describe "acceptWire" $ do
49 it "" $ do
50 pending
51
52 describe "messaging" $ do
53 it "first message is bitfield" $ do
54 withWire def $ do
55 msg <- recvMessage
56 let isBitfield (Available (Bitfield _)) = True
57 isBitfield _ = False
58 liftIO $ msg `shouldSatisfy` isBitfield
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs
new file mode 100644
index 00000000..d46f2034
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs
@@ -0,0 +1,59 @@
1{-# LANGUAGE RecordWildCards #-}
2module Network.BitTorrent.Exchange.DownloadSpec (spec) where
3import Control.Concurrent
4import Data.ByteString as BS
5import Data.ByteString.Lazy as BL
6import Test.Hspec
7import Test.QuickCheck
8
9import Data.BEncode as BE
10import Data.Torrent as Torrent
11import Network.BitTorrent.Address
12import Network.BitTorrent.Exchange.Download
13import Network.BitTorrent.Exchange.Message
14
15import Config
16import Network.BitTorrent.CoreSpec ()
17
18
19placeholderAddr :: PeerAddr IP
20placeholderAddr = "0.0.0.0:0"
21
22chunkBy :: Int -> BS.ByteString -> [BS.ByteString]
23chunkBy s bs
24 | BS.null bs = []
25 | otherwise = BS.take s bs : chunkBy s (BS.drop s bs)
26
27withUpdates :: Updates s a -> IO a
28withUpdates m = do
29 Torrent {..} <- getTestTorrent
30 let infoDictLen = fromIntegral $ BL.length $ BE.encode tInfoDict
31 --mvar <- newMVar (nullStatus infoDictLen)
32 --runUpdates mvar placeholderAddr m
33 undefined
34
35simulateFetch :: InfoDict -> Updates s (Maybe InfoDict)
36simulateFetch dict = undefined
37
38spec :: Spec
39spec = do
40 describe "scheduleBlock" $ do
41 it "never schedule the same index twice" $ do
42 pending
43
44 describe "resetPending" $ do
45 it "" $ do
46 pending
47
48 describe "cancelPending" $ do
49 it "must not throw an exception if cancel the same piece twice" $ do
50 pending
51
52 describe "pushBlock" $ do
53 it "assemble infodict from chunks" $ do
54 Torrent {..} <- getTestTorrent
55 mdict <- withUpdates $ simulateFetch tInfoDict
56 mdict `shouldBe` Just tInfoDict
57
58 it "must throw an exception if block if not requested" $ do
59 pending \ No newline at end of file
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs
new file mode 100644
index 00000000..d615b1ff
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs
@@ -0,0 +1,102 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2module Network.BitTorrent.Exchange.MessageSpec (spec) where
3import Control.Applicative
4import Control.Exception
5import Data.ByteString as BS
6import Data.List as L
7import Data.Set as S
8import Data.Serialize as S
9import Data.String
10import Test.Hspec
11import Test.QuickCheck
12
13import Data.TorrentSpec ()
14import Network.BitTorrent.Exchange.BitfieldSpec ()
15import Network.BitTorrent.CoreSpec ()
16import Network.BitTorrent.Address ()
17import Network.BitTorrent.Exchange.BlockSpec ()
18import Network.BitTorrent.Exchange.Message
19
20instance Arbitrary Extension where
21 arbitrary = elements [minBound .. maxBound]
22
23instance Arbitrary Caps where
24 arbitrary = toCaps <$> arbitrary
25
26instance Arbitrary ExtendedExtension where
27 arbitrary = elements [minBound .. maxBound]
28
29instance Arbitrary ExtendedCaps where
30 arbitrary = toCaps <$> arbitrary
31
32instance Arbitrary ProtocolName where
33 arbitrary = fromString <$> (arbitrary `suchThat` ((200 <) . L.length))
34
35instance Arbitrary Handshake where
36 arbitrary = Handshake <$> arbitrary <*> arbitrary
37 <*> arbitrary <*> arbitrary
38
39instance Arbitrary StatusUpdate where
40 arbitrary = frequency
41 [ (1, Choking <$> arbitrary)
42 , (1, Interested <$> arbitrary)
43 ]
44
45instance Arbitrary Available where
46 arbitrary = frequency
47 [ (1, Have <$> arbitrary)
48 , (1, Bitfield <$> arbitrary)
49 ]
50
51instance Arbitrary Transfer where
52 arbitrary = frequency
53 [ (1, Request <$> arbitrary)
54 , (1, Piece <$> arbitrary)
55 , (1, Cancel <$> arbitrary)
56 ]
57
58instance Arbitrary FastMessage where
59 arbitrary = frequency
60 [ (1, pure HaveAll)
61 , (1, pure HaveNone)
62 , (1, SuggestPiece <$> arbitrary)
63 , (1, RejectRequest <$> arbitrary)
64 , (1, AllowedFast <$> arbitrary)
65 ]
66
67instance Arbitrary Message where
68 arbitrary = frequency
69 [ (1, pure KeepAlive)
70 , (1, Status <$> arbitrary)
71 , (1, Available <$> arbitrary)
72 , (1, Transfer <$> arbitrary)
73 , (1, Fast <$> arbitrary)
74 ]
75
76-- TODO test extension protocol
77
78spec :: Spec
79spec = do
80 describe "Caps" $ do
81 it "set-like container" $ property $ \ exts ->
82 L.all (`allowed` (toCaps exts :: Caps)) exts
83
84 it "preserve items" $ property $ \ extSet ->
85 S.fromList (fromCaps (toCaps (S.toList extSet) :: Caps))
86 `shouldBe` extSet
87
88 describe "ByteStats" $ do
89 it "preserve size" $ property $ \ msg ->
90 byteLength (stats msg) `shouldBe`
91 fromIntegral (BS.length (S.encode (msg :: Message)))
92
93 describe "ProtocolName" $ do
94 it "fail to construct invalid string" $ do
95 let str = L.replicate 500 'x'
96 evaluate (fromString str :: ProtocolName)
97 `shouldThrow`
98 errorCall ("fromString: ProtocolName too long: " ++ str)
99
100 describe "Handshake" $ do
101 it "properly serialized" $ property $ \ hs ->
102 S.decode (S.encode hs ) `shouldBe` Right (hs :: Handshake)
diff --git a/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs
new file mode 100644
index 00000000..bf5b95a1
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs
@@ -0,0 +1,64 @@
1{-# LANGUAGE RecordWildCards #-}
2module Network.BitTorrent.Exchange.SessionSpec (spec) where
3import Test.Hspec
4
5import Data.Torrent
6import Network.BitTorrent.Address
7import Network.BitTorrent.Exchange.Session
8
9import Config
10
11
12nullLogger :: LogFun
13nullLogger _ _ x _ = print x
14
15simpleSession :: InfoDict -> (Session -> IO ()) -> IO ()
16simpleSession dict action = do
17 withRemoteAddr $ \ addr -> do
18 myAddr <- getMyAddr
19 ses <- newSession nullLogger myAddr "" (Right dict)
20 connect addr ses
21 action ses
22 closeSession ses
23
24spec :: Spec
25spec = do
26 describe "construction" $ do
27 describe "newSession" $ do
28 it "" $ do
29 pending
30
31 describe "closeSession" $ do
32 it "" $ do
33 pending
34
35 describe "connection set" $ do
36 describe "connect" $ do
37 it "" $ do
38 pending
39
40 describe "establish" $ do
41 it "" $ do
42 pending
43
44 describe "exchange" $ do
45 describe "metadata" $ do
46 it "should fetch info dictionary" $ do
47 Torrent {..} <- getTestTorrent
48 simpleSession tInfoDict $ \ ses -> do
49 dict <- waitMetadata ses
50 dict `shouldBe` tInfoDict
51
52 it "should serve info dictionary" $ do
53 pending
54
55 describe "content" $ do
56 it "should fetch torrent content" $ do
57 Torrent {..} <- getTestTorrent
58 simpleSession tInfoDict $ \ ses -> do
59 pending
60-- st <- waitData ses
61-- verifyStorage st (idPieceInfo tInfoDict)
62
63 it "should serve torrent content" $ do
64 pending
diff --git a/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs b/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs
new file mode 100644
index 00000000..337e7add
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs
@@ -0,0 +1,7 @@
1module Network.BitTorrent.Internal.CacheSpec (spec) where
2import Test.Hspec
3
4spec :: Spec
5spec = do
6 describe "Cached" $ do
7 return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs b/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs
new file mode 100644
index 00000000..acbfd84c
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs
@@ -0,0 +1,13 @@
1{-# OPTIONS -fno-warn-orphans #-}
2module Network.BitTorrent.Internal.ProgressSpec (spec) where
3import Control.Applicative
4import Test.Hspec
5import Test.QuickCheck
6import Network.BitTorrent.Internal.Progress
7
8
9instance Arbitrary Progress where
10 arbitrary = Progress <$> arbitrary <*> arbitrary <*> arbitrary
11
12spec :: Spec
13spec = return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs
new file mode 100644
index 00000000..bba9d0e2
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs
@@ -0,0 +1,40 @@
1module Network.BitTorrent.Tracker.ListSpec (spec) where
2import Control.Exception
3import Data.Default
4import Data.Foldable as F
5import Data.List as L
6import Data.Maybe
7import Network.URI
8import Test.Hspec
9
10import Data.Torrent
11import Network.BitTorrent.Tracker.List
12import Network.BitTorrent.Tracker.RPC
13
14
15uris :: [URI]
16uris = fmap (fromJust . parseURI . renderURI) [1..10 :: Int]
17 where
18 renderURI n = "http://" ++ show n ++ ".org"
19
20list :: TrackerList ()
21list = trackerList def { tAnnounceList = Just [uris] }
22
23spec :: Spec
24spec = do
25 describe "TrackerList" $ do
26 it "shuffleTiers (may fail with very small probability)" $ do
27 list' <- shuffleTiers list
28 list' `shouldSatisfy` (/= list)
29
30 it "traverseAll" $ do
31 xs <- traverseAll (\ (uri, _) -> if uri == L.last uris
32 then throwIO (GenericException "")
33 else return ()) list
34 return ()
35
36 it "traverseTiers" $ do
37 xs' <- traverseTiers (\ (uri, _) -> if uri == L.last uris then return ()
38 else throwIO (GenericException "")) list
39
40 return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs
new file mode 100644
index 00000000..29854d58
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs
@@ -0,0 +1,173 @@
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# OPTIONS -fno-warn-orphans #-}
5module Network.BitTorrent.Tracker.MessageSpec
6 ( spec
7 , arbitrarySample
8 ) where
9
10import Control.Applicative
11import Control.Exception
12import Data.BEncode as BE
13import Data.ByteString.Lazy as BL
14import Data.List as L
15import Data.Maybe
16import Test.Hspec
17import Test.QuickCheck
18
19import Data.TorrentSpec ()
20import Network.BitTorrent.Internal.ProgressSpec ()
21import Network.BitTorrent.Address ()
22import Network.BitTorrent.Address ()
23
24import Network.BitTorrent.Tracker.Message as Message
25import Network.BitTorrent.Address
26
27
28--prop_bencode :: Eq a => BEncode a => a -> Bool
29--prop_bencode a = BE.decode (BL.toStrict (BE.encode a)) == return a
30
31--prop_urlencode :: Eq a => URLDecoded a => URLEncoded a => a -> Bool
32--prop_urlencode a = urlDecode (T.pack (urlEncode a)) == a
33
34instance Arbitrary AnnounceEvent where
35 arbitrary = elements [minBound..maxBound]
36
37instance Arbitrary AnnounceQuery where
38 arbitrary = AnnounceQuery
39 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
40 <*> arbitrary <*> arbitrary <*> arbitrary
41
42instance Arbitrary (PeerList IP) where
43 arbitrary = frequency
44 [ (1, (PeerList . maybeToList) <$> arbitrary)
45 , (1, (CompactPeerList . maybeToList . fmap zeroPeerId) <$> arbitrary)
46 ]
47
48 shrink ( PeerList xs) = PeerList <$> shrink xs
49 shrink (CompactPeerList xs) = CompactPeerList <$> shrink xs
50
51instance Arbitrary AnnounceInfo where
52 arbitrary = AnnounceInfo
53 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
54 <*> arbitrary <*> arbitrary
55
56arbitrarySample :: Arbitrary a => IO a
57arbitrarySample = L.head <$> sample' arbitrary
58
59zeroPeerId :: PeerAddr a -> PeerAddr a
60zeroPeerId addr = addr { peerId = Nothing }
61
62spec :: Spec
63spec = do
64 describe "AnnounceQuery" $ do
65 it "properly url encoded" $ property $ \ q ->
66 parseAnnounceQuery (renderAnnounceQuery q)
67 `shouldBe` Right q
68
69 describe "PeerList" $ do
70 context "Non compact" $ do
71 it "properly encoded (both ipv4 and ipv6)" $ do
72 BE.decode "ld2:ip7:1.2.3.44:porti80eed2:ip3:::14:porti8080eee"
73 `shouldBe` Right
74 (PeerList ["1.2.3.4:80", "[::1]:8080"] :: PeerList IPv4)
75
76 it "properly encoded (iso)" $ property $ \ xs ->
77 BE.decode (BL.toStrict (BE.encode (PeerList xs :: PeerList IPv4)))
78 `shouldBe` Right (PeerList xs :: PeerList IPv4)
79
80 context "Compact" $ do
81 it "properly encodes (ipv4)" $ do
82 BE.decode "12:\x1\x2\x3\x4\x1\x2\x9\x8\x7\x6\x1\x2"
83 `shouldBe` Right
84 (CompactPeerList ["1.2.3.4:258", "9.8.7.6:258"] :: PeerList IPv4)
85
86 it "properly encodes (ipv6)" $ do
87 BE.decode "18:\x1\x2\x3\x4\x5\x6\x7\x8\x1\x2\x3\x4\x5\x6\x7\x8\x1\x2"
88 `shouldBe` Right
89 (CompactPeerList ["[102:304:506:708:102:304:506:708]:258"]
90 :: PeerList IPv6)
91
92 it "properly encoded (ipv4, iso)" $
93 property $ \ (fmap zeroPeerId -> xs) ->
94 BE.decode (BL.toStrict (BE.encode (CompactPeerList xs)))
95 `shouldBe` Right (CompactPeerList xs :: PeerList IPv4)
96
97 it "properly encoded (ipv6, iso)" $
98 property $ \ (fmap zeroPeerId -> xs) ->
99 BE.decode (BL.toStrict (BE.encode (CompactPeerList xs)))
100 `shouldBe` Right (CompactPeerList xs :: PeerList IPv6)
101
102 describe "AnnounceInfo" $ do
103 it "parses minimal sample" $ do
104 "d8:intervali0e5:peerslee"
105 `shouldBe`
106 AnnounceInfo Nothing Nothing 0 Nothing (PeerList []) Nothing
107
108 it "parses optional fields" $ do
109 "d8:completei1e\
110 \10:incompletei2e\
111 \8:intervali3e\
112 \12:min intervali4e\
113 \5:peersle\
114 \15:warning message3:str\
115 \e"
116 `shouldBe`
117 AnnounceInfo (Just 1) (Just 2) 3 (Just 4) (PeerList []) (Just "str")
118
119 it "parses failed response" $ do
120 "d14:failure reason10:any reasone"
121 `shouldBe`
122 Message.Failure "any reason"
123
124 it "fail if no peer list present" $ do
125 evaluate ("d8:intervali0ee" :: AnnounceInfo)
126 `shouldThrow`
127 errorCall "fromString: unable to decode AnnounceInfo: \
128 \required field `peers' not found"
129
130 it "parses `peer' list" $ do -- TODO
131 "d8:intervali0e\
132 \5:peersl\
133 \d2:ip7:1.2.3.4\
134 \4:porti80e\
135 \e\
136 \d2:ip3:::1\
137 \4:porti80e\
138 \e\
139 \e\
140 \e" `shouldBe`
141 let xs = PeerList ["1.2.3.4:80", "[::1]:80"] in
142 AnnounceInfo Nothing Nothing 0 Nothing xs Nothing
143
144 it "parses `peers6' list" $ do
145 "d8:intervali0e\
146 \5:peers0:\
147 \6:peers60:\
148 \e" `shouldBe`
149 AnnounceInfo Nothing Nothing 0 Nothing (CompactPeerList []) Nothing
150
151 it "fails on invalid combinations of the peer lists" $ do
152 BE.decode "d8:intervali0e\
153 \5:peers0:\
154 \6:peers6le\
155 \e"
156 `shouldBe` (Left
157 "PeerList: the `peers6' field value should contain \
158 \*compact* peer list" :: BE.Result AnnounceInfo)
159
160 BE.decode "d8:intervali0e\
161 \5:peersle\
162 \6:peers60:\
163 \e"
164 `shouldBe` (Left
165 "PeerList: non-compact peer list provided, \
166 \but the `peers6' field present" :: BE.Result AnnounceInfo)
167
168 it "properly bencoded (iso)" $ property $ \ info ->
169 BE.decode (BL.toStrict (BE.encode info))
170 `shouldBe` Right (info :: AnnounceInfo)
171
172 describe "Scrape" $ do
173 return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs
new file mode 100644
index 00000000..e928f917
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs
@@ -0,0 +1,95 @@
1{-# LANGUAGE RecordWildCards #-}
2module Network.BitTorrent.Tracker.RPC.HTTPSpec (spec) where
3import Control.Monad
4import Data.Default
5import Data.List as L
6import Test.Hspec
7
8import Network.BitTorrent.Internal.Progress
9import Network.BitTorrent.Tracker.Message as Message
10import Network.BitTorrent.Tracker.RPC.HTTP
11
12import Network.BitTorrent.Tracker.TestData
13import Network.BitTorrent.Tracker.MessageSpec hiding (spec)
14
15
16validateInfo :: AnnounceQuery -> AnnounceInfo -> Expectation
17validateInfo _ (Message.Failure reason) = do
18 error $ "validateInfo: " ++ show reason
19validateInfo AnnounceQuery {..} AnnounceInfo {..} = do
20 return ()
21-- case respComplete <|> respIncomplete of
22-- Nothing -> return ()
23-- Just n -> n `shouldBe` L.length (getPeerList respPeers)
24
25isUnrecognizedScheme :: RpcException -> Bool
26isUnrecognizedScheme (RequestFailed _) = True
27isUnrecognizedScheme _ = False
28
29isNotResponding :: RpcException -> Bool
30isNotResponding (RequestFailed _) = True
31isNotResponding _ = False
32
33spec :: Spec
34spec = parallel $ do
35 describe "Manager" $ do
36 describe "newManager" $ do
37 it "" $ pending
38
39 describe "closeManager" $ do
40 it "" $ pending
41
42 describe "withManager" $ do
43 it "" $ pending
44
45 describe "RPC" $ do
46 describe "announce" $ do
47 it "must fail on bad uri scheme" $ do
48 withManager def $ \ mgr -> do
49 q <- arbitrarySample
50 announce mgr "magnet://foo.bar" q
51 `shouldThrow` isUnrecognizedScheme
52
53 describe "scrape" $ do
54 it "must fail on bad uri scheme" $ do
55 withManager def $ \ mgr -> do
56 scrape mgr "magnet://foo.bar" []
57 `shouldThrow` isUnrecognizedScheme
58
59 forM_ (L.filter isHttpTracker trackers) $ \ TrackerEntry {..} ->
60 context trackerName $ do
61
62 describe "announce" $ do
63 if tryAnnounce
64 then do
65 it "have valid response" $ do
66 withManager def $ \ mgr -> do
67-- q <- arbitrarySample
68 let ih = maybe def L.head hashList
69 let q = AnnounceQuery ih "-HS0003-203534.37420" 6000
70 (Progress 0 0 0) Nothing Nothing (Just Started)
71 info <- announce mgr trackerURI q
72 validateInfo q info
73 else do
74 it "should fail with RequestFailed" $ do
75 withManager def $ \ mgr -> do
76 q <- arbitrarySample
77 announce mgr trackerURI q
78 `shouldThrow` isNotResponding
79
80 describe "scrape" $ do
81 if tryScraping
82 then do
83 it "have valid response" $ do
84 withManager def $ \ mgr -> do
85 xs <- scrape mgr trackerURI [def]
86 L.length xs `shouldSatisfy` (>= 1)
87 else do
88 it "should fail with ScrapelessTracker" $ do
89 pending
90
91 when (not tryAnnounce) $ do
92 it "should fail with RequestFailed" $ do
93 withManager def $ \ mgr -> do
94 scrape mgr trackerURI [def]
95 `shouldThrow` isNotResponding
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs
new file mode 100644
index 00000000..73acb3fa
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs
@@ -0,0 +1,144 @@
1{-# LANGUAGE RecordWildCards #-}
2module Network.BitTorrent.Tracker.RPC.UDPSpec (spec, rpcOpts) where
3import Control.Concurrent
4import Control.Concurrent.Async
5import Control.Exception
6import Control.Monad
7import Data.Default
8import Data.List as L
9import Data.Maybe
10import Test.Hspec
11
12import Network.BitTorrent.Address
13import Network.BitTorrent.Tracker.Message as Message
14
15import Network.BitTorrent.Tracker.TestData
16import Network.BitTorrent.Tracker.MessageSpec hiding (spec)
17import Network.BitTorrent.Tracker.RPC.UDP
18
19
20validateInfo :: AnnounceQuery -> AnnounceInfo -> Expectation
21validateInfo _ Message.Failure {} = error "validateInfo: failure"
22validateInfo AnnounceQuery {..} AnnounceInfo {..} = do
23 respComplete `shouldSatisfy` isJust
24 respIncomplete `shouldSatisfy` isJust
25 respMinInterval `shouldSatisfy` isNothing
26 respWarning `shouldSatisfy` isNothing
27 peerList `shouldSatisfy` L.all (isNothing . peerId)
28 where
29 peerList = getPeerList respPeers
30
31-- | Number of concurrent calls.
32rpcCount :: Int
33rpcCount = 100
34
35rpcOpts :: Options
36rpcOpts = def
37 { optMinTimeout = 1
38 , optMaxTimeout = 10
39 }
40
41isTimeoutExpired :: RpcException -> Bool
42isTimeoutExpired (TimeoutExpired _) = True
43isTimeoutExpired _ = False
44
45isSomeException :: SomeException -> Bool
46isSomeException _ = True
47
48isIOException :: IOException -> Bool
49isIOException _ = True
50
51spec :: Spec
52spec = parallel $ do
53 describe "newManager" $ do
54 it "should throw exception on zero optMaxPacketSize" $ do
55 let opts = def { optMaxPacketSize = 0 }
56 newManager opts `shouldThrow` isSomeException
57
58 it "should throw exception on zero optMinTimout" $ do
59 let opts = def { optMinTimeout = 0 }
60 newManager opts `shouldThrow` isSomeException
61
62 it "should throw exception on zero optMaxTimeout" $ do
63 let opts = def { optMaxTimeout = 0 }
64 newManager opts `shouldThrow` isSomeException
65
66 it "should throw exception on maxTimeout < minTimeout" $ do
67 let opts = def { optMinTimeout = 2, optMaxTimeout = 1 }
68 newManager opts `shouldThrow` isSomeException
69
70 it "should throw exception on zero optMultiplier" $ do
71 let opts = def { optMultiplier = 0 }
72 newManager opts `shouldThrow` isSomeException
73
74 describe "closeManager" $ do
75 it "unblock rpc calls" $ do
76 mgr <- newManager rpcOpts
77 _ <- forkIO $ do
78 threadDelay 10000000
79 closeManager mgr
80 q <- arbitrarySample
81 announce mgr (trackerURI badTracker) q `shouldThrow` (== ManagerClosed)
82
83 it "announce throw exception after manager closed" $ do
84 mgr <- newManager rpcOpts
85 closeManager mgr
86 q <- arbitrarySample
87 announce mgr (trackerURI badTracker) q `shouldThrow` isIOException
88
89 it "scrape throw exception after manager closed" $ do
90 mgr <- newManager rpcOpts
91 closeManager mgr
92 scrape mgr (trackerURI badTracker) [def] `shouldThrow` isIOException
93
94 describe "withManager" $ do
95 it "closesManager at exit" $ do
96 mgr <- withManager rpcOpts return
97 scrape mgr (trackerURI badTracker) [def] `shouldThrow` isSomeException
98
99 describe "RPC" $ do
100 describe "announce" $ do
101 it "must fail on bad scheme" $ do
102 withManager rpcOpts $ \ mgr -> do
103 q <- arbitrarySample
104 announce mgr "magnet://a.com" q
105 `shouldThrow` (== UnrecognizedScheme "magnet:")
106
107 describe "scrape" $ do
108 it "must fail on bad scheme" $ do
109 withManager rpcOpts $ \ mgr -> do
110 scrape mgr "magnet://a.com" []
111 `shouldThrow` (== UnrecognizedScheme "magnet:")
112
113 forM_ (L.filter isUdpTracker trackers) $ \ TrackerEntry {..} ->
114 context trackerName $ do
115
116 describe "announce" $ do
117 if tryAnnounce then do
118 it "have valid response" $ do
119 withManager rpcOpts $ \ mgr -> do
120 q <- arbitrarySample
121 announce mgr trackerURI q >>= validateInfo q
122 else do
123 it "should throw TimeoutExpired" $ do
124 withManager rpcOpts $ \ mgr -> do
125 q <- arbitrarySample
126 announce mgr trackerURI q `shouldThrow` isTimeoutExpired
127
128 describe "scrape" $ do
129 if tryScraping then do
130 it "have valid response" $ do
131 withManager rpcOpts $ \ mgr -> do
132 xs <- scrape mgr trackerURI [def]
133 L.length xs `shouldSatisfy` (>= 1)
134 else do
135 it "should throw TimeoutExpired" $ do
136 withManager rpcOpts $ \ mgr -> do
137 scrape mgr trackerURI [def] `shouldThrow` isTimeoutExpired
138
139 describe "Manager" $ do
140 when tryScraping $ do
141 it "should handle arbitrary intermixed concurrent queries" $ do
142 withManager rpcOpts $ \ mgr -> do
143 _ <- mapConcurrently (\ _ -> scrape mgr trackerURI [def]) [1..rpcCount]
144 return ()
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs
new file mode 100644
index 00000000..dfc13a1e
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs
@@ -0,0 +1,79 @@
1{-# LANGUAGE RecordWildCards #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Network.BitTorrent.Tracker.RPCSpec (spec) where
4import Control.Applicative
5import Control.Monad
6import Data.Default
7import Data.List as L
8import Test.Hspec
9import Test.QuickCheck
10
11import Network.BitTorrent.Tracker.RPC as RPC
12
13import Network.BitTorrent.Tracker.TestData
14import Network.BitTorrent.Tracker.MessageSpec hiding (spec)
15import qualified Network.BitTorrent.Tracker.RPC.UDPSpec as UDP (rpcOpts)
16
17
18instance Arbitrary SAnnounceQuery where
19 arbitrary = SAnnounceQuery <$> arbitrary <*> arbitrary
20 <*> arbitrary <*> arbitrary
21
22rpcOpts :: Options
23rpcOpts = def
24 { optUdpRPC = UDP.rpcOpts
25 }
26
27matchUnrecognizedScheme :: String -> RpcException -> Bool
28matchUnrecognizedScheme x (UnrecognizedScheme scheme) = x == scheme
29matchUnrecognizedScheme _ _ = False
30
31spec :: Spec
32spec = parallel $ do
33 describe "Manager" $ do
34 describe "newManager" $ do
35 it "" $ pending
36
37 describe "closeManager" $ do
38 it "" $ pending
39
40 describe "withManager" $ do
41 it "" $ pending
42
43 describe "RPC" $ do
44 describe "announce" $ do
45 it "must fail on bad uri scheme" $ do
46 withManager rpcOpts def $ \ mgr -> do
47 q <- arbitrarySample
48 announce mgr "magnet://foo.bar" q
49 `shouldThrow` matchUnrecognizedScheme "magnet:"
50
51 describe "scrape" $ do
52 it "must fail on bad uri scheme" $ do
53 withManager rpcOpts def $ \ mgr -> do
54 scrape mgr "magnet://foo.bar" []
55 `shouldThrow` matchUnrecognizedScheme "magnet:"
56
57 forM_ trackers $ \ TrackerEntry {..} ->
58 context trackerName $ do
59
60 describe "announce" $ do
61 if tryAnnounce then do
62 it "have valid response" $ do
63 withManager rpcOpts def $ \ mgr -> do
64 q <- arbitrarySample
65 _ <- announce mgr trackerURI q
66 return ()
67 else do
68 it "should throw exception" $ do
69 pending
70
71 describe "scrape" $ do
72 if tryScraping then do
73 it "have valid response" $ do
74 withManager rpcOpts def $ \ mgr -> do
75 xs <- scrape mgr trackerURI [def]
76 L.length xs `shouldSatisfy` (>= 1)
77 else do
78 it "should throw exception" $ do
79 pending
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs
new file mode 100644
index 00000000..72936ee7
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs
@@ -0,0 +1,61 @@
1module Network.BitTorrent.Tracker.SessionSpec (spec) where
2import Control.Monad
3import Data.Default
4import Data.List as L
5import Test.Hspec
6
7import Data.Torrent
8import Network.BitTorrent.Tracker.Message
9import Network.BitTorrent.Tracker.List
10import Network.BitTorrent.Tracker.RPC
11import Network.BitTorrent.Tracker.Session
12
13import Config
14
15testSession :: Bool -> (Manager -> Session -> IO ()) -> IO ()
16testSession runEmpty action = do
17 t <- getTestTorrent
18 withManager def def $ \ m -> do
19 withSession m (idInfoHash (tInfoDict t)) (trackerList t) $ \ s ->
20 action m s
21
22 when runEmpty $ do
23 withSession m (idInfoHash (tInfoDict t)) def $ \ s ->
24 action m s
25
26spec :: Spec
27spec = do
28 describe "Session" $ do
29 it "start new session in paused state" $ do
30 testSession True $ \ _ s -> do
31 status <- getStatus s
32 status `shouldBe` Paused
33
34 describe "Query" $ do
35 it "change status after notify" $ do
36 testSession True $ \ m s -> do
37 notify m s Started
38 status <- getStatus s
39 status `shouldBe` Running
40
41 notify m s Stopped
42 stopped <- getStatus s
43 stopped `shouldBe` Paused
44
45 it "completed event do not change status" $ do
46 testSession True $ \ m s -> do
47 notify m s Completed
48 status <- getStatus s
49 status `shouldBe` Paused
50
51 testSession True $ \ m s -> do
52 notify m s Started
53 notify m s Completed
54 status <- getStatus s
55 status `shouldBe` Running
56
57 it "return non-empty list of peers" $ do
58 testSession False $ \ m s -> do
59 notify m s Started
60 peers <- askPeers m s
61 peers `shouldSatisfy` (not . L.null)
diff --git a/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs b/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs
new file mode 100644
index 00000000..b95e2df4
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs
@@ -0,0 +1,93 @@
1{-# LANGUAGE RecordWildCards #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Network.BitTorrent.Tracker.TestData
4 ( TrackerEntry (..)
5 , isUdpTracker
6 , isHttpTracker
7 , trackers
8 , badTracker
9 ) where
10
11import Data.Maybe
12import Data.String
13import Network.URI
14
15import Data.Torrent
16
17
18data TrackerEntry = TrackerEntry
19 { -- | May be used to show tracker name in test suite report.
20 trackerName :: String
21
22 -- | Announce uri of the tracker.
23 , trackerURI :: URI
24
25 -- | Some trackers abadoned, so don't even try to announce.
26 , tryAnnounce :: Bool
27
28 -- | Some trackers do not support scraping, so we should not even
29 -- try to scrape them.
30 , tryScraping :: Bool
31
32 -- | Some trackers allow
33 , hashList :: Maybe [InfoHash]
34 }
35
36isUdpTracker :: TrackerEntry -> Bool
37isUdpTracker TrackerEntry {..} = uriScheme trackerURI == "udp:"
38
39isHttpTracker :: TrackerEntry -> Bool
40isHttpTracker TrackerEntry {..} = uriScheme trackerURI == "http:"
41 || uriScheme trackerURI == "https:"
42
43instance IsString URI where
44 fromString str = fromMaybe err $ parseURI str
45 where
46 err = error $ "fromString: bad URI " ++ show str
47
48trackerEntry :: URI -> TrackerEntry
49trackerEntry uri = TrackerEntry
50 { trackerName = maybe "<unknown>" uriRegName (uriAuthority uri)
51 , trackerURI = uri
52 , tryAnnounce = False
53 , tryScraping = False
54 , hashList = Nothing
55 }
56
57announceOnly :: String -> URI -> TrackerEntry
58announceOnly name uri = (trackerEntry uri)
59 { trackerName = name
60 , tryAnnounce = True
61 }
62
63announceScrape :: String -> URI -> TrackerEntry
64announceScrape name uri = (announceOnly name uri)
65 { tryScraping = True
66 }
67
68notWorking :: String -> URI -> TrackerEntry
69notWorking name uri = (trackerEntry uri)
70 { trackerName = name
71 }
72
73trackers :: [TrackerEntry]
74trackers =
75 [ (announceOnly "LinuxTracker"
76 "http://linuxtracker.org:2710/00000000000000000000000000000000/announce")
77 { hashList = Just ["1c82a95b9e02bf3db4183da072ad3ef656aacf0e"] -- debian 7
78 }
79
80 , (announceScrape "Arch" "http://tracker.archlinux.org:6969/announce")
81 { hashList = Just ["bc9ae647a3e6c3636de58535dd3f6360ce9f4621"]
82 }
83
84 , notWorking "rarbg" "udp://9.rarbg.com:2710/announce"
85
86 , announceScrape "OpenBitTorrent" "udp://tracker.openbittorrent.com:80/announce"
87 , announceScrape "PublicBT" "udp://tracker.publicbt.com:80/announce"
88 , notWorking "OpenBitTorrent" "http://tracker.openbittorrent.com:80/announce"
89 , notWorking "PublicBT" "http://tracker.publicbt.com:80/announce"
90 ]
91
92badTracker :: TrackerEntry
93badTracker = notWorking "rarbg" "udp://9.rarbg.com:2710/announce" \ No newline at end of file
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 17:39:57 +0000