summaryrefslogtreecommitdiff
path: root/tests/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'tests/Main.hs')
-rw-r--r--tests/Main.hs285
1 files changed, 29 insertions, 256 deletions
diff --git a/tests/Main.hs b/tests/Main.hs
index 3c58e2ed..439e9c4e 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -1,260 +1,33 @@
1-- | 1module Main where
2-- Copyright : (c) Sam Truzjan 2013 2
3-- License : BSD3 3import Spec
4-- Maintainer : pxqr.sta@gmail.com 4import System.Exit
5-- Stability : experimental 5import System.Environment
6-- Portability : portable 6import System.Process
7-- 7import Control.Exception
8-- Do not add other (than this) test suites without need. Do not use 8import Data.List
9-- linux-specific paths, use 'filepath' and 'directory' machinery.
10--
11{-# LANGUAGE StandaloneDeriving #-}
12{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13{-# LANGUAGE OverloadedStrings #-}
14module Main (main) where
15
16import Control.Applicative hiding (empty)
17import Data.ByteString (ByteString)
18import qualified Data.ByteString as B
19import qualified Data.ByteString.Lazy as Lazy
20import Data.List as L
21import Data.Maybe 9import Data.Maybe
22import Data.Word
23import Data.Serialize as S
24import Data.Text as T
25
26import Network
27import Network.URI
28
29import Test.QuickCheck as QC
30import Test.Framework as Framework (Test, defaultMain)
31import Test.Framework.Providers.QuickCheck2 (testProperty)
32
33import Data.Aeson as JSON
34import Data.BEncode as BE
35import Data.Torrent.Block
36import Data.Torrent.Bitfield as BF
37import Data.Torrent.Metainfo
38import Network.BitTorrent.Exchange.Protocol
39import Network.BitTorrent.Tracker
40import Network.BitTorrent.Tracker.Protocol
41import Network.BitTorrent.Tracker.HTTP
42import Network.BitTorrent.Peer
43
44-- import Debug.Trace
45
46
47data T a = T
48
49
50prop_properBEncode :: Show a => BEncodable a => Eq a => T a -> a -> Bool
51prop_properBEncode _ expected = actual == Right expected
52 where
53 actual = decoded $ Lazy.toStrict $ encoded expected
54
55instance Arbitrary URI where
56 arbitrary = pure $ fromJust
57 $ parseURI "http://exsample.com:80/123365_asd"
58
59instance Arbitrary Text where
60 arbitrary = T.pack <$> arbitrary
61
62{-
63{-----------------------------------------------------------------------
64 MemMap
65-----------------------------------------------------------------------}
66
67tmpdir :: FilePath
68tmpdir = "tmp"
69
70boundaryTest :: Assertion
71boundaryTest = do
72 f <- mallocTo (Fixed.interval 0 1) Fixed.empty
73 f <- mallocTo (Fixed.interval 1 2) f
74 writeElem f 0 (1 :: Word8)
75 writeElem f 1 (2 :: Word8)
76 bs <- readBytes (Fixed.interval 0 2) f
77 "\x1\x2" @=? bs
78
79mmapSingle :: Assertion
80mmapSingle = do
81 f <- mmapTo (tmpdir </> "single.test") (10, 5) 5 Fixed.empty
82 writeBytes (Fixed.interval 5 5) "abcde" f
83 bs <- readBytes (Fixed.interval 5 5) f
84 "abcde" @=? bs
85
86coalesceTest :: Assertion
87coalesceTest = do
88 f <- mmapTo (tmpdir </> "a.test") (0, 1) 10 Fixed.empty
89 f <- mmapTo (tmpdir </> "bc.test") (0, 2) 12 f
90 f <- mmapTo (tmpdir </> "c.test") (0, 1) 13 f
91 writeBytes (Fixed.interval 10 4) "abcd" f
92 bs <- readBytes (Fixed.interval 10 4) f
93 "abcd" @=? bs
94-}
95
96{-----------------------------------------------------------------------
97 Bitfield
98-----------------------------------------------------------------------}
99-- other properties are tested in IntervalSet
100
101prop_completenessRange :: Bitfield -> Bool
102prop_completenessRange bf = 0 <= c && c <= 1
103 where
104 c = completeness bf
105
106prop_minMax :: Bitfield -> Bool
107prop_minMax bf
108 | BF.null bf = True
109 | otherwise = BF.findMin bf <= BF.findMax bf
110
111prop_rarestInRange :: [Bitfield] -> Bool
112prop_rarestInRange xs = case rarest xs of
113 Just r -> 0 <= r
114 && r < totalCount (maximumBy (comparing totalCount) xs)
115 Nothing -> True
116
117{- this one should give pretty good coverage -}
118prop_differenceDeMorgan :: Bitfield -> Bitfield -> Bitfield -> Bool
119prop_differenceDeMorgan a b c =
120 (a `BF.difference` (b `BF.intersection` c))
121 == ((a `BF.difference` b) `BF.union` (a `BF.difference` c))
122 &&
123 (a `BF.difference` (b `BF.union` c))
124 == ((a `BF.difference` b) `BF.intersection` (a `BF.difference` c))
125
126 {-
127 [ -- mem map
128 testCase "boudary" boundaryTest
129 , testCase "single" mmapSingle
130 , testCase "coalesce" coalesceTest
131 ]
132
133instance Arbitrary Bitfield where
134 arbitrary = mkBitfield <$> (succ . min 1000 <$> positive)
135 <*> arbitrary
136
137 testProperty "completeness range" prop_completenessRange
138 , testProperty "rarest in range" prop_rarestInRange
139 , testProperty "min less that max" prop_minMax
140 , testProperty "difference de morgan" prop_differenceDeMorgan
141-}
142{-----------------------------------------------------------------------
143 Handshake
144-----------------------------------------------------------------------}
145
146instance Arbitrary PeerId where
147 arbitrary = azureusStyle <$> pure defaultClientId
148 <*> arbitrary
149 <*> arbitrary
150
151instance Arbitrary InfoHash where
152 arbitrary = (hash . B.pack) <$> arbitrary
153
154instance Arbitrary Handshake where
155 arbitrary = defaultHandshake <$> arbitrary <*> arbitrary
156
157prop_cerealEncoding :: (Serialize a, Eq a) => T a -> [a] -> Bool
158prop_cerealEncoding _ msgs = S.decode (S.encode msgs) == Right msgs
159
160{-----------------------------------------------------------------------
161 Tracker/Scrape
162-----------------------------------------------------------------------}
163
164instance Arbitrary ScrapeInfo where
165 arbitrary = ScrapeInfo <$> arbitrary <*> arbitrary
166 <*> arbitrary <*> arbitrary
167
168-- | Note that in 6 esample we intensionally do not agree with
169-- specification, because taking in account '/' in query parameter
170-- seems to be meaningless. (And thats because other clients do not
171-- chunk uri by parts) Moreover in practice there should be no
172-- difference. (I think so)
173--
174test_scrape_url :: [Framework.Test]
175test_scrape_url = L.zipWith mkTest [1 :: Int ..] (check `L.map` tests)
176 where
177 check (iu, ou) = (parseURI iu >>= (`scrapeURL` [])
178 >>= return . show) == ou
179 tests =
180 [ ( "http://example.com/announce"
181 , Just "http://example.com/scrape")
182 , ( "http://example.com/x/announce"
183 , Just "http://example.com/x/scrape")
184 , ( "http://example.com/announce.php"
185 , Just "http://example.com/scrape.php")
186 , ( "http://example.com/a" , Nothing)
187 , ( "http://example.com/announce?x2%0644"
188 , Just "http://example.com/scrape?x2%0644")
189 , ( "http://example.com/announce?x=2/4"
190 , Just "http://example.com/scrape?x=2/4")
191-- , ("http://example.com/announce?x=2/4" , Nothing) -- by specs
192 , ("http://example.com/x%064announce" , Nothing)
193 ]
194
195 mkTest i = testProperty ("scrape test #" ++ show i)
196
197{-----------------------------------------------------------------------
198 P2P/message
199-----------------------------------------------------------------------}
200
201positive :: Gen Int
202positive = fromIntegral <$> (arbitrary :: Gen Word32)
203
204instance Arbitrary ByteString where
205 arbitrary = B.pack <$> arbitrary
206
207instance Arbitrary Lazy.ByteString where
208 arbitrary = Lazy.pack <$> arbitrary
209
210instance Arbitrary BlockIx where
211 arbitrary = BlockIx <$> positive <*> positive <*> positive
212
213instance Arbitrary Block where
214 arbitrary = Block <$> positive <*> positive <*> arbitrary
215
216instance Arbitrary PortNumber where
217 arbitrary = fromIntegral <$> (arbitrary :: Gen Word16)
218
219instance Arbitrary Message where
220 arbitrary = oneof
221 [ pure KeepAlive
222 , pure Choke
223 , pure Unchoke
224 , pure Interested
225 , pure NotInterested
226 , Have <$> positive
227 , pure $ Bitfield $ BF.haveNone 0
228 , Request <$> arbitrary
229 , Piece <$> arbitrary
230 , Cancel <$> arbitrary
231 , Port <$> arbitrary
232 ]
233-- todo add all messages
234
235prop_messageEncoding :: Message -> Bool
236prop_messageEncoding msg @ (Bitfield bf)
237 = case S.decode (S.encode msg) of
238 Right (Bitfield bf') -> bf == adjustSize (totalCount bf) bf'
239 _ -> False
240prop_messageEncoding msg
241 = S.decode (S.encode msg) == Right msg
242
243{-----------------------------------------------------------------------
244 Main
245-----------------------------------------------------------------------}
246 10
247allTests :: [Framework.Test] 11clients :: [(String, String)]
248allTests = 12clients = [
249 [ -- handshake module 13 ("rtorrent","rtorrent -p 51234-51234 res/testfile.torrent") ]
250 testProperty "handshake encoding" $
251 prop_cerealEncoding (T :: T Handshake)
252 , testProperty "message encoding" prop_messageEncoding
253 ] ++ test_scrape_url
254 ++
255 [ testProperty "scrape bencode" $
256 prop_properBEncode (T :: T ScrapeInfo)
257 ]
258 14
259main :: IO () 15main :: IO ()
260main = defaultMain allTests 16main = do
17 args <- getArgs
18 let cmd' = do
19 cl <- listToMaybe $ reverse
20 $ map (tail . dropWhile (/='='))
21 $ filter (isPrefixOf "--bittorrent-client=") args
22 cmd <- (++) "screen -dm -S bittorrent-testsuite " <$> lookup cl clients
23 return cmd
24 case cmd' of
25 Just cmd -> do _ <- system "screen -S bittorrent-testsuite -X quit"
26 createProcess (shell cmd) >> return ()
27 Nothing -> return ()
28
29 let args' = (filter (not . isPrefixOf "--bittorrent-client=") args)
30 code <- catch (withArgs args' hspecMain >> return ExitSuccess) return
31
32 _ <- system "screen -S bittorrent-testsuite -X quit"
33 exitWith code >> return ()
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 19:43:35 +0000