Implement AnnounceQuery parsing

2 files changed, 79 insertions, 47 deletions

diff --git a/src/Network/BitTorrent/Core/PeerId.hs b/src/Network/BitTorrent/Core/PeerId.hs
index 2c79739a..a2b03e92 100644
--- a/src/Network/BitTorrent/Core/PeerId.hs
+++ b/src/Network/BitTorrent/Core/PeerId.hs
@@ -15,6 +15,7 @@
 module Network.BitTorrent.Core.PeerId
        ( -- * PeerId
          PeerId (getPeerId)
+       , byteStringToPeerId
 
          -- * Generation
        , genPeerId
@@ -60,30 +61,37 @@ import Paths_bittorrent (version)
 
 import Data.Torrent.Client
 
--- TODO use unpacked form (length is known statically)
+-- TODO use unpacked Word160 form (length is known statically)
 
 -- | Peer identifier is exactly 20 bytes long bytestring.
 newtype PeerId = PeerId { getPeerId :: ByteString }
                  deriving (Show, Eq, Ord, BEncode, ToJSON, FromJSON)
 
+peerIdLen :: Int
+peerIdLen = 20
+
 instance Serialize PeerId where
   put = putByteString . getPeerId
-  get = PeerId <$> getBytes 20
+  get = PeerId <$> getBytes peerIdLen
 
 instance URLShow PeerId where
   urlShow = BC.unpack . getPeerId
 
 instance IsString PeerId where
   fromString str
-      | BS.length bs == 20 = PeerId bs
-      |      otherwise     = error $ "Peer id should be 20 bytes long: "
-                                  ++ show str
+      | BS.length bs == peerIdLen = PeerId bs
+      | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str
     where
       bs = fromString str
 
 instance Pretty PeerId where
   pretty = text . BC.unpack . getPeerId
 
+byteStringToPeerId :: BS.ByteString -> Maybe PeerId
+byteStringToPeerId bs
+  | BS.length bs == peerIdLen = Just (PeerId bs)
+  |          otherwise        = Nothing
+
 {-----------------------------------------------------------------------
 --  Encoding
 -----------------------------------------------------------------------}
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index 3447a367..59ef2027 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -52,6 +52,8 @@ import Data.Aeson (ToJSON(..), FromJSON(..))
 import Data.Aeson.TH
 import Data.BEncode as BE
 import Data.BEncode.BDict as BE
+import Data.ByteString as BS
+import Data.ByteString.Char8 as BC
 import Data.Char as Char
 import Data.List as L
 import Data.Map  as M
@@ -64,8 +66,10 @@ import Data.Typeable
 import Data.URLEncoded as URL
 import Data.Word
 import Network
-import Network.URI
+import Network.HTTP.Types.URI hiding (urlEncode)
 import Network.Socket
+import Network.URI
+import Text.Read (readMaybe)
 
 import Data.Torrent.InfoHash
 import Data.Torrent.Progress
@@ -226,63 +230,83 @@ data QueryParam
   = ParamInfoHash
   | ParamPeerId
   | ParamPort
-  | ParamProgress
+  | ParamUploaded
+  | ParamLeft
+  | ParamDownloaded
   | ParamIP
   | ParamNumWant
   | ParamEvent
     deriving (Show, Eq, Ord, Enum)
 
 data ParamParseFailure
-  = Missing QueryParam      -- ^ param not found in query string;
-  | Invalid QueryParam Text -- ^ param present but not valid.
+  = Missing QueryParam            -- ^ param not found in query string;
+  | Invalid QueryParam ByteString -- ^ param present but not valid.
     deriving (Show, Eq)
 
-type ParamResult = Either ParamParseFailure
+paramName :: QueryParam -> ByteString
+paramName ParamInfoHash   = "info_hash"
+paramName ParamPeerId     = "peer_id"
+paramName ParamPort       = "port"
+paramName ParamUploaded   = "uploaded"
+paramName ParamLeft       = "left"
+paramName ParamDownloaded = "downloaded"
+paramName ParamIP         = "ip"
+paramName ParamNumWant    = "numwant"
+paramName ParamEvent      = "event"
+
+class FromParam a where
+  fromParam :: BS.ByteString -> Maybe a
+
+instance FromParam InfoHash where
+  fromParam = byteStringToInfoHash
+
+instance FromParam PeerId where
+  fromParam = byteStringToPeerId
+
+instance FromParam Word32 where
+  fromParam = readMaybe . BC.unpack
+
+instance FromParam Word64 where
+  fromParam = readMaybe . BC.unpack
+
+instance FromParam Int where
+  fromParam = readMaybe . BC.unpack
 
-textToPeerId :: Text -> Maybe PeerId
-textToPeerId = undefined
+instance FromParam PortNumber where
+  fromParam bs = fromIntegral <$> (fromParam bs :: Maybe Word32)
 
-textToPortNumber :: Text -> Maybe PortNumber
-textToPortNumber = undefined
+instance FromParam Event where
+  fromParam bs = case BC.uncons bs of
+    Nothing      -> Nothing
+    Just (x, xs) -> readMaybe $ BC.unpack $ BC.cons (Char.toUpper x) xs
 
-textToHostAddress :: Text -> Maybe HostAddress
-textToHostAddress = undefined
+withError e = maybe (Left e) Right
 
-textToNumWant :: Text -> Maybe Int
-textToNumWant = undefined
+reqParam param xs = do
+  val <- withError (Missing param) $ L.lookup (paramName param) xs
+  withError (Invalid param val) (fromParam val)
 
-textToEvent :: Text -> Maybe Event
-textToEvent = undefined
+optParam param ps
+  | Just x <- L.lookup (paramName param) ps
+  = pure <$> withError (Invalid param x) (fromParam x)
+  | otherwise = pure Nothing
 
-paramName :: QueryParam -> Text
-paramName ParamInfoHash = "info_hash"
-paramName ParamPeerId   = "peer_id"
-paramName ParamPort     = "port"
+parseProgress :: SimpleQuery -> Either ParamParseFailure Progress
+parseProgress params = Progress
+  <$> reqParam ParamDownloaded params
+  <*> reqParam ParamLeft       params
+  <*> reqParam ParamUploaded   params
 
--- | Parse announce request from a decoded query string.
-parseAnnounceQuery :: [(Text, Text)] -> Either ParamParseFailure AnnounceQuery
+-- | Parse announce request from a query string.
+parseAnnounceQuery :: SimpleQuery -> Either ParamParseFailure AnnounceQuery
 parseAnnounceQuery params = AnnounceQuery
-    <$> reqParam ParamInfoHash textToInfoHash    params
-    <*> reqParam ParamPeerId   textToPeerId      params
-    <*> reqParam ParamPort     textToPortNumber  params
-    <*> progress params
-    <*> optParam ParamIP       textToHostAddress params
-    <*> optParam ParamNumWant  textToNumWant     params
-    <*> optParam ParamEvent    textToEvent       params
-  where
-    withError e = maybe (Left e) Right
-    reqParam param p = withError (Missing param) . L.lookup (paramName param)
-                   >=> \x -> withError (Invalid param x) (p x)
-
-    optParam param p ps
-      | Just x <- L.lookup (paramName param) ps
-      = pure <$> withError (Invalid param x) (p x)
-      | otherwise = pure Nothing
-
-    progress = undefined
-    ip       = undefined
-    numwant  = undefined
-    event    = undefined
+  <$> reqParam ParamInfoHash params
+  <*> reqParam ParamPeerId   params
+  <*> reqParam ParamPort     params
+  <*> parseProgress params
+  <*> optParam ParamIP       params
+  <*> optParam ParamNumWant  params
+  <*> optParam ParamEvent    params
 
 -- TODO add extension datatype