From 9356528a6a14e35448d5b8556bc951b8eefeef1e Mon Sep 17 00:00:00 2001 From: Sam T Date: Fri, 7 Jun 2013 21:49:10 +0400 Subject: ~ Merge Encoding to Main. --- tests/Encoding.hs | 96 ----------------------------------------- tests/Main.hs | 127 ++++++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 118 insertions(+), 105 deletions(-) delete mode 100644 tests/Encoding.hs (limited to 'tests') 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 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS -fno-warn-orphans #-} -module Encoding where - -import Control.Applicative -import Data.Word -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Serialize -import Test.Framework (Test) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck - - -import Network.URI -import Network - - -import Data.Bitfield -import Data.Torrent -import Network.BitTorrent - - -positive :: Gen Int -positive = fromIntegral <$> (arbitrary :: Gen Word32) - -instance Arbitrary ByteString where - arbitrary = B.pack <$> arbitrary - -instance Arbitrary BlockIx where - arbitrary = BlockIx <$> positive <*> positive <*> positive - -instance Arbitrary Block where - arbitrary = Block <$> positive <*> positive <*> arbitrary - -instance Arbitrary Bitfield where - arbitrary = mkBitfield <$> (succ . min 1000 <$> positive) - <*> arbitrary - -instance Arbitrary PortNumber where - arbitrary = fromIntegral <$> (arbitrary :: Gen Word16) - -instance Arbitrary Message where - arbitrary = oneof - [ pure KeepAlive - , pure Choke - , pure Unchoke - , pure Interested - , pure NotInterested - , Have <$> positive - , Bitfield <$> arbitrary - , Request <$> arbitrary - , Piece <$> arbitrary - , Cancel <$> arbitrary - , Port <$> arbitrary - ] - -instance Arbitrary PeerID where - arbitrary = azureusStyle <$> pure defaultClientID - <*> arbitrary - <*> arbitrary - -instance Arbitrary InfoHash where - arbitrary = (hash . B.pack) <$> arbitrary - -instance Arbitrary Handshake where - arbitrary = defaultHandshake <$> arbitrary <*> arbitrary - - -data T a = T - -prop_encoding :: (Serialize a, Eq a) => T a -> [a] -> Bool -prop_encoding _ msgs = decode (encode msgs) == Right msgs - --- | Note that in 6 esample we intensionally do not agree with specification, --- because taking in account '/' in query parameter seems to be meaningless. --- (And thats because other clients do not chunk uri by parts) --- Moreover in practice there should be no difference. (I hope) --- -test_scrape_url :: [Test] -test_scrape_url = zipWith mkTest [1 :: Int ..] (check `map` tests) - where - check (iu, ou) = (parseURI iu >>= (`scrapeURL` []) >>= return . show) == ou - tests = - [ ("http://example.com/announce" , Just "http://example.com/scrape") - , ("http://example.com/x/announce" , Just "http://example.com/x/scrape") - , ("http://example.com/announce.php" , Just "http://example.com/scrape.php") - , ("http://example.com/a" , Nothing) - , ("http://example.com/announce?x2%0644", Just "http://example.com/scrape?x2%0644") - , ("http://example.com/announce?x=2/4" , Just "http://example.com/scrape?x=2/4") --- , ("http://example.com/announce?x=2/4" , Nothing) -- by specs - , ("http://example.com/x%064announce" , Nothing) - ] - - 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 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Main (main) where import Control.Applicative +import Data.ByteString (ByteString) +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as Lazy -import Data.IntervalSet import Data.List as L import Data.Ord import Data.Maybe import Data.Word +import Data.Serialize as S import Data.Text as T + +import Network import Network.URI -import Test.Framework (defaultMain) +import Test.Framework (Test, defaultMain) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck -import Data.BEncode +import Data.BEncode as BE import Data.Bitfield as BF import Data.Torrent import Network.BitTorrent as BT -import Debug.Trace -import Encoding +-- import Debug.Trace + +data T a = T instance Arbitrary URI where arbitrary = pure $ fromJust @@ -90,17 +97,119 @@ instance Arbitrary Torrent where <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> pure Nothing <*> arbitrary +{----------------------------------------------------------------------- + Handshake +-----------------------------------------------------------------------} + +instance Arbitrary PeerID where + arbitrary = azureusStyle <$> pure defaultClientID + <*> arbitrary + <*> arbitrary + +instance Arbitrary InfoHash where + arbitrary = (hash . B.pack) <$> arbitrary + +instance Arbitrary Handshake where + arbitrary = defaultHandshake <$> arbitrary <*> arbitrary + +prop_cerealEncoding :: (Serialize a, Eq a) => T a -> [a] -> Bool +prop_cerealEncoding _ msgs = S.decode (S.encode msgs) == Right msgs + +{----------------------------------------------------------------------- + Tracker/Scrape +-----------------------------------------------------------------------} + +-- | Note that in 6 esample we intensionally do not agree with +-- specification, because taking in account '/' in query parameter +-- seems to be meaningless. (And thats because other clients do not +-- chunk uri by parts) Moreover in practice there should be no +-- difference. (I think so) +-- +test_scrape_url :: [Test] +test_scrape_url = L.zipWith mkTest [1 :: Int ..] (check `L.map` tests) + where + check (iu, ou) = (parseURI iu >>= (`scrapeURL` []) + >>= return . show) == ou + tests = + [ ( "http://example.com/announce" + , Just "http://example.com/scrape") + , ( "http://example.com/x/announce" + , Just "http://example.com/x/scrape") + , ( "http://example.com/announce.php" + , Just "http://example.com/scrape.php") + , ( "http://example.com/a" , Nothing) + , ( "http://example.com/announce?x2%0644" + , Just "http://example.com/scrape?x2%0644") + , ( "http://example.com/announce?x=2/4" + , Just "http://example.com/scrape?x=2/4") +-- , ("http://example.com/announce?x=2/4" , Nothing) -- by specs + , ("http://example.com/x%064announce" , Nothing) + ] + + mkTest i = testProperty ("scrape test #" ++ show i) + +{----------------------------------------------------------------------- + P2P/message +-----------------------------------------------------------------------} + +positive :: Gen Int +positive = fromIntegral <$> (arbitrary :: Gen Word32) + +instance Arbitrary ByteString where + arbitrary = B.pack <$> arbitrary + +instance Arbitrary BlockIx where + arbitrary = BlockIx <$> positive <*> positive <*> positive + +instance Arbitrary Block where + arbitrary = Block <$> positive <*> positive <*> arbitrary + +instance Arbitrary Bitfield where + arbitrary = mkBitfield <$> (succ . min 1000 <$> positive) + <*> arbitrary + +instance Arbitrary PortNumber where + arbitrary = fromIntegral <$> (arbitrary :: Gen Word16) + +instance Arbitrary Message where + arbitrary = oneof + [ pure KeepAlive + , pure Choke + , pure Unchoke + , pure Interested + , pure NotInterested + , Have <$> positive + , Bitfield <$> arbitrary + , Request <$> arbitrary + , Piece <$> arbitrary + , Cancel <$> arbitrary + , Port <$> arbitrary + ] + +{----------------------------------------------------------------------- + Main +-----------------------------------------------------------------------} + main :: IO () -main = defaultMain - [ testProperty "completeness range" prop_completenessRange +main = defaultMain $ + [ -- bitfield module + testProperty "completeness range" prop_completenessRange , testProperty "rarest in range" prop_rarestInRange , testProperty "min less that max" prop_minMax , testProperty "difference de morgan" prop_differenceDeMorgan + -- torrent module , testProperty "file info encoding" $ prop_properBEncode (T :: T FileInfo) , testProperty "content info encoding" $ prop_properBEncode (T :: T ContentInfo) , testProperty "torrent encoding" $ prop_properBEncode (T :: T Torrent) - ] + + -- handshake module + , testProperty "handshake encoding" $ + prop_cerealEncoding (T :: T Handshake) + , testProperty "message encoding" $ + prop_cerealEncoding (T :: T Message) + + ] ++ test_scrape_url -- cgit v1.2.3