Add http tracker server-side skeleton

2 files changed, 145 insertions, 6 deletions

diff --git a/src/Network/BitTorrent/Tracker/RPC/Message.hs b/src/Network/BitTorrent/Tracker/RPC/Message.hs
index cec68169..cefe96d5 100644
--- a/src/Network/BitTorrent/Tracker/RPC/Message.hs
+++ b/src/Network/BitTorrent/Tracker/RPC/Message.hs
@@ -32,10 +32,18 @@ module Network.BitTorrent.Tracker.RPC.Message
        , ParamParseFailure
        , parseAnnounceQuery
 
+         -- ** Request
+       , AnnounceQueryExt (..)
+       , AnnounceRequest  (..)
+       , parseAnnounceRequest
+       , renderAnnounceRequest
+
          -- ** Info
        , PeerList (..)
        , AnnounceInfo(..)
        , defaultNumWant
+       , defaultMaxNumWant
+       , defaultReannounceInterval
        , parseFailureStatus
 
          -- * Scrape
@@ -47,6 +55,9 @@ module Network.BitTorrent.Tracker.RPC.Message
          -- ** Info
        , ScrapeEntry (..)
        , ScrapeInfo
+
+         -- ** Extra
+       , queryToSimpleQuery
        )
        where
 
@@ -223,15 +234,15 @@ instance QueryLike AnnounceQuery where
       , ("event"    , toQueryValue reqEvent)
       ]
 
-filterMaybes :: [(a, Maybe b)] -> [(a, b)]
-filterMaybes = catMaybes . L.map f
+queryToSimpleQuery :: Query -> SimpleQuery
+queryToSimpleQuery = catMaybes . L.map f
   where
     f (_, Nothing) = Nothing
     f (a, Just b ) = Just (a, b)
 
 -- | Encode announce query and add it to the base tracker URL.
 renderAnnounceQuery :: AnnounceQuery -> SimpleQuery
-renderAnnounceQuery = filterMaybes . toQuery
+renderAnnounceQuery = queryToSimpleQuery . toQuery
 
 data QueryParam
   = ParamInfoHash
@@ -320,8 +331,27 @@ parseAnnounceQuery params = AnnounceQuery
   <*> optParam ParamNumWant  params
   <*> optParam ParamEvent    params
 
--- TODO add extension datatype
---type AnnounceRequest = ()
+data AnnounceQueryExt = AnnounceQueryExt
+  { extCompact  :: Maybe Bool -- | "compact" param
+  , extNoPeerId :: Maybe Bool -- | "no_peer_id" param
+  } deriving (Show, Eq, Typeable)
+
+parseAnnounceQueryExt :: SimpleQuery -> AnnounceQueryExt
+parseAnnounceQueryExt = undefined
+
+renderAnnounceQueryExt :: AnnounceQueryExt -> SimpleQuery
+renderAnnounceQueryExt = undefined
+
+data AnnounceRequest = AnnounceRequest
+  { announceQuery   :: AnnounceQuery
+  , announceAdvises :: AnnounceQueryExt
+  } deriving (Show, Eq, Typeable)
+
+parseAnnounceRequest :: SimpleQuery -> Either ParamParseFailure AnnounceRequest
+parseAnnounceRequest = undefined
+
+renderAnnounceRequest :: AnnounceRequest -> SimpleQuery
+renderAnnounceRequest = undefined
 
 {-----------------------------------------------------------------------
 --  Announce response
@@ -449,6 +479,13 @@ instance Serialize AnnounceInfo where
 defaultNumWant :: Int
 defaultNumWant = 50
 
+defaultMaxNumWant :: Int
+defaultMaxNumWant = 200
+
+defaultReannounceInterval :: Int
+defaultReannounceInterval = 30 * 60
+
+
 missingOffset :: Int
 missingOffset = 101
 
@@ -500,7 +537,7 @@ isScrapeParam :: BS.ByteString -> Bool
 isScrapeParam = (==) scrapeParam
 
 renderScrapeQuery :: ScrapeQuery -> SimpleQuery
-renderScrapeQuery = filterMaybes . L.map mkPair
+renderScrapeQuery = queryToSimpleQuery . L.map mkPair
   where
     mkPair ih = (scrapeParam, toQueryValue ih)
 
diff --git a/src/Network/BitTorrent/Tracker/Wai.hs b/src/Network/BitTorrent/Tracker/Wai.hs
new file mode 100644
index 00000000..f290c380
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/Wai.hs
@@ -0,0 +1,102 @@
+-- supported extensions:
+--
+--   no_peer_id - do not send peer id if no_peer_id=1 specified
+--   http://www.bittorrent.org/beps/bep_0023.html
+--
+--   compact - compact=1 or compact=0
+--   http://permalink.gmane.org/gmane.network.bit-torrent.general/4030
+--
+--
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.Tracker.Wai
+       ( tracker
+       ) where
+
+import Control.Monad.Trans.Resource
+import Data.BEncode as BE
+import Data.ByteString
+import Data.Default
+import Data.List as L
+import Network.HTTP.Types
+import Network.Wai
+
+import Data.Torrent.Progress
+import Network.BitTorrent.Core.PeerId
+import Network.BitTorrent.Core.PeerAddr
+import Network.BitTorrent.Tracker.RPC.Message
+
+
+data TrackerSettings = TrackerSettings
+  { -- | If peer did not specified the "numwant" then this value is
+    -- used.
+    defNumWant            :: {-# UNPACK #-} !Int
+
+    -- | If peer specified to big numwant value.
+  , maxNumWant            :: {-# UNPACK #-} !Int
+
+    -- | Recommended time interval to wait between regular announce
+    -- requests.
+  , reannounceInterval    :: {-# UNPACK #-} !Int
+
+    -- | Minimum time interval to wait between regular announce
+    -- requests.
+  , reannounceMinInterval :: !(Maybe Int)
+
+    -- | Whether to send count of seeders.
+  , completePeers         :: !Bool
+
+    -- | Whether to send count of leechers.
+  , incompletePeers       :: !Bool
+
+    -- | Do not send peer id in response. Peer can override this value
+    -- by setting "no_peer_id" to 0 or 1.
+  , noPeerId              :: !Bool
+
+    -- | Whether to send compact peer list. Peer can override this
+    -- value by setting "compact" to 0 or 1.
+  , compactPeerList       :: !Bool
+  }
+
+instance Default TrackerSettings where
+  def = TrackerSettings
+    { defNumWant            = defaultNumWant
+    , maxNumWant            = defaultMaxNumWant
+    , reannounceInterval    = defaultReannounceInterval
+    , reannounceMinInterval = Nothing
+    , compactPeerList       = False
+    , completePeers         = False
+    , incompletePeers       = False
+    , noPeerId              = False
+    }
+
+getAnnounceR :: AnnounceRequest -> ResourceT IO AnnounceInfo
+getAnnounceR = undefined
+
+getScrapeR :: ScrapeQuery -> ResourceT IO ScrapeInfo
+getScrapeR = undefined
+
+-- content-type: "text/plain" ?
+tracker :: Application
+tracker Request {..}
+  | requestMethod /= methodGet
+  = return $ responseLBS methodNotAllowed405 [] ""
+
+  | otherwise = do
+    case pathInfo of
+      ["announce"] ->
+        case parseAnnounceRequest $ queryToSimpleQuery queryString of
+          Right query -> do
+            info <- getAnnounceR 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 query
+            return $ responseLBS ok200 [] $ BE.encode info
+          Left _ ->
+            return $ responseLBS badRequest400 [] ""
+
+      _            -> undefined --badPath