summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/Encoding.hs96
-rw-r--r--tests/Main.hs127
2 files changed, 118 insertions, 105 deletions
diff --git a/tests/Encoding.hs b/tests/Encoding.hs
deleted file mode 100644
index 78f0dfc1..00000000
--- a/tests/Encoding.hs
+++ /dev/null
@@ -1,96 +0,0 @@
1{-# LANGUAGE StandaloneDeriving #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# OPTIONS -fno-warn-orphans #-}
4module Encoding where
5
6import Control.Applicative
7import Data.Word
8import Data.ByteString (ByteString)
9import qualified Data.ByteString as B
10import Data.Serialize
11import Test.Framework (Test)
12import Test.Framework.Providers.QuickCheck2 (testProperty)
13import Test.QuickCheck
14
15
16import Network.URI
17import Network
18
19
20import Data.Bitfield
21import Data.Torrent
22import Network.BitTorrent
23
24
25positive :: Gen Int
26positive = fromIntegral <$> (arbitrary :: Gen Word32)
27
28instance Arbitrary ByteString where
29 arbitrary = B.pack <$> arbitrary
30
31instance Arbitrary BlockIx where
32 arbitrary = BlockIx <$> positive <*> positive <*> positive
33
34instance Arbitrary Block where
35 arbitrary = Block <$> positive <*> positive <*> arbitrary
36
37instance Arbitrary Bitfield where
38 arbitrary = mkBitfield <$> (succ . min 1000 <$> positive)
39 <*> arbitrary
40
41instance Arbitrary PortNumber where
42 arbitrary = fromIntegral <$> (arbitrary :: Gen Word16)
43
44instance Arbitrary Message where
45 arbitrary = oneof
46 [ pure KeepAlive
47 , pure Choke
48 , pure Unchoke
49 , pure Interested
50 , pure NotInterested
51 , Have <$> positive
52 , Bitfield <$> arbitrary
53 , Request <$> arbitrary
54 , Piece <$> arbitrary
55 , Cancel <$> arbitrary
56 , Port <$> arbitrary
57 ]
58
59instance Arbitrary PeerID where
60 arbitrary = azureusStyle <$> pure defaultClientID
61 <*> arbitrary
62 <*> arbitrary
63
64instance Arbitrary InfoHash where
65 arbitrary = (hash . B.pack) <$> arbitrary
66
67instance Arbitrary Handshake where
68 arbitrary = defaultHandshake <$> arbitrary <*> arbitrary
69
70
71data T a = T
72
73prop_encoding :: (Serialize a, Eq a) => T a -> [a] -> Bool
74prop_encoding _ msgs = decode (encode msgs) == Right msgs
75
76-- | Note that in 6 esample we intensionally do not agree with specification,
77-- because taking in account '/' in query parameter seems to be meaningless.
78-- (And thats because other clients do not chunk uri by parts)
79-- Moreover in practice there should be no difference. (I hope)
80--
81test_scrape_url :: [Test]
82test_scrape_url = zipWith mkTest [1 :: Int ..] (check `map` tests)
83 where
84 check (iu, ou) = (parseURI iu >>= (`scrapeURL` []) >>= return . show) == ou
85 tests =
86 [ ("http://example.com/announce" , Just "http://example.com/scrape")
87 , ("http://example.com/x/announce" , Just "http://example.com/x/scrape")
88 , ("http://example.com/announce.php" , Just "http://example.com/scrape.php")
89 , ("http://example.com/a" , Nothing)
90 , ("http://example.com/announce?x2%0644", Just "http://example.com/scrape?x2%0644")
91 , ("http://example.com/announce?x=2/4" , Just "http://example.com/scrape?x=2/4")
92-- , ("http://example.com/announce?x=2/4" , Nothing) -- by specs
93 , ("http://example.com/x%064announce" , Nothing)
94 ]
95
96 mkTest i = testProperty ("scrape test #" ++ show i)
diff --git a/tests/Main.hs b/tests/Main.hs
index ff571b6b..0e18a06b 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -1,28 +1,35 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE StandaloneDeriving #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE OverloadedStrings #-}
2module Main (main) where 4module Main (main) where
3 5
4import Control.Applicative 6import Control.Applicative
7import Data.ByteString (ByteString)
8import qualified Data.ByteString as B
5import qualified Data.ByteString.Lazy as Lazy 9import qualified Data.ByteString.Lazy as Lazy
6import Data.IntervalSet
7import Data.List as L 10import Data.List as L
8import Data.Ord 11import Data.Ord
9import Data.Maybe 12import Data.Maybe
10import Data.Word 13import Data.Word
14import Data.Serialize as S
11import Data.Text as T 15import Data.Text as T
16
17import Network
12import Network.URI 18import Network.URI
13 19
14import Test.Framework (defaultMain) 20import Test.Framework (Test, defaultMain)
15import Test.Framework.Providers.QuickCheck2 (testProperty) 21import Test.Framework.Providers.QuickCheck2 (testProperty)
16import Test.QuickCheck 22import Test.QuickCheck
17 23
18import Data.BEncode 24import Data.BEncode as BE
19import Data.Bitfield as BF 25import Data.Bitfield as BF
20import Data.Torrent 26import Data.Torrent
21import Network.BitTorrent as BT 27import Network.BitTorrent as BT
22 28
23import Debug.Trace 29-- import Debug.Trace
24import Encoding 30
25 31
32data T a = T
26 33
27instance Arbitrary URI where 34instance Arbitrary URI where
28 arbitrary = pure $ fromJust 35 arbitrary = pure $ fromJust
@@ -90,17 +97,119 @@ instance Arbitrary Torrent where
90 <*> arbitrary <*> arbitrary <*> arbitrary 97 <*> arbitrary <*> arbitrary <*> arbitrary
91 <*> arbitrary <*> pure Nothing <*> arbitrary 98 <*> arbitrary <*> pure Nothing <*> arbitrary
92 99
100{-----------------------------------------------------------------------
101 Handshake
102-----------------------------------------------------------------------}
103
104instance Arbitrary PeerID where
105 arbitrary = azureusStyle <$> pure defaultClientID
106 <*> arbitrary
107 <*> arbitrary
108
109instance Arbitrary InfoHash where
110 arbitrary = (hash . B.pack) <$> arbitrary
111
112instance Arbitrary Handshake where
113 arbitrary = defaultHandshake <$> arbitrary <*> arbitrary
114
115prop_cerealEncoding :: (Serialize a, Eq a) => T a -> [a] -> Bool
116prop_cerealEncoding _ msgs = S.decode (S.encode msgs) == Right msgs
117
118{-----------------------------------------------------------------------
119 Tracker/Scrape
120-----------------------------------------------------------------------}
121
122-- | Note that in 6 esample we intensionally do not agree with
123-- specification, because taking in account '/' in query parameter
124-- seems to be meaningless. (And thats because other clients do not
125-- chunk uri by parts) Moreover in practice there should be no
126-- difference. (I think so)
127--
128test_scrape_url :: [Test]
129test_scrape_url = L.zipWith mkTest [1 :: Int ..] (check `L.map` tests)
130 where
131 check (iu, ou) = (parseURI iu >>= (`scrapeURL` [])
132 >>= return . show) == ou
133 tests =
134 [ ( "http://example.com/announce"
135 , Just "http://example.com/scrape")
136 , ( "http://example.com/x/announce"
137 , Just "http://example.com/x/scrape")
138 , ( "http://example.com/announce.php"
139 , Just "http://example.com/scrape.php")
140 , ( "http://example.com/a" , Nothing)
141 , ( "http://example.com/announce?x2%0644"
142 , Just "http://example.com/scrape?x2%0644")
143 , ( "http://example.com/announce?x=2/4"
144 , Just "http://example.com/scrape?x=2/4")
145-- , ("http://example.com/announce?x=2/4" , Nothing) -- by specs
146 , ("http://example.com/x%064announce" , Nothing)
147 ]
148
149 mkTest i = testProperty ("scrape test #" ++ show i)
150
151{-----------------------------------------------------------------------
152 P2P/message
153-----------------------------------------------------------------------}
154
155positive :: Gen Int
156positive = fromIntegral <$> (arbitrary :: Gen Word32)
157
158instance Arbitrary ByteString where
159 arbitrary = B.pack <$> arbitrary
160
161instance Arbitrary BlockIx where
162 arbitrary = BlockIx <$> positive <*> positive <*> positive
163
164instance Arbitrary Block where
165 arbitrary = Block <$> positive <*> positive <*> arbitrary
166
167instance Arbitrary Bitfield where
168 arbitrary = mkBitfield <$> (succ . min 1000 <$> positive)
169 <*> arbitrary
170
171instance Arbitrary PortNumber where
172 arbitrary = fromIntegral <$> (arbitrary :: Gen Word16)
173
174instance Arbitrary Message where
175 arbitrary = oneof
176 [ pure KeepAlive
177 , pure Choke
178 , pure Unchoke
179 , pure Interested
180 , pure NotInterested
181 , Have <$> positive
182 , Bitfield <$> arbitrary
183 , Request <$> arbitrary
184 , Piece <$> arbitrary
185 , Cancel <$> arbitrary
186 , Port <$> arbitrary
187 ]
188
189{-----------------------------------------------------------------------
190 Main
191-----------------------------------------------------------------------}
192
93main :: IO () 193main :: IO ()
94main = defaultMain 194main = defaultMain $
95 [ testProperty "completeness range" prop_completenessRange 195 [ -- bitfield module
196 testProperty "completeness range" prop_completenessRange
96 , testProperty "rarest in range" prop_rarestInRange 197 , testProperty "rarest in range" prop_rarestInRange
97 , testProperty "min less that max" prop_minMax 198 , testProperty "min less that max" prop_minMax
98 , testProperty "difference de morgan" prop_differenceDeMorgan 199 , testProperty "difference de morgan" prop_differenceDeMorgan
99 200
201 -- torrent module
100 , testProperty "file info encoding" $ 202 , testProperty "file info encoding" $
101 prop_properBEncode (T :: T FileInfo) 203 prop_properBEncode (T :: T FileInfo)
102 , testProperty "content info encoding" $ 204 , testProperty "content info encoding" $
103 prop_properBEncode (T :: T ContentInfo) 205 prop_properBEncode (T :: T ContentInfo)
104 , testProperty "torrent encoding" $ 206 , testProperty "torrent encoding" $
105 prop_properBEncode (T :: T Torrent) 207 prop_properBEncode (T :: T Torrent)
106 ] 208
209 -- handshake module
210 , testProperty "handshake encoding" $
211 prop_cerealEncoding (T :: T Handshake)
212 , testProperty "message encoding" $
213 prop_cerealEncoding (T :: T Message)
214
215 ] ++ test_scrape_url