Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: e1372a2f80
Fetching contributors…

Cannot retrieve contributors at this time

253 lines (208 sloc) 10.482 kb
-- Normal imports
import Control.Monad
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy as LZ
import Data.Char
import Data.List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import Test.HUnit
import Text.Printf
import Test.QuickCheck
import Test.QuickCheck.Test hiding ( test )
-- Tested modules
import Data.Bencoding
import Data.Checksum
import Data.Metainfo
import Text.Regex.Simple
import Data.Extra
------------------------------
-- Tests for Data.Bencoding
instance Arbitrary L.ByteString where
arbitrary = do
txt <- arbitrary
return $ L.pack txt
instance (Ord a, Arbitrary a, Arbitrary b) => Arbitrary (Map a b) where
arbitrary = do
l <- arbitrary
return $ Map.fromList l
instance Arbitrary Bencoding where
arbitrary = sized bencoding
where
bencoding 0 = return $ BencList []
bencoding n = oneof [liftM BencInt arbitrary,
liftM BencString arbitrary,
liftM BencList thirdlist,
liftM BencDict thirdlist]
where
thirdlist :: (Arbitrary a) => Gen a
thirdlist = resize (n `div` 3) arbitrary
prop_EncodeDecodeInt :: Integer -> Bool
prop_EncodeDecodeInt i = i == (fromJust . fromBencoding . fromJust
. decode . (""++) . encode . BencInt $ i)
prop_EncodeDecodeString :: String -> Bool
prop_EncodeDecodeString s = s == (fromJust . fromBencoding . fromJust
. decode . (""++) . encode . BencString . L.pack $ s)
prop_EncodeDecodeList :: [Integer] -> Bool
prop_EncodeDecodeList xs = BencList (map BencInt xs)
== (fromJust . decode . (""++) . encode . BencList . map BencInt $ xs)
prop_EncodeDecode :: Bencoding -> Bool
prop_EncodeDecode x = x == (fromJust . decode . (""++) . encode $ x)
bencodingProps = [ ("encode.decode(int)/id", quickCheck prop_EncodeDecodeInt)
, ("encode.decode(string)/id ", quickCheck prop_EncodeDecodeString)
, ("encode.decode(list)/id", quickCheck prop_EncodeDecodeList)
, ("encode.decode/id", quickCheck prop_EncodeDecode)
]
-- Why do I get the feeling that HUnit is useless when put next to QuickCheck?
bencodingTests = test [ "empty list" ~: (encode $ BencList []) ~=? (L.pack "le")
, "empty dict" ~: (encode $ BencDict Map.empty) ~=? (L.pack "de")
, "empty string" ~: (encode $ BencString L.empty) ~=? (L.pack "0:")
, "bad int" ~: (decode $ L.pack "ie") ~=? Nothing
, "bad int" ~: (decode $ L.pack "i") ~=? Nothing
, "bad int" ~: (decode $ L.pack "e") ~=? Nothing
, "bad int" ~: (decode $ L.pack "i23.3e") ~=? Nothing
, "bad int" ~: (decode $ L.pack "i23,3e") ~=? Nothing
, "bad int" ~: (decode $ L.pack "i2a3e") ~=? Nothing
, "bad int" ~: (decode $ L.pack "iiee") ~=? Nothing
, "bad int" ~: (decode $ L.pack "iae") ~=? Nothing
, "bad list" ~: (decode $ L.pack "l") ~=? Nothing
, "bad dict" ~: (decode $ L.pack "d") ~=? Nothing
]
------------------------------
-- Tests for Data.Checksum
newtype HexNumber = HexNumber { getDigits :: [HexDigit] }
deriving (Show, Eq)
newtype HexDigit = HexDigit { getCharValue :: [Char] }
deriving (Show, Eq)
instance Arbitrary HexDigit where
arbitrary = do
c <- elements (concat [['0'..'9'], ['a'..'f']])
d <- elements (concat [['0'..'9'], ['a'..'f']])
return $ HexDigit [c, d]
instance Arbitrary HexNumber where
arbitrary = do
s <- sized $ \sz -> resize (sz `div` 2) arbitrary
return $ HexNumber $ concat s
prop_B2HH2B :: HexNumber -> Bool
prop_B2HH2B hn = let hn' = L.pack . concatMap getCharValue . getDigits $ hn
in hn' == (bytesToHexGroups . (""++) . hexGroupsToBytes $ hn')
checksumProps = [ ("h2b.b2h/id", quickCheck prop_B2HH2B) ]
------------------------------
-- Tests for Data.Metainfo
metainfoTests = test [ "empty metainfo" ~: (parseMetainfo . L.pack $ "de") ~=? Nothing
, "empty metainfo" ~: (parseMetainfo . L.pack $ "") ~=? Nothing
, "partial metainfo" ~: (parseMetainfo . L.pack $ "d8:announce3:yes")
~=? Nothing
]
------------------------------
-- Tests for Text.Regex.Simple
prop_PrefixMatch :: String -> Bool
prop_PrefixMatch s = matchPattern (take (length s `div` 2) s) s
prop_PrefixFail :: String -> Bool
prop_PrefixFail s = let prefix = take (length s `div` 2) s
prefix' = map (\c -> if c =='.' then '#' else c)
. map (\c -> chr $ ord c + 1) $ prefix
in if null prefix'
then True
else matchPattern prefix' s == False
regexTests = test [ "empty pattern" ~: matchPattern "" "" ~=? True
, "empty pattern" ~: matchPattern "" "abc" ~=? True
, "prefix pattern" ~: matchPattern "a" "abc" ~=? True
, "prefix pattern" ~: matchPattern "ab" "abc" ~=? True
, "full match" ~: matchPattern "abc" "abc" ~=? True
, "failed match" ~: matchPattern "c" "abc" ~=? False
, "failed match" ~: matchPattern "ca" "abc" ~=? False
, "empty text" ~: matchPattern "ca" "" ~=? False
, "failed match" ~: matchPattern "ac" "abc" ~=? False
, "shorter text" ~: matchPattern "ac" "a" ~=? False
, "failed match" ~: matchPattern "abd" "abc" ~=? False
, "wildcard" ~: matchPattern "." "" ~=? False
, "wildcard" ~: matchPattern "." "a" ~=? True
, "wildcard" ~: matchPattern "a." "abc" ~=? True
, "wildcard" ~: matchPattern ".b" "abc" ~=? True
, "wildcard" ~: matchPattern ".c" "abc" ~=? False
, "wildcard" ~: matchPattern "..." "abc" ~=? True
, "wildcard" ~: matchPattern "a.b" "abc" ~=? False
, "wildcard" ~: matchPattern "a.b" "aab" ~=? True
]
regexProps = [ ("prefix match", quickCheck prop_PrefixMatch)
, ("prefix fail", quickCheck prop_PrefixFail) ]
------------------------------
-- Tests for Data.Extra
ordered xs = and $ zipWith (<=) xs (tail xs)
prop_MergeSorted :: [Int] -> Bool
prop_MergeSorted xs = let len = length xs `div` 2
(ys, zs) = splitAt len xs
(ys', zs') = (sort ys, sort zs)
in ordered $ merge ys' zs'
newtype SmallString = SmallString String
deriving (Show)
instance Arbitrary SmallString where
arbitrary = do
s <- sized $ \sz -> resize (sz `div` 2) arbitrary
return $ SmallString s
prop_PadNothingString :: SmallString -> Bool
prop_PadNothingString (SmallString s) = (padFront 0 'x' s == s)
&& (padBack 0 'x' s == s)
newtype SmallInt = SmallInt Int
deriving (Show)
instance Arbitrary SmallInt where
arbitrary = do
n <- sized $ \sz -> resize (sz `div` 2) arbitrary
return $ SmallInt n
prop_PadLengthString :: SmallInt -> Bool
prop_PadLengthString (SmallInt n) = let s = "Hello World"
l = length s
in (l `max` n == length (padFront n 'x' s))
&& (l `max` n == length (padBack n 'x' s))
prop_PadPrefixSuffixString :: SmallInt -> Bool
prop_PadPrefixSuffixString (SmallInt n) = let s = "Hello World"
l = length s
in isSuffixOf s (padFront n 'x' s)
&& isPrefixOf s (padBack n 'x' s)
prop_PadNothingBS :: SmallString -> Bool
prop_PadNothingBS (SmallString s) = let bs = L.pack s
in (padFront 0 'x' bs == bs)
&& (padBack 0 'x' bs == bs)
prop_PadLengthBS :: SmallInt -> Bool
prop_PadLengthBS (SmallInt n) =
let bs = L.pack "Hello World"
l = L.length bs
in (l `max` fromIntegral n == L.length (padFront n 'x' bs))
&& (l `max` fromIntegral n == L.length (padBack n 'x' bs))
prop_PadPrefixSuffixBS :: SmallInt -> Bool
prop_PadPrefixSuffixBS (SmallInt n) = let bs = L.pack "Hello World"
l = L.length bs
in LZ.isSuffixOf bs (padFront n 'x' bs)
&& LZ.isPrefixOf bs (padBack n 'x' bs)
newtype NaturalInteger = NaturalInteger Integer
deriving (Show)
instance Arbitrary NaturalInteger where
arbitrary = do
n <- arbitrary
return . NaturalInteger . abs $ n
prop_MGSReflection :: NaturalInteger -> Bool
prop_MGSReflection (NaturalInteger n) = let ss = makeGroupedSum mgsConfigDiskSpace n
mgss = map swapPair mgsConfigDiskSpace
n' = foldl' (\t (i, s) -> t + i * (fromJust $ lookup s mgss)) 0 ss
in n == n'
where
swapPair (a, b) = (b, a)
dataExtraProps = [ ("ordered.merge", quickCheck prop_MergeSorted)
, ("pad nothing s", quickCheck prop_PadNothingString)
, ("pad length s", quickCheck prop_PadLengthString)
, ("pad pre suf s", quickCheck prop_PadPrefixSuffixString)
, ("pad nothing bs", quickCheck prop_PadNothingBS)
, ("pad length bs", quickCheck prop_PadLengthBS)
, ("pad pre suf bs", quickCheck prop_PadPrefixSuffixBS)
, ("mgs reflection", quickCheck prop_MGSReflection)]
props = concat [bencodingProps, checksumProps, regexProps, dataExtraProps]
tests = test [bencodingTests, metainfoTests, regexTests]
main :: IO ()
main = do
putStrLn "Testing QuickCheck properties"
mapM_ (\(s, a) -> printf " %-25s: " s >> a) props
putStrLn "Running HUnit tests"
runTestTT tests
putStrLn "All tests done"
Jump to Line
Something went wrong with that request. Please try again.