summaryrefslogtreecommitdiff
path: root/bittorrent/tests
diff options
context:
space:
mode:
Diffstat (limited to 'bittorrent/tests')
-rw-r--r--bittorrent/tests/Config.hs183
-rw-r--r--bittorrent/tests/Data/TorrentSpec.hs139
-rw-r--r--bittorrent/tests/Main.hs97
-rw-r--r--bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs19
-rw-r--r--bittorrent/tests/Network/BitTorrent/CoreSpec.hs309
-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
-rw-r--r--bittorrent/tests/Network/KRPC/MessageSpec.hs72
-rw-r--r--bittorrent/tests/Network/KRPC/MethodSpec.hs52
-rw-r--r--bittorrent/tests/Network/KRPCSpec.hs59
-rw-r--r--bittorrent/tests/Readme.md4
-rw-r--r--bittorrent/tests/Spec.hs1
-rw-r--r--bittorrent/tests/System/Torrent/FileMapSpec.hs116
-rw-r--r--bittorrent/tests/System/Torrent/StorageSpec.hs91
34 files changed, 0 insertions, 2839 deletions
diff --git a/bittorrent/tests/Config.hs b/bittorrent/tests/Config.hs
deleted file mode 100644
index 55e30867..00000000
--- a/bittorrent/tests/Config.hs
+++ /dev/null
@@ -1,183 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE RecordWildCards #-}
3module Config
4 ( -- * Types
5 ClientName
6 , ClientOpts (..)
7 , EnvOpts (..)
8
9 -- * For test suite driver
10 , getOpts
11
12 -- * For item specs
13 , getEnvOpts
14 , getThisOpts
15 , getMyAddr
16
17 , getRemoteOpts
18 , withRemote
19 , withRemoteAddr
20
21 , getTestTorrent
22 ) where
23
24import Control.Monad
25import Network
26import Data.Default
27import Data.IORef
28import Data.List as L
29import Data.Maybe
30import Options.Applicative
31import System.Exit
32import System.Environment
33import System.IO.Unsafe
34import Test.Hspec
35
36import Data.Torrent
37import Network.BitTorrent.Address (IP, PeerAddr (PeerAddr), genPeerId)
38
39
40type ClientName = String
41
42
43#if !MIN_VERSION_network(2,6,3)
44instance Read PortNumber where
45 readsPrec = error "readsPrec"
46#endif
47
48data ClientOpts = ClientOpts
49 { peerPort :: PortNumber -- tcp port
50 , nodePort :: PortNumber -- udp port
51 }
52
53instance Default ClientOpts where
54 def = ClientOpts
55 { peerPort = 6881
56 , nodePort = 6881
57 }
58
59defRemoteOpts :: ClientOpts
60defRemoteOpts = def
61
62defThisOpts :: ClientOpts
63defThisOpts = def
64 { peerPort = 6882
65 , nodePort = 6882
66 }
67
68clientOptsParser :: Parser ClientOpts
69clientOptsParser = ClientOpts
70 <$> option auto
71 ( long "peer-port" <> short 'p'
72 <> value 6881 <> showDefault
73 <> metavar "NUM"
74 <> help "port to bind the specified bittorrent client"
75 )
76 <*> option auto
77 ( long "node-port" <> short 'n'
78 <> value 6881 <> showDefault
79 <> metavar "NUM"
80 <> help "port to bind node of the specified client"
81 )
82
83data EnvOpts = EnvOpts
84 { testClient :: Maybe ClientName
85 , testTorrents :: [FilePath]
86 , remoteOpts :: ClientOpts
87 , thisOpts :: ClientOpts
88 }
89
90instance Default EnvOpts where
91 def = EnvOpts
92 { testClient = Just "rtorrent"
93 , testTorrents = ["testfile.torrent"]
94 , remoteOpts = defRemoteOpts
95 , thisOpts = defThisOpts
96 }
97
98findConflicts :: EnvOpts -> [String]
99findConflicts EnvOpts {..}
100 | isNothing testClient = []
101 | peerPort remoteOpts == peerPort thisOpts = ["Peer port the same"]
102 | nodePort remoteOpts == nodePort thisOpts = ["Node port the same"]
103 | otherwise = []
104
105
106envOptsParser :: Parser EnvOpts
107envOptsParser = EnvOpts
108 <$> optional (strOption
109 ( long "bittorrent-client"
110 <> metavar "CLIENT"
111 <> help "torrent client to run"
112 ))
113 <*> pure []
114 <*> clientOptsParser
115 <*> clientOptsParser
116
117envOptsInfo :: ParserInfo EnvOpts
118envOptsInfo = info (helper <*> envOptsParser)
119 ( fullDesc
120 <> progDesc "The bittorrent library testsuite"
121 <> header ""
122 )
123
124-- do not modify this while test suite is running because spec items
125-- can run in parallel
126envOptsRef :: IORef EnvOpts
127envOptsRef = unsafePerformIO (newIORef def)
128
129-- | Should be used from spec items.
130getEnvOpts :: IO EnvOpts
131getEnvOpts = readIORef envOptsRef
132
133getThisOpts :: IO ClientOpts
134getThisOpts = thisOpts <$> getEnvOpts
135
136-- | Return 'Nothing' if remote client is not running.
137getRemoteOpts :: IO (Maybe ClientOpts)
138getRemoteOpts = do
139 EnvOpts {..} <- getEnvOpts
140 return $ const remoteOpts <$> testClient
141
142withRemote :: (ClientOpts -> Expectation) -> Expectation
143withRemote action = do
144 mopts <- getRemoteOpts
145 case mopts of
146 Nothing -> pendingWith "Remote client isn't running"
147 Just opts -> action opts
148
149withRemoteAddr :: (PeerAddr IP -> Expectation) -> Expectation
150withRemoteAddr action = do
151 withRemote $ \ ClientOpts {..} ->
152 action (PeerAddr Nothing "0.0.0.0" peerPort)
153
154getMyAddr :: IO (PeerAddr (Maybe IP))
155getMyAddr = do
156 ClientOpts {..} <- getThisOpts
157 pid <- genPeerId
158 return $ PeerAddr (Just pid) Nothing peerPort
159
160getTestTorrent :: IO Torrent
161getTestTorrent = do
162 EnvOpts {..} <- getEnvOpts
163 if L.null testTorrents
164 then error "getTestTorrent"
165 else fromFile ("res/" ++ L.head testTorrents)
166
167-- TODO fix EnvOpts parsing
168
169-- | Should be used by test suite driver.
170getOpts :: IO (EnvOpts, [String])
171getOpts = do
172 args <- getArgs
173-- case runParser SkipOpts envOptsParser args) (prefs idm) of
174 case (Right (def, args), ()) of
175 (Left err , _ctx) -> exitFailure
176 (Right (envOpts, hspecOpts), _ctx) -> do
177 let conflicts = findConflicts envOpts
178 unless (L.null conflicts) $ do
179 forM_ conflicts putStrLn
180 exitFailure
181
182 writeIORef envOptsRef envOpts
183 return (envOpts, hspecOpts)
diff --git a/bittorrent/tests/Data/TorrentSpec.hs b/bittorrent/tests/Data/TorrentSpec.hs
deleted file mode 100644
index b4a280e4..00000000
--- a/bittorrent/tests/Data/TorrentSpec.hs
+++ /dev/null
@@ -1,139 +0,0 @@
1{-# LANGUAGE TypeSynonymInstances #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE StandaloneDeriving #-}
4{-# OPTIONS -fno-warn-orphans #-}
5module Data.TorrentSpec (spec) where
6import Control.Applicative
7import Data.BEncode
8import Data.ByteString as BS
9import Data.ByteString.Lazy as BL
10import Data.Convertible
11import Data.Maybe
12import Data.Monoid
13import Data.Time
14import Network.URI
15import System.FilePath
16import System.Posix.Types
17import Test.Hspec
18import Test.QuickCheck
19import Test.QuickCheck.Instances ()
20
21import Data.Torrent
22import Network.BitTorrent.CoreSpec ()
23
24
25pico :: Gen (Maybe NominalDiffTime)
26pico = oneof
27 [ pure Nothing
28 , (Just . fromIntegral) <$> (arbitrary :: Gen Int)
29 ]
30
31instance Arbitrary COff where
32 arbitrary = fromIntegral <$> (arbitrary :: Gen Int)
33
34instance Arbitrary URIAuth where
35 arbitrary = URIAuth <$> arbitrary <*> arbitrary <*> arbitrary
36
37instance Arbitrary URI where
38 arbitrary
39 = pure $ fromJust $ parseURI "http://ietf.org/1737.txt?a=1&b=h#123"
40
41instance Arbitrary InfoHash where
42 arbitrary = do
43 bs <- BS.pack <$> vectorOf 20 arbitrary
44 pure $ either (const (error "arbitrary infohash")) id $ safeConvert bs
45
46instance Arbitrary a => Arbitrary (FileInfo a) where
47 arbitrary = FileInfo <$> arbitrary <*> arbitrary <*> arbitrary
48
49instance Arbitrary LayoutInfo where
50 arbitrary = oneof
51 [ SingleFile <$> arbitrary
52 , MultiFile <$> arbitrary <*> arbitrary
53 ]
54
55instance Arbitrary a => Arbitrary (Piece a) where
56 arbitrary = Piece <$> arbitrary <*> arbitrary
57
58instance Arbitrary HashList where
59 arbitrary = HashList <$> arbitrary
60
61instance Arbitrary PieceInfo where
62 arbitrary = PieceInfo <$> arbitrary <*> arbitrary
63
64instance Arbitrary InfoDict where
65 arbitrary = infoDictionary <$> arbitrary <*> arbitrary <*> arbitrary
66
67instance Arbitrary Torrent where
68 arbitrary = Torrent <$> arbitrary
69 <*> arbitrary <*> arbitrary <*> arbitrary
70 <*> pico <*> arbitrary <*> arbitrary
71 <*> arbitrary
72 <*> arbitrary <*> pure Nothing <*> arbitrary
73
74instance Arbitrary Magnet where
75 arbitrary = Magnet <$> arbitrary <*> arbitrary
76 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
77 <*> arbitrary <*> arbitrary <*> pure mempty
78
79type TestPair = (FilePath, String)
80
81-- TODO add a few more torrents here
82torrentList :: [TestPair]
83torrentList =
84 [ ( "res" </> "dapper-dvd-amd64.iso.torrent"
85 , "0221caf96aa3cb94f0f58d458e78b0fc344ad8bf")
86 ]
87
88infohashSpec :: (FilePath, String) -> Spec
89infohashSpec (filepath, expectedHash) = do
90 it ("should match " ++ filepath) $ do
91 torrent <- fromFile filepath
92 let actualHash = show $ idInfoHash $ tInfoDict torrent
93 actualHash `shouldBe` expectedHash
94
95magnetEncoding :: Magnet -> IO ()
96magnetEncoding m = parseMagnet (renderMagnet m) `shouldBe` Just m
97
98data T a = T
99
100prop_properBEncode :: Show a => BEncode a => Eq a
101 => T a -> a -> IO ()
102prop_properBEncode _ expected = actual `shouldBe` Right expected
103 where
104 actual = decode $ BL.toStrict $ encode expected
105
106spec :: Spec
107spec = do
108 describe "info hash" $ do
109 mapM_ infohashSpec torrentList
110
111 describe "accumPosition" $ do
112 it "" $ property $ \ p1 p2 p3 s1 s2 s3 ->
113 accumPositions [(p1, s1), (p2, s2), (p3, s3)]
114 `shouldBe` [(p1, (0, s1)), (p2, (s1, s2)), (p3, (s1 + s2, s3))]
115
116 describe "FileInfo" $ do
117 it "properly bencoded" $ property $
118 prop_properBEncode (T :: T (FileInfo BS.ByteString))
119
120 describe "LayoutInfo" $ do
121 it "properly bencoded" $ property $
122 prop_properBEncode (T :: T LayoutInfo)
123
124 describe "Torrent" $ do
125 it "property bencoded" $ property $
126 prop_properBEncode (T :: T Torrent)
127
128 describe "Magnet" $ do
129 it "properly encoded" $ property $ magnetEncoding
130
131 it "parse base32" $ do
132 let magnet = "magnet:?xt=urn:btih:CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6"
133 let ih = "CT76LXJDDCH5LS2TUHKH6EUJ3NYKX4Y6"
134 parseMagnet magnet `shouldBe` Just (nullMagnet ih)
135
136 it "parse base16" $ do
137 let magnet = "magnet:?xt=urn:btih:0123456789abcdef0123456789abcdef01234567"
138 let ih = "0123456789abcdef0123456789abcdef01234567"
139 parseMagnet magnet `shouldBe` Just (nullMagnet ih)
diff --git a/bittorrent/tests/Main.hs b/bittorrent/tests/Main.hs
deleted file mode 100644
index 5ed953da..00000000
--- a/bittorrent/tests/Main.hs
+++ /dev/null
@@ -1,97 +0,0 @@
1{-# LANGUAGE RecordWildCards #-}
2module Main where
3import Control.Exception
4import Control.Monad
5import Data.Functor
6import Data.Maybe
7import System.Directory
8import System.Exit
9import System.Environment
10import System.FilePath
11import System.Process
12import Text.Printf
13import Test.Hspec
14
15import Config
16import qualified Spec as Generated
17
18
19type Command = String
20type Descr = (ClientName, ClientOpts -> FilePath -> Command)
21
22torrents :: [FilePath]
23torrents =
24 [ "dapper-dvd-amd64-iso.torrent"
25 , "pkg.torrent"
26 , "testfile.torrent"
27 ]
28
29rtorrentSessionDir :: String
30rtorrentSessionDir = "rtorrent-sessiondir"
31
32sessionName :: String -- screen session name
33sessionName = "bittorrent-testsuite"
34
35tmpDir :: FilePath
36tmpDir = "res"
37
38clients :: [Descr]
39clients =
40 [ ("rtorrent"
41 , \ ClientOpts {..} tfile -> printf
42 "rtorrent -p %i-%i -O dht=on -O dht_port=%i -O session=%s %s"
43 (fromEnum peerPort) (fromEnum peerPort) (fromEnum nodePort)
44 rtorrentSessionDir tfile
45 )
46 ]
47
48setupEnv :: EnvOpts -> IO (Maybe ())
49setupEnv EnvOpts {..}
50 | Just client <- testClient
51 , Just mkCmd <- lookup client clients = do
52 _ <- printf "Setting up %s\n" client
53
54 let torrentPath = "testfile.torrent"
55 let runner = printf "screen -dm -S %s %s" sessionName
56 (mkCmd remoteOpts torrentPath)
57
58 wd <- getCurrentDirectory
59 createDirectoryIfMissing True (wd </> tmpDir </> rtorrentSessionDir)
60 _ <- createProcess (shell runner) { cwd = Just (wd </> tmpDir) }
61
62 return (Just ())
63
64 | Just client <- testClient = do
65 _ <- printf "Bad client `%s`, use one of %s\n" client (show (fst <$> clients))
66 return Nothing
67
68 | otherwise = do
69 _ <- printf "Running without remote client\n"
70 return (Just ())
71
72terminateEnv :: IO ()
73terminateEnv = do
74 wd <- getCurrentDirectory
75 removeDirectoryRecursive (wd </> tmpDir </> rtorrentSessionDir)
76 _ <- printf "closing screen session: %s\n" sessionName
77 _ <- system (printf "screen -S %s -X quit" sessionName)
78 return ()
79
80runTestSuite :: [String] -> IO ExitCode
81runTestSuite args = do
82 _ <- printf "running hspec test suite with args: %s\n" (show args)
83 catch (withArgs args (hspec Generated.spec) >> return ExitSuccess) return
84
85withEnv :: EnvOpts -> IO a -> IO a
86withEnv opts action = bracket (setupEnv opts) terminate (const action)
87 where
88 terminate running = do
89 when (isJust running) $ do
90 terminateEnv
91
92main :: IO ()
93main = do
94 (envOpts, suiteArgs) <- getOpts
95 withEnv envOpts $ do
96 code <- runTestSuite suiteArgs
97 exitWith code
diff --git a/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs b/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs
deleted file mode 100644
index d51bab02..00000000
--- a/bittorrent/tests/Network/BitTorrent/Client/HandleSpec.hs
+++ /dev/null
@@ -1,19 +0,0 @@
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
deleted file mode 100644
index e9b17a42..00000000
--- a/bittorrent/tests/Network/BitTorrent/CoreSpec.hs
+++ /dev/null
@@ -1,309 +0,0 @@
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
7#if MIN_VERSION_iproute(1,7,4)
8import Data.IP hiding (fromSockAddr)
9#else
10import Data.IP
11#endif
12import Data.Serialize as S
13import Data.String
14import Data.Text.Encoding as T
15import Data.Word
16import Network
17import Test.Hspec
18import Test.QuickCheck
19import Test.QuickCheck.Instances ()
20
21import Network.BitTorrent.Address
22
23
24instance Arbitrary IPv4 where
25 arbitrary = do
26 a <- choose (0, 255)
27 b <- choose (0, 255)
28 c <- choose (0, 255)
29 d <- choose (0, 255)
30 return $ toIPv4 [a, b, c, d]
31
32instance Arbitrary IPv6 where
33 arbitrary = do
34 a <- choose (0, fromIntegral (maxBound :: Word16))
35 b <- choose (0, fromIntegral (maxBound :: Word16))
36 c <- choose (0, fromIntegral (maxBound :: Word16))
37 d <- choose (0, fromIntegral (maxBound :: Word16))
38 e <- choose (0, fromIntegral (maxBound :: Word16))
39 f <- choose (0, fromIntegral (maxBound :: Word16))
40 g <- choose (0, fromIntegral (maxBound :: Word16))
41 h <- choose (0, fromIntegral (maxBound :: Word16))
42 return $ toIPv6 [a, b, c, d, e, f, g, h]
43
44instance Arbitrary IP where
45 arbitrary = frequency
46 [ (1, IPv4 <$> arbitrary)
47 , (1, IPv6 <$> arbitrary)
48 ]
49
50instance Arbitrary PortNumber where
51 arbitrary = fromIntegral <$> (arbitrary :: Gen Word16)
52
53instance Arbitrary PeerId where
54 arbitrary = oneof
55 [ azureusStyle defaultClientId defaultVersionNumber
56 <$> (T.encodeUtf8 <$> arbitrary)
57 , shadowStyle 'X' defaultVersionNumber
58 <$> (T.encodeUtf8 <$> arbitrary)
59 ]
60
61instance Arbitrary a => Arbitrary (PeerAddr a) where
62 arbitrary = PeerAddr <$> arbitrary <*> arbitrary <*> arbitrary
63
64instance Arbitrary NodeId where
65 arbitrary = fromString <$> vector 20
66
67instance Arbitrary a => Arbitrary (NodeAddr a) where
68 arbitrary = NodeAddr <$> arbitrary <*> arbitrary
69
70instance Arbitrary a => Arbitrary (NodeInfo a) where
71 arbitrary = NodeInfo <$> arbitrary <*> arbitrary
72
73spec :: Spec
74spec = do
75 describe "PeerId" $ do
76 it "properly bencoded" $ do
77 BE.decode "20:01234567890123456789"
78 `shouldBe` Right ("01234567890123456789" :: PeerId)
79
80 describe "PortNumber" $ do
81 it "properly serialized" $ do
82 S.decode "\x1\x2" `shouldBe` Right (258 :: PortNumber)
83 S.encode (258 :: PortNumber) `shouldBe` "\x1\x2"
84
85 it "properly bencoded" $ do
86 BE.decode "i80e" `shouldBe` Right (80 :: PortNumber)
87
88 it "fail if port number is invalid" $ do
89 (BE.decode "i-10e" :: BE.Result PortNumber)
90 `shouldBe`
91 Left "fromBEncode: unable to decode PortNumber: -10"
92
93 (BE.decode "i70000e" :: BE.Result PortNumber)
94 `shouldBe`
95 Left "fromBEncode: unable to decode PortNumber: 70000"
96
97 describe "Peer IPv4" $ do
98 it "properly serialized" $ do
99 S.decode "\x1\x2\x3\x4" `shouldBe` Right (toIPv4 [1, 2, 3, 4])
100 S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4"
101
102 it "properly serialized (iso)" $ property $ \ ip -> do
103 S.decode (S.encode ip) `shouldBe` Right (ip :: IPv4)
104
105 it "properly bencoded" $ do
106 BE.decode "11:168.192.0.1" `shouldBe` Right (toIPv4 [168, 192, 0, 1])
107 BE.encode (toIPv4 [168, 192, 0, 1]) `shouldBe` "11:168.192.0.1"
108
109 it "properly bencoded (iso)" $ property $ \ ip ->
110 BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4)
111
112 it "fail gracefully on invalid strings" $ do
113 BE.decode "3:1.1" `shouldBe`
114 (Left "fromBEncode: unable to decode IP: 1.1" :: BE.Result IPv4)
115
116 it "fail gracefully on invalid bencode" $ do
117 BE.decode "i10e" `shouldBe`
118 (Left "fromBEncode: unable to decode IP: addr should be a bstring"
119 :: BE.Result IPv4)
120
121 describe "Peer IPv6" $ do
122 it "properly serialized" $ do
123 S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
124 `shouldBe`
125 Right ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6)
126
127 S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IPv6)
128 `shouldBe`
129 "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
130
131 it "properly serialized (iso)" $ property $ \ ip ->
132 S.decode (S.encode ip) `shouldBe` Right (ip :: IPv6)
133
134 it "properly bencoded" $ do
135 BE.decode "3:::1" `shouldBe` Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])
136 BE.encode (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]) `shouldBe`
137 "23:00:00:00:00:00:00:00:01"
138
139 BE.decode "23:00:00:00:00:00:00:00:01"
140 `shouldBe`
141 Right (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])
142
143 it "properly bencoded iso" $ property $ \ ip ->
144 BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IPv4)
145
146 it "fail gracefully on invalid strings" $ do
147 BE.decode "4:g::1" `shouldBe`
148 (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IPv6)
149
150 it "fail gracefully on invalid bencode" $ do
151 BE.decode "i10e" `shouldBe`
152 (Left "fromBEncode: unable to decode IP: addr should be a bstring"
153 :: BE.Result IPv6)
154
155
156 describe "Peer IP" $ do
157 it "properly serialized IPv6" $ do
158 S.decode "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
159 `shouldBe`
160 Right ("102:304:506:708:90a:b0c:d0e:f10" :: IP)
161
162 S.encode ("102:304:506:708:90a:b0c:d0e:f10" :: IP)
163 `shouldBe`
164 "\x1\x2\x3\x4\x5\x6\x7\x8\x9\xa\xb\xc\xd\xe\xf\x10"
165
166 it "properly serialized (iso) IPv6" $ property $ \ ip ->
167 S.decode (S.encode ip) `shouldBe` Right (ip :: IP)
168
169 it "properly serialized IPv4" $ do
170 S.decode "\x1\x2\x3\x4" `shouldBe` Right (IPv4 $ toIPv4 [1, 2, 3, 4])
171 S.encode (toIPv4 [1, 2, 3, 4]) `shouldBe` "\x1\x2\x3\x4"
172
173 it "properly serialized (iso) IPv4" $ property $ \ ip -> do
174 S.decode (S.encode ip) `shouldBe` Right (ip :: IP)
175
176 it "properly bencoded" $ do
177 BE.decode "11:168.192.0.1" `shouldBe`
178 Right (IPv4 (toIPv4 [168, 192, 0, 1]))
179
180 BE.decode "3:::1" `shouldBe` Right
181 (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]))
182
183 BE.encode (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1])) `shouldBe`
184 "23:00:00:00:00:00:00:00:01"
185
186 BE.decode "23:00:00:00:00:00:00:00:01"
187 `shouldBe`
188 Right (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]))
189
190 it "properly bencoded iso" $ property $ \ ip ->
191 BE.decode (BL.toStrict (BE.encode ip)) `shouldBe` Right (ip :: IP)
192
193 it "fail gracefully on invalid strings" $ do
194 BE.decode "4:g::1" `shouldBe`
195 (Left "fromBEncode: unable to decode IP: g::1" :: BE.Result IP)
196
197 it "fail gracefully on invalid bencode" $ do
198 BE.decode "i10e" `shouldBe`
199 (Left "fromBEncode: unable to decode IP: addr should be a bstring"
200 :: BE.Result IP)
201
202 describe "PeerAddr" $ do
203 it "IsString" $ do
204 ("127.0.0.1:80" :: PeerAddr IP)
205 `shouldBe` PeerAddr Nothing "127.0.0.1" 80
206
207 ("127.0.0.1:80" :: PeerAddr IPv4)
208 `shouldBe` PeerAddr Nothing "127.0.0.1" 80
209
210 ("[::1]:80" :: PeerAddr IP)
211 `shouldBe` PeerAddr Nothing "::1" 80
212
213 ("[::1]:80" :: PeerAddr IPv6)
214 `shouldBe` PeerAddr Nothing "::1" 80
215
216 it "properly bencoded (iso)" $ property $ \ addr ->
217 BE.decode (BL.toStrict (BE.encode addr))
218 `shouldBe` Right (addr :: PeerAddr IP)
219
220
221 it "properly bencoded (ipv4)" $ do
222 BE.decode "d2:ip11:168.192.0.1\
223 \7:peer id20:01234567890123456789\
224 \4:porti6881e\
225 \e"
226 `shouldBe`
227 Right (PeerAddr (Just "01234567890123456789")
228 (IPv4 (toIPv4 [168, 192, 0, 1]))
229 6881)
230
231 it "properly bencoded (ipv6)" $ do
232 BE.decode "d2:ip3:::1\
233 \7:peer id20:01234567890123456789\
234 \4:porti6881e\
235 \e"
236 `shouldBe`
237 Right (PeerAddr (Just "01234567890123456789")
238 (IPv6 (toIPv6 [0, 0, 0, 0, 0, 0, 0, 1]))
239 6881)
240
241 it "peer id is optional" $ do
242 BE.decode "d2:ip11:168.192.0.1\
243 \4:porti6881e\
244 \e"
245 `shouldBe`
246 Right (PeerAddr Nothing (IPv4 (toIPv4 [168, 192, 0, 1])) 6881)
247
248 it "has sock addr for both ipv4 and ipv6" $ do
249 show (peerSockAddr "128.0.0.1:80") `shouldBe` "128.0.0.1:80"
250 show (peerSockAddr "[::1]:8080" ) `shouldBe` "[::1]:8080"
251
252 describe "NodeId" $ do
253 it "properly serialized" $ do
254 S.decode "mnopqrstuvwxyz123456"
255 `shouldBe` Right ("mnopqrstuvwxyz123456" :: NodeId)
256
257 S.encode ("mnopqrstuvwxyz123456" :: NodeId)
258 `shouldBe` "mnopqrstuvwxyz123456"
259
260 it "properly serialized (iso)" $ property $ \ nid ->
261 S.decode (S.encode nid) `shouldBe`
262 Right (nid :: NodeId)
263
264 describe "NodeAddr" $ do
265 it "properly serialized" $ do
266 S.decode "\127\0\0\1\1\2" `shouldBe`
267 Right ("127.0.0.1:258" :: NodeAddr IPv4)
268
269 it "properly serialized (iso)" $ property $ \ nid ->
270 S.decode (S.encode nid) `shouldBe`
271 Right (nid :: NodeAddr IPv4)
272
273 describe "NodeInfo" $ do
274 it "properly serialized" $ do
275 S.decode "mnopqrstuvwxyz123456\
276 \\127\0\0\1\1\2" `shouldBe` Right
277 (NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258" :: NodeInfo IPv4)
278
279 it "properly serialized (iso)" $ property $ \ nid ->
280 S.decode (S.encode nid) `shouldBe`
281 Right (nid :: NodeInfo IPv4)
282
283 -- see <http://bittorrent.org/beps/bep_0020.html>
284 describe "Fingerprint" $ do
285 it "decode mainline encoded peer id" $ do
286 fingerprint "M4-3-6--xxxxxxxxxxxx" `shouldBe` "Mainline-4.3.6"
287 fingerprint "M4-20-8-xxxxxxxxxxxx" `shouldBe` "Mainline-4.20.8"
288
289 it "decode azureus encoded peer id" $ do
290 fingerprint "-AZ2060-xxxxxxxxxxxx" `shouldBe` "Azureus-2060"
291 fingerprint "-BS0000-xxxxxxxxxxxx" `shouldBe` "BTSlave-0"
292
293 it "decode Shad0w style peer id" $ do
294 fingerprint "S58B-----xxxxxxxxxxx" `shouldBe` "Shadow-5.8.11"
295 fingerprint "T58B-----xxxxxxxxxxx" `shouldBe` "BitTornado-5.8.11"
296
297 it "decode bitcomet style peer id" $ do
298 fingerprint "exbc01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49"
299 fingerprint "FUTB01xxxxxxxxxxxxxx" `shouldBe` "BitComet-48.49"
300 fingerprint "exbc01LORDxxxxxxxxxx" `shouldBe` "BitLord-48.49"
301
302 it "decode opera style peer id" $ do
303 fingerprint "OP0123xxxxxxxxxxxxxx" `shouldBe` "Opera-123"
304
305 it "decode ML donkey style peer id" $ do
306 fingerprint "-ML2.7.2-xxxxxxxxxxx" `shouldBe` "MLdonkey-0"
307
308-- TODO XBT, Bits on Wheels, Queen Bee, BitTyrant, TorrenTopia,
309-- BitSpirit, Rufus, G3 Torrent, FlashGet
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs
deleted file mode 100644
index 6f3c7489..00000000
--- a/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs
+++ /dev/null
@@ -1,221 +0,0 @@
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
deleted file mode 100644
index 93f78263..00000000
--- a/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs
+++ /dev/null
@@ -1,105 +0,0 @@
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
deleted file mode 100644
index 07a906ba..00000000
--- a/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs
+++ /dev/null
@@ -1,77 +0,0 @@
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
deleted file mode 100644
index 32e4c158..00000000
--- a/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs
+++ /dev/null
@@ -1,110 +0,0 @@
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
deleted file mode 100644
index e9473cbb..00000000
--- a/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs
+++ /dev/null
@@ -1,45 +0,0 @@
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
deleted file mode 100644
index a45d2212..00000000
--- a/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs
+++ /dev/null
@@ -1,42 +0,0 @@
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
deleted file mode 100644
index 77160eb5..00000000
--- a/bittorrent/tests/Network/BitTorrent/DHTSpec.hs
+++ /dev/null
@@ -1,60 +0,0 @@
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
deleted file mode 100644
index 1ba772f6..00000000
--- a/bittorrent/tests/Network/BitTorrent/Exchange/BitfieldSpec.hs
+++ /dev/null
@@ -1,14 +0,0 @@
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
deleted file mode 100644
index 2dc8e0b8..00000000
--- a/bittorrent/tests/Network/BitTorrent/Exchange/BlockSpec.hs
+++ /dev/null
@@ -1,35 +0,0 @@
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
deleted file mode 100644
index d654cda1..00000000
--- a/bittorrent/tests/Network/BitTorrent/Exchange/ConnectionSpec.hs
+++ /dev/null
@@ -1,58 +0,0 @@
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
deleted file mode 100644
index d46f2034..00000000
--- a/bittorrent/tests/Network/BitTorrent/Exchange/DownloadSpec.hs
+++ /dev/null
@@ -1,59 +0,0 @@
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
deleted file mode 100644
index d615b1ff..00000000
--- a/bittorrent/tests/Network/BitTorrent/Exchange/MessageSpec.hs
+++ /dev/null
@@ -1,102 +0,0 @@
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
deleted file mode 100644
index bf5b95a1..00000000
--- a/bittorrent/tests/Network/BitTorrent/Exchange/SessionSpec.hs
+++ /dev/null
@@ -1,64 +0,0 @@
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
deleted file mode 100644
index 337e7add..00000000
--- a/bittorrent/tests/Network/BitTorrent/Internal/CacheSpec.hs
+++ /dev/null
@@ -1,7 +0,0 @@
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
deleted file mode 100644
index acbfd84c..00000000
--- a/bittorrent/tests/Network/BitTorrent/Internal/ProgressSpec.hs
+++ /dev/null
@@ -1,13 +0,0 @@
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
deleted file mode 100644
index bba9d0e2..00000000
--- a/bittorrent/tests/Network/BitTorrent/Tracker/ListSpec.hs
+++ /dev/null
@@ -1,40 +0,0 @@
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
deleted file mode 100644
index 29854d58..00000000
--- a/bittorrent/tests/Network/BitTorrent/Tracker/MessageSpec.hs
+++ /dev/null
@@ -1,173 +0,0 @@
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
deleted file mode 100644
index e928f917..00000000
--- a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/HTTPSpec.hs
+++ /dev/null
@@ -1,95 +0,0 @@
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
deleted file mode 100644
index 73acb3fa..00000000
--- a/bittorrent/tests/Network/BitTorrent/Tracker/RPC/UDPSpec.hs
+++ /dev/null
@@ -1,144 +0,0 @@
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
deleted file mode 100644
index dfc13a1e..00000000
--- a/bittorrent/tests/Network/BitTorrent/Tracker/RPCSpec.hs
+++ /dev/null
@@ -1,79 +0,0 @@
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
deleted file mode 100644
index 72936ee7..00000000
--- a/bittorrent/tests/Network/BitTorrent/Tracker/SessionSpec.hs
+++ /dev/null
@@ -1,61 +0,0 @@
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
deleted file mode 100644
index b95e2df4..00000000
--- a/bittorrent/tests/Network/BitTorrent/Tracker/TestData.hs
+++ /dev/null
@@ -1,93 +0,0 @@
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
diff --git a/bittorrent/tests/Network/KRPC/MessageSpec.hs b/bittorrent/tests/Network/KRPC/MessageSpec.hs
deleted file mode 100644
index 498ef679..00000000
--- a/bittorrent/tests/Network/KRPC/MessageSpec.hs
+++ /dev/null
@@ -1,72 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Network.KRPC.MessageSpec (spec) where
4import Control.Applicative
5import Data.ByteString.Lazy as BL
6import Test.Hspec
7import Test.QuickCheck
8import Test.QuickCheck.Instances ()
9
10import Data.BEncode as BE
11import Network.KRPC.Message
12
13instance Arbitrary ErrorCode where
14 arbitrary = arbitraryBoundedEnum
15
16instance Arbitrary KError where
17 arbitrary = KError <$> arbitrary <*> arbitrary <*> arbitrary
18
19instance Arbitrary KQuery where
20 arbitrary = KQuery <$> pure (BInteger 0) <*> arbitrary <*> arbitrary
21
22instance Arbitrary KResponse where
23 -- TODO: Abitrary instance for ReflectedIP
24 arbitrary = KResponse <$> pure (BList []) <*> arbitrary <*> pure Nothing
25
26instance Arbitrary KMessage where
27 arbitrary = frequency
28 [ (1, Q <$> arbitrary)
29 , (1, R <$> arbitrary)
30 , (1, E <$> arbitrary)
31 ]
32
33spec :: Spec
34spec = do
35 describe "error message" $ do
36 it "properly bencoded (iso)" $ property $ \ ke ->
37 BE.decode (BL.toStrict (BE.encode ke)) `shouldBe` Right (ke :: KError)
38
39 it "properly bencoded" $ do
40 BE.decode "d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee"
41 `shouldBe` Right (KError GenericError "A Generic Error Ocurred" "aa")
42
43 BE.decode "d1:eli202e22:A Server Error Ocurrede1:t2:bb1:y1:ee"
44 `shouldBe` Right (KError ServerError "A Server Error Ocurred" "bb")
45
46 BE.decode "d1:eli203e24:A Protocol Error Ocurrede1:t2:cc1:y1:ee"
47 `shouldBe` Right (KError ProtocolError "A Protocol Error Ocurred" "cc")
48
49 BE.decode "d1:eli204e30:Attempt to call unknown methode1:t2:dd1:y1:ee"
50 `shouldBe` Right
51 (KError MethodUnknown "Attempt to call unknown method" "dd")
52
53 describe "query message" $ do
54 it "properly bencoded (iso)" $ property $ \ kq ->
55 BE.decode (BL.toStrict (BE.encode kq)) `shouldBe` Right (kq :: KQuery)
56
57 it "properly bencoded" $ do
58 BE.decode "d1:ale1:q4:ping1:t2:aa1:y1:qe" `shouldBe`
59 Right (KQuery (BList []) "ping" "aa")
60
61
62 describe "response message" $ do
63 it "properly bencoded (iso)" $ property $ \ kr ->
64 BE.decode (BL.toStrict (BE.encode kr)) `shouldBe` Right (kr :: KResponse)
65
66 it "properly bencoded" $ do
67 BE.decode "d1:rle1:t2:aa1:y1:re" `shouldBe`
68 Right (KResponse (BList []) "aa" Nothing)
69
70 describe "generic message" $ do
71 it "properly bencoded (iso)" $ property $ \ km ->
72 BE.decode (BL.toStrict (BE.encode km)) `shouldBe` Right (km :: KMessage)
diff --git a/bittorrent/tests/Network/KRPC/MethodSpec.hs b/bittorrent/tests/Network/KRPC/MethodSpec.hs
deleted file mode 100644
index c1c58282..00000000
--- a/bittorrent/tests/Network/KRPC/MethodSpec.hs
+++ /dev/null
@@ -1,52 +0,0 @@
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE DeriveDataTypeable #-}
6{-# OPTIONS_GHC -fno-warn-orphans #-}
7module Network.KRPC.MethodSpec where
8import Control.Applicative
9import Data.BEncode
10import Data.ByteString as BS
11import Data.Typeable
12import Network.KRPC
13import Test.Hspec
14
15
16data Ping = Ping
17 deriving (Show, Eq, Typeable)
18
19instance BEncode Ping where
20 toBEncode Ping = toBEncode ()
21 fromBEncode b = Ping <$ (fromBEncode b :: Result ())
22
23instance KRPC Ping Ping
24
25ping :: Monad h => Handler h
26ping = handler $ \ _ Ping -> return Ping
27
28newtype Echo a = Echo a
29 deriving (Show, Eq, BEncode, Typeable)
30
31echo :: Monad h => Handler h
32echo = handler $ \ _ (Echo a) -> return (Echo (a :: ByteString))
33
34instance (Typeable a, BEncode a) => KRPC (Echo a) (Echo a)
35
36spec :: Spec
37spec = do
38 describe "ping method" $ do
39 it "name is ping" $ do
40 (method :: Method Ping Ping) `shouldBe` "ping"
41
42 it "has pretty Show instance" $ do
43 show (method :: Method Ping Ping) `shouldBe` "ping :: Ping -> Ping"
44
45 describe "echo method" $ do
46 it "is overloadable" $ do
47 (method :: Method (Echo Int ) (Echo Int )) `shouldBe` "echo int"
48 (method :: Method (Echo Bool) (Echo Bool)) `shouldBe` "echo bool"
49
50 it "has pretty Show instance" $ do
51 show (method :: Method (Echo Int) (Echo Int))
52 `shouldBe` "echo int :: Echo Int -> Echo Int" \ No newline at end of file
diff --git a/bittorrent/tests/Network/KRPCSpec.hs b/bittorrent/tests/Network/KRPCSpec.hs
deleted file mode 100644
index eabcc817..00000000
--- a/bittorrent/tests/Network/KRPCSpec.hs
+++ /dev/null
@@ -1,59 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Network.KRPCSpec (spec) where
4import Control.Monad.Logger
5import Control.Monad.Reader
6import Network.KRPC
7import Network.KRPC.MethodSpec hiding (spec)
8import Test.Hspec
9
10servAddr :: SockAddr
11servAddr = SockAddrInet 6000 (256 * 256 * 256 + 127)
12
13handlers :: [Handler IO]
14handlers =
15 [ handler $ \ _ Ping -> return Ping
16 , handler $ \ _ (Echo a) -> return (Echo (a :: Bool))
17 , handler $ \ _ (Echo a) -> return (Echo (a :: Int))
18 ]
19
20instance MonadLogger IO where
21 monadLoggerLog _ _ _ _ = return ()
22
23opts :: Options
24opts = def { optQueryTimeout = 1 }
25
26spec :: Spec
27spec = do
28 let qr :: MonadKRPC h m => SockAddr -> Echo Int -> m (Echo Int)
29 qr = query
30
31 describe "manager" $ do
32 it "is active until closeManager called" $ do
33 m <- newManager opts servAddr []
34 isActive m `shouldReturn` True
35 closeManager m
36 isActive m `shouldReturn` False
37
38 describe "query" $ do
39 it "run handlers" $ do
40 let int = 0xabcd :: Int
41 (withManager opts servAddr handlers $ runReaderT $ do
42 listen
43 query servAddr (Echo int))
44 `shouldReturn` Echo int
45
46 it "count transactions properly" $ do
47 (withManager opts servAddr handlers $ runReaderT $ do
48 listen
49 _ <- qr servAddr (Echo 0xabcd)
50 _ <- qr servAddr (Echo 0xabcd)
51 getQueryCount
52 )
53 `shouldReturn` 2
54
55 it "throw timeout exception" $ do
56 (withManager opts servAddr handlers $ runReaderT $ do
57 qr servAddr (Echo 0xabcd)
58 )
59 `shouldThrow` (== TimeoutExpired)
diff --git a/bittorrent/tests/Readme.md b/bittorrent/tests/Readme.md
deleted file mode 100644
index 7a9d8914..00000000
--- a/bittorrent/tests/Readme.md
+++ /dev/null
@@ -1,4 +0,0 @@
1Prerequisites
2=============
3
4To run test suite you need rtorrent and screen installed.
diff --git a/bittorrent/tests/Spec.hs b/bittorrent/tests/Spec.hs
deleted file mode 100644
index b4e92e75..00000000
--- a/bittorrent/tests/Spec.hs
+++ /dev/null
@@ -1 +0,0 @@
1{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
diff --git a/bittorrent/tests/System/Torrent/FileMapSpec.hs b/bittorrent/tests/System/Torrent/FileMapSpec.hs
deleted file mode 100644
index 29252925..00000000
--- a/bittorrent/tests/System/Torrent/FileMapSpec.hs
+++ /dev/null
@@ -1,116 +0,0 @@
1-- this is test string used in the 'spec' --- don't touch me!
2module System.Torrent.FileMapSpec (spec) where
3
4import Control.Monad.Loops
5import Data.List as L
6import Data.ByteString.Lazy as BL
7import System.Directory
8import System.FilePath
9import System.IO.Temp
10import Test.Hspec
11
12import Data.Torrent
13import System.Torrent.FileMap as FM
14
15
16withLayout :: (FileLayout FileSize -> IO ()) -> IO ()
17withLayout f = do
18 tmp <- getTemporaryDirectory
19 withTempDirectory tmp "bittorrentTestDir" $ \dir ->
20 f [ (dir </> "a", 2)
21 , (dir </> "b", 3)
22 , (dir </> "c", 2)
23 ] `seq` return ()
24
25spec :: Spec
26spec = do
27 describe "mmapFiles" $ do
28 it "creates new files" $ withLayout $ \layout -> do
29 m <- mmapFiles ReadWriteEx layout
30 unmapFiles m
31
32 (doesFileExist . fst) `allM` layout
33 `shouldReturn` True
34
35 describe "size" $ do
36 it "is equal to the layout size" $ withLayout $ \layout -> do
37 m <- mmapFiles ReadOnly layout
38 FM.size m `shouldBe` L.sum (L.map snd layout)
39 unmapFiles m
40
41 describe "readBytes" $ do
42 it "read from files" $ do
43 let thisFile = [("tests/System/Torrent/FileMapSpec.hs", 15)]
44 m <- mmapFiles ReadOnly thisFile
45 readBytes 3 15 m `shouldReturn` "this is test"
46 unmapFiles m
47
48 it "ignore underflow reads" $ withLayout $ \layout -> do
49 m <- mmapFiles ReadOnly layout
50 readBytes (-1) 1 m `shouldReturn` ""
51 readBytes (-5) 12 m `shouldReturn` ""
52 unmapFiles m
53
54 it "crop overflow reads" $ withLayout $ \layout -> do
55 _m <- mmapFiles ReadWrite layout
56 writeBytes 5 "cc" _m
57 unmapFiles _m
58
59 m <- mmapFiles ReadOnly layout
60 readBytes 5 10 m `shouldReturn` "cc"
61 unmapFiles m
62
63 describe "writeBytes" $ do
64 it "writes to files" $ withLayout $ \layout -> do
65 m <- mmapFiles ReadWriteEx layout
66 writeBytes 0 "a" m
67 readBytes 0 1 m `shouldReturn` "a"
68 writeBytes 1 "ab" m
69 readBytes 1 2 m `shouldReturn` "ab"
70 writeBytes 3 "b" m
71 readBytes 3 1 m `shouldReturn` "b"
72 writeBytes 4 "bc" m
73 readBytes 4 2 m `shouldReturn` "bc"
74 writeBytes 6 "c" m
75 readBytes 6 1 m `shouldReturn` "c"
76 readBytes 0 7 m `shouldReturn` "aabbbcc"
77 unmapFiles m
78
79 BL.readFile (fst (layout !! 0)) `shouldReturn` "aa"
80 BL.readFile (fst (layout !! 1)) `shouldReturn` "bbb"
81 BL.readFile (fst (layout !! 2)) `shouldReturn` "cc"
82
83 let max_page_size = 4 * 1024 * 1024
84 let long_bs = BL.replicate (fromIntegral max_page_size) 0
85
86 it "no buffer underflow errors" $ withLayout $ \layout -> do
87 m <- mmapFiles ReadWrite layout
88 writeBytes (1 - max_page_size) long_bs m
89 unmapFiles m
90
91 it "no buffer overflow errors" $ withLayout $ \layout -> do
92 m <- mmapFiles ReadWrite layout
93 writeBytes 5 long_bs m
94 unmapFiles m
95
96 it "ignore underflow writes" $ withLayout $ \layout -> do
97 _m <- mmapFiles ReadWrite layout
98 writeBytes 0 "aa" _m
99 unmapFiles _m
100
101 m <- mmapFiles ReadWrite layout
102 writeBytes (-1) "hhh" m
103 unmapFiles m
104 BL.readFile (fst (layout !! 0)) `shouldReturn` "aa"
105
106 it "crop overflow writes" $ withLayout $ \layout -> do
107 m <- mmapFiles ReadWrite layout
108 writeBytes 5 "ddddddddd" m
109 unmapFiles m
110 BL.readFile (fst (layout !! 2)) `shouldReturn` "dd"
111
112 describe "from/to lazy bytestring" $ do
113 it "isomorphic to lazy bytestring" $ withLayout $ \layout -> do
114 m <- mmapFiles ReadOnly layout
115 fromLazyByteString (toLazyByteString m) `shouldBe` m
116 unmapFiles m
diff --git a/bittorrent/tests/System/Torrent/StorageSpec.hs b/bittorrent/tests/System/Torrent/StorageSpec.hs
deleted file mode 100644
index b5e49078..00000000
--- a/bittorrent/tests/System/Torrent/StorageSpec.hs
+++ /dev/null
@@ -1,91 +0,0 @@
1module System.Torrent.StorageSpec (spec) where
2import Data.ByteString.Lazy as BL
3import Data.Conduit as C
4import Data.Conduit.List as C
5import System.FilePath
6import System.Directory
7import System.IO.Unsafe
8import Test.Hspec
9
10import Data.Torrent
11import Network.BitTorrent.Exchange.Bitfield as BF
12import System.Torrent.Storage
13
14
15layout :: FileLayout FileSize
16layout =
17 [ (dir </> "_a", 20)
18 , (dir </> "_b", 50)
19 , (dir </> "_c", 100)
20 , (dir </> "_d", 5)
21 ]
22 where
23 dir = unsafePerformIO $ getTemporaryDirectory
24
25createLayout :: IO ()
26createLayout = withStorage ReadWriteEx 1 layout (const (return ()))
27
28psize :: PieceSize
29psize = 16
30
31pcount :: PieceCount
32pcount = 11
33
34spec :: Spec
35spec = before createLayout $ do
36 describe "writePiece" $ do
37 it "should fail gracefully on write operation in RO mode" $ do
38 withStorage ReadOnly 1 layout $ \ s ->
39 writePiece (Piece 0 "a") s `shouldThrow` (== StorageIsRO)
40
41 it "should fail if piece size do not match" $ do
42 withStorage ReadWrite 1 layout $ \ s ->
43 writePiece (Piece 0 "") s `shouldThrow` (== InvalidSize 0)
44
45 it "should fail on negative index" $ do
46 withStorage ReadWrite 1 layout $ \ s ->
47 writePiece (Piece (-1) "") s `shouldThrow` (== InvalidIndex (-1))
48
49 it "should fail on out of upper bound index" $ do
50 withStorage ReadWrite 100 layout $ \ s -> do
51 let bs = BL.replicate 100 0
52 writePiece (Piece 0 bs) s
53
54 let bs' = BL.replicate 75 0
55 writePiece (Piece 1 bs') s
56
57 writePiece (Piece 2 bs') s `shouldThrow` (== InvalidIndex 2)
58
59 describe "readPiece" $ do
60 it "should fail on negative index" $
61 withStorage ReadOnly 1 layout $ \ s ->
62 readPiece (-1) s `shouldThrow` (== InvalidIndex (-1))
63
64 it "should fail on out of upper bound index" $ do
65 withStorage ReadOnly 100 layout $ \ s -> do
66 _ <- readPiece 1 s
67 readPiece 2 s `shouldThrow` (== InvalidIndex 2)
68
69 describe "sourceStorage" $ do
70 it "should source all chunks" $ do
71 withStorage ReadOnly psize layout $ \ s -> do
72 n <- sourceStorage s $$ C.fold (\ n _ -> succ n) 0
73 n `shouldBe` pcount
74
75 -- this test should fail if 'sourceStorage' test fail
76 describe "sinkStorage" $ do
77 it "should write all chunks" $ do
78 let byteVal = 0
79 let bzeroPiece p = p { pieceData = BL.replicate (BL.length (pieceData p)) byteVal }
80 let isZeroPiece p = (== byteVal) `BL.all` pieceData p
81
82 withStorage ReadWrite psize layout $ \ s -> do
83 sourceStorage s $= C.map bzeroPiece $$ sinkStorage s
84 b <- sourceStorage s $$ C.fold (\ b p -> b && isZeroPiece p) True
85 b `shouldBe` True
86
87 describe "genPieceInfo" $ do
88 it "" $ do
89 withStorage ReadWrite psize layout $ \ s -> do
90 bf <- genPieceInfo s >>= getBitfield s
91 bf `shouldSatisfy` BF.full \ No newline at end of file
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 09:20:18 +0000