From: Ramakrishnan Muthukrishnan <ram@rkrishnan.org>
Date: Sun, 23 Jul 2017 16:36:30 +0000 (+0530)
Subject: DONOTUSE quickcheck tests do not terminate
X-Git-Url: https://git.rkrishnan.org/pf/content/en/seg/index.php?a=commitdiff_plain;h=8dcb9c0c7d752fc9b6a76142064741c822d9d3a5;p=functorrent.git

DONOTUSE quickcheck tests do not terminate
---

diff --git a/src/FuncTorrent/Bencode.hs b/src/FuncTorrent/Bencode.hs
index f359465..fd521dc 100644
--- a/src/FuncTorrent/Bencode.hs
+++ b/src/FuncTorrent/Bencode.hs
@@ -33,6 +33,7 @@ import Prelude hiding (length, concat)
 
 import Data.ByteString (ByteString, length, concat)
 import Data.ByteString.Char8 (unpack, pack)
+import Data.Char (isLetter, isNumber, isPrint, isAscii)
 import Data.Map.Strict (Map, fromList, toList)
 import Text.ParserCombinators.Parsec
 import qualified Text.Parsec.ByteString as ParsecBS
@@ -44,6 +45,11 @@ data BVal = Bint Integer
           | Bdict (Map String BVal)
             deriving (Ord, Eq, Show)
 
+genNonEmptyString :: Gen String
+genNonEmptyString = arbitrary `suchThat` (\s -> ((s /= "") &&
+                                                 (all isAscii s) &&
+                                                 (all isLetter s)))
+
 instance Arbitrary ByteString where
   arbitrary = pack <$> arbitrary
 
@@ -56,7 +62,7 @@ instance Arbitrary BVal where
                 bval n = oneof [ Bint <$> arbitrary
                                , Bstr <$> arbitrary
                                , Blist <$> vectorOf n (bval (n `div` 4))
-                               , do keys <- vectorOf n arbitrary
+                               , do keys <- vectorOf n genNonEmptyString
                                     vals <- vectorOf n (bval (n `div` 4))
                                     return $ Bdict $ fromList $ zip keys vals ]
 
@@ -152,9 +158,14 @@ bencList = between (char 'l') (char 'e') (many bencVal)
 -- Right (fromList [("publisher",Bstr "bob"),("publisher-webpage",Bstr "www.example.com"),("publisher.location",Bstr "home")])
 bencDict :: ParsecBS.Parser (Map String BVal)
 bencDict = between (char 'd') (char 'e') $ fromList <$> many kvpair
-  where kvpair = do k <- bencStr
+  where kvpair = do k <- bdictKey
                     v <- bencVal
-                    return (unpack k, v)
+                    return (k, v)
+        bdictKey = do
+          ds <- many1 digit <* char ':'
+          s <- count (read ds) alphaNum
+          return s
+
 
 bencVal :: ParsecBS.Parser BVal
 bencVal = Bstr <$> bencStr <|>
@@ -195,4 +206,4 @@ encode (Bdict d) = concat ["d", concat kvlist, "e"]
     where
       kvlist :: [ByteString]
       kvlist = [encPair kv | kv <- toList d]
-      encPair (k, v) = concat [encode . Bstr . pack $ k, encode v]
+      encPair (k, v) = concat [encode (Bstr (pack k)), encode v]
diff --git a/src/FuncTorrent/Metainfo.hs b/src/FuncTorrent/Metainfo.hs
index 898cc54..13e7979 100644
--- a/src/FuncTorrent/Metainfo.hs
+++ b/src/FuncTorrent/Metainfo.hs
@@ -17,6 +17,7 @@
  - along with FuncTorrent; if not,  see <http://www.gnu.org/licenses/>
  -}
 
+{-# LANGUAGE OverloadedStrings #-}
 module FuncTorrent.Metainfo
     (Info(..),
      Metainfo(..),
diff --git a/src/FuncTorrent/Tracker/Types.hs b/src/FuncTorrent/Tracker/Types.hs
index 1c47d31..56d5604 100644
--- a/src/FuncTorrent/Tracker/Types.hs
+++ b/src/FuncTorrent/Tracker/Types.hs
@@ -28,7 +28,7 @@ module FuncTorrent.Tracker.Types
        , TrackerMsg(..)
        ) where
 
-import Data.ByteString (ByteString)
+
 import Data.Word (Word32)
 import Control.Concurrent.MVar (MVar)
 
diff --git a/test/BencodeTests.hs b/test/BencodeTests.hs
index d889643..8e54e93 100644
--- a/test/BencodeTests.hs
+++ b/test/BencodeTests.hs
@@ -24,9 +24,13 @@ tests = hspec $ do
         let encoded = encode (Bint i)
             decoded = decode encoded
         in Right (Bint i) == decoded
-  -- describe "Bencode property tests" $ do
-  --   it "encode/decode" $ do
-  --     property $ \bval ->
-  --       let encoded = encode bval
-  --           decoded = decode encoded
-  --       in Right bval == decoded
+    it "encode/decode blist tests" $ do
+      property $ \bval ->
+        let encoded = encode (Blist (take 1 bval))
+            decoded = decode encoded
+        in Right (Blist (take 1 bval)) == decoded
+    -- it "encode/decode" $ do
+    --   property $ \bval ->
+    --     let encoded = encode bval
+    --         decoded = decode encoded
+    --     in Right bval == decoded