From 27cf6fbeeb19572a58a71ca7cf080aeea82d0cb8 Mon Sep 17 00:00:00 2001
From: Sam Truzjan <pxqr.sta@gmail.com>
Date: Wed, 27 Nov 2013 13:35:41 +0400
Subject: More informative ParamParseFailure

---
 bittorrent.cabal                                |  3 ++-
 src/Network/BitTorrent/Tracker/Message.hs       | 15 +++++++-------
 tests/Network/BitTorrent/Tracker/MessageSpec.hs | 27 +++++++++++++++++++++++--
 3 files changed, 35 insertions(+), 10 deletions(-)

diff --git a/bittorrent.cabal b/bittorrent.cabal
index dbc9d96a..6d2c7896 100644
--- a/bittorrent.cabal
+++ b/bittorrent.cabal
@@ -63,7 +63,7 @@ library
 --                     , Network.BitTorrent.Tracker.HTTP
 --                     , Network.BitTorrent.Tracker.UDP
 --                     , Network.BitTorrent.Exchange
---                     , Network.BitTorrent.Exchange.Protocol
+                     , Network.BitTorrent.Exchange.Protocol
 --                     , Network.BitTorrent.DHT
 --                     , Network.BitTorrent.DHT.Protocol
 --                     , Network.BitTorrent.Sessions
@@ -155,6 +155,7 @@ test-suite spec
                      , directory
                      , filepath
                      , time
+                     , random
 
                      , aeson
                      , cereal
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index 53d7a946..3447a367 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -155,7 +155,7 @@ data AnnounceQuery = AnnounceQuery
 
      -- | If not specified, the request is regular periodic request.
    , reqEvent      :: Maybe Event
-   } deriving (Show, Typeable)
+   } deriving (Show, Eq, Typeable)
 
 $(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceQuery)
 
@@ -233,8 +233,9 @@ data QueryParam
     deriving (Show, Eq, Ord, Enum)
 
 data ParamParseFailure
-  = Missing QueryParam -- ^ param not found in query string;
-  | Invalid QueryParam -- ^ param present but not valid.
+  = Missing QueryParam      -- ^ param not found in query string;
+  | Invalid QueryParam Text -- ^ param present but not valid.
+    deriving (Show, Eq)
 
 type ParamResult = Either ParamParseFailure
 
@@ -271,11 +272,11 @@ parseAnnounceQuery params = AnnounceQuery
   where
     withError e = maybe (Left e) Right
     reqParam param p = withError (Missing param) . L.lookup (paramName param)
-                   >=> withError (Invalid param) . p
+                   >=> \x -> withError (Invalid param x) (p x)
 
     optParam param p ps
       | Just x <- L.lookup (paramName param) ps
-      = pure <$> withError (Invalid param) (p x)
+      = pure <$> withError (Invalid param x) (p x)
       | otherwise = pure Nothing
 
     progress = undefined
@@ -426,8 +427,8 @@ invalidOffset = 150
 --   <https://wiki.theory.org/BitTorrent_Tracker_Protocol#Response_Codes>
 --
 paramFailureCode :: ParamParseFailure -> Int
-paramFailureCode (Missing param) = missingOffset + fromEnum param
-paramFailureCode (Invalid param) = invalidOffset + fromEnum param
+paramFailureCode (Missing param  ) = missingOffset + fromEnum param
+paramFailureCode (Invalid param _) = invalidOffset + fromEnum param
 
 {-----------------------------------------------------------------------
   Scrape message
diff --git a/tests/Network/BitTorrent/Tracker/MessageSpec.hs b/tests/Network/BitTorrent/Tracker/MessageSpec.hs
index 99518067..8a06aaba 100644
--- a/tests/Network/BitTorrent/Tracker/MessageSpec.hs
+++ b/tests/Network/BitTorrent/Tracker/MessageSpec.hs
@@ -3,14 +3,19 @@ module Network.BitTorrent.Tracker.MessageSpec (spec) where
 
 import Control.Applicative
 import Data.BEncode as BE
+import Data.ByteString.Char8 as BC
 import Data.ByteString.Lazy as BL
+import Data.List as L
 import Data.Maybe
 import Data.Word
+import Data.Text
 import Network
 import Network.URI
 import Test.Hspec
 import Test.QuickCheck
---import Network.HTTP.Types.URI
+import Test.QuickCheck.Gen
+import Network.HTTP.Types.URI
+import System.Random
 
 import Data.Torrent.InfoHashSpec ()
 import Data.Torrent.ProgressSpec ()
@@ -39,9 +44,27 @@ instance Arbitrary AnnounceQuery where
 baseURI :: URI
 baseURI = fromJust $ parseURI "http://a"
 
+parseUriQuery :: URI -> [(Text, Text)]
+parseUriQuery = filterMaybes . parseQueryText . BC.pack . uriQuery
+  where
+    filterMaybes :: [(a, Maybe b)] -> [(a, b)]
+    filterMaybes = catMaybes . L.map f
+      where
+        f (a, Nothing) = Nothing
+        f (a, Just b ) = Just (a, b)
+
+test = do
+  let q = unGen arbitrary (mkStdGen 0) 0
+  print $ renderAnnounceQuery baseURI q
+  print $ parseUriQuery $ renderAnnounceQuery baseURI q
+
 spec :: Spec
 spec = do
   describe "Announce" $ do
-    return ()
+    before test $
+      it "properly url encoded" $ property $ \ q ->
+      parseAnnounceQuery (parseUriQuery (renderAnnounceQuery baseURI q))
+        `shouldBe` Right q
+
   describe "Scrape" $ do
     return ()
-- 
cgit v1.2.3