[HTTP Tracker]: allow to specify path

2 files changed, 62 insertions, 26 deletions

diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index 54de44f7..dc8794b6 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -51,8 +51,6 @@ module Network.BitTorrent.Tracker.Message
        , defaultNumWant
        , defaultMaxNumWant
        , defaultReannounceInterval
-       , announceType
-       , parseFailureStatus
 
          -- * Scrape
          -- ** Query
@@ -64,6 +62,14 @@ module Network.BitTorrent.Tracker.Message
        , ScrapeEntry (..)
        , ScrapeInfo
 
+         -- * HTTP specific
+       , RawPath
+       , defaultAnnouncePath
+       , defaultScrapePath
+       , announceType
+       , scrapeType
+       , parseFailureStatus
+
          -- * Extra
        , queryToSimpleQuery
        )
@@ -615,6 +621,14 @@ defaultMaxNumWant = 200
 defaultReannounceInterval :: Int
 defaultReannounceInterval = 30 * 60
 
+type RawPath = BS.ByteString
+
+defaultAnnouncePath :: RawPath
+defaultAnnouncePath = "announce"
+
+defaultScrapePath :: RawPath
+defaultScrapePath = "scrape"
+
 missingOffset :: Int
 missingOffset = 101
 
@@ -630,10 +644,14 @@ parseFailureMessage e = BS.concat $ case e of
   Missing p   -> ["Missing parameter: ", paramName p]
   Invalid p v -> ["Invalid parameter: ", paramName p, " = ", v]
 
--- | HTTP response /content type/.
+-- | HTTP response /content type/ for announce info.
 announceType :: ByteString
 announceType = "text/plain"
 
+-- | HTTP response /content type/ for scrape info.
+scrapeType :: ByteString
+scrapeType = "text/plain"
+
 -- | Get HTTP response status from a announce params parse failure.
 --
 --   For more info see:
diff --git a/src/Network/BitTorrent/Tracker/Wai.hs b/src/Network/BitTorrent/Tracker/Wai.hs
index 69510fa0..29e0e952 100644
--- a/src/Network/BitTorrent/Tracker/Wai.hs
+++ b/src/Network/BitTorrent/Tracker/Wai.hs
@@ -16,6 +16,7 @@ module Network.BitTorrent.Tracker.Wai
        , tracker
        ) where
 
+import Control.Applicative
 import Control.Monad.Trans.Resource
 import Data.BEncode as BE
 import Data.ByteString
@@ -30,9 +31,12 @@ import Network.BitTorrent.Tracker.Message
 
 -- | Various configuration settings used to generate tracker response.
 data TrackerSettings = TrackerSettings
-  { -- | If peer did not specified the "numwant" then this value is
+  { announcePath          :: !RawPath
+  , scrapePath            :: !RawPath
+
+    -- | If peer did not specified the "numwant" then this value is
     -- used.
-    defNumWant            :: {-# UNPACK #-} !Int
+  , defNumWant            :: {-# UNPACK #-} !Int
 
     -- | If peer specified too big numwant value.
   , maxNumWant            :: {-# UNPACK #-} !Int
@@ -63,7 +67,9 @@ data TrackerSettings = TrackerSettings
 -- | Conservative tracker settings compatible with any client.
 instance Default TrackerSettings where
   def = TrackerSettings
-    { defNumWant            = defaultNumWant
+    { announcePath          = defaultAnnouncePath
+    , scrapePath            = defaultScrapePath
+    , defNumWant            = defaultNumWant
     , maxNumWant            = defaultMaxNumWant
     , reannounceInterval    = defaultReannounceInterval
     , reannounceMinInterval = Nothing
@@ -73,34 +79,46 @@ instance Default TrackerSettings where
     , noPeerId              = False
     }
 
+
+
+{-----------------------------------------------------------------------
+--  Handlers
+-----------------------------------------------------------------------}
+
 getAnnounceR :: TrackerSettings -> AnnounceRequest -> ResourceT IO AnnounceInfo
 getAnnounceR = undefined
 
 getScrapeR :: TrackerSettings -> ScrapeQuery -> ResourceT IO ScrapeInfo
 getScrapeR = undefined
 
+{-----------------------------------------------------------------------
+--  Routing
+-----------------------------------------------------------------------}
+
+announceResponse :: AnnounceInfo -> Response
+announceResponse info = responseLBS ok200 headers $ BE.encode info
+  where
+    headers = [(hContentType, announceType)]
+
+scrapeResponse :: ScrapeInfo -> Response
+scrapeResponse info = responseLBS ok200 headers $ BE.encode info
+  where
+    headers = [(hContentType, scrapeType)]
+
 -- content-type: "text/plain"!
 tracker :: TrackerSettings -> Application
-tracker settings Request {..}
+tracker settings @ TrackerSettings {..} Request {..}
   | requestMethod /= methodGet
   = return $ responseLBS methodNotAllowed405 [] ""
 
-  | otherwise = do
-    case pathInfo of
-      ["announce"] ->
-        case parseAnnounceRequest $ queryToSimpleQuery queryString of
-          Right query -> do
-            info <- getAnnounceR settings query
-            return $ responseLBS ok200 [] $ BE.encode info
-          Left msg ->
-            return $ responseLBS (parseFailureStatus msg) [] ""
-
-      ["scrape"]   ->
-        case Right $ parseScrapeQuery $ queryToSimpleQuery queryString of -- TODO
-          Right query -> do
-            info <- getScrapeR settings query
-            return $ responseLBS ok200 [] $ BE.encode info
-          Left _ ->
-            return $ responseLBS badRequest400 [] ""
-
-      _            -> undefined --badPath
+  | rawPathInfo == announcePath = do
+    case parseAnnounceRequest $ queryToSimpleQuery queryString of
+      Right query -> announceResponse <$> getAnnounceR settings query
+      Left  msg   -> return $ responseLBS (parseFailureStatus msg) [] ""
+
+  | rawPathInfo == scrapePath   = do
+    case Right $ parseScrapeQuery $ queryToSimpleQuery queryString of -- TODO
+      Right query -> scrapeResponse <$> getScrapeR settings query
+      Left  msg   -> return $ responseLBS badRequest400 [] ""
+
+  |     otherwise               = undefined --badPath