6 files changed, 167 insertions, 24 deletions

diff --git a/bittorrent.cabal b/bittorrent.cabal
index 762bff01..c5a8a476 100644
--- a/bittorrent.cabal
+++ b/bittorrent.cabal
@@ -59,21 +59,21 @@ library
 --                   , Network.BitTorrent.DHT.Protocol
 --                   , Network.BitTorrent.DHT.Session
 --                   , Network.BitTorrent.Exchange
-                     , Network.BitTorrent.Exchange.Assembler
-                     , Network.BitTorrent.Exchange.Message
+--                   , Network.BitTorrent.Exchange.Assembler
+--                   , Network.BitTorrent.Exchange.Message
 --                   , Network.BitTorrent.Exchange.Session
 --                     , Network.BitTorrent.Exchange.Status
 --                   , Network.BitTorrent.Exchange.Wire
 --                   , Network.BitTorrent.Extension
 --                   , Network.BitTorrent.Tracker
 --                     , Network.BitTorrent.Tracker.RPC
+                     , Network.BitTorrent.Tracker.Wai
                      , Network.BitTorrent.Tracker.RPC.Message
                      , Network.BitTorrent.Tracker.RPC.HTTP
                      , Network.BitTorrent.Tracker.RPC.UDP
 --                   , Network.BitTorrent.Tracker.Session
 --                   , Network.BitTorrent.Session
 --                   , Network.BitTorrent.Session.Types
---                   , System.IO.MMap.Fixed
 --                   , System.Torrent.Storage
   other-modules:       Paths_bittorrent
 
@@ -86,7 +86,6 @@ library
                        -- Control
                      , deepseq
                      , lens
---                     , mtl
                      , resourcet
 --                     , transformers
 
@@ -131,6 +130,7 @@ library
                      , network     >= 2.4
                      , http-types  >= 0.7
                      , http-conduit
+                     , wai
 --                     , krpc
 
                        -- System
diff --git a/src/Data/Torrent/Block.hs b/src/Data/Torrent/Block.hs
index fd12b7a0..089217fa 100644
--- a/src/Data/Torrent/Block.hs
+++ b/src/Data/Torrent/Block.hs
@@ -7,9 +7,11 @@
 --
 --   Blocks are used to transfer pieces.
 --
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Data.Torrent.Block
        ( -- * Piece attributes
          PieceIx
@@ -38,6 +40,7 @@ import qualified Data.ByteString.Lazy as Lazy
 import Data.Char
 import Data.List as L
 import Data.Serialize as S
+import Data.Typeable
 import Text.PrettyPrint
 import Text.PrettyPrint.Class
 
@@ -95,7 +98,7 @@ data BlockIx = BlockIx {
 
     -- | Block size starting from offset.
   , ixLength :: {-# UNPACK #-} !BlockSize
-  } deriving (Show, Eq)
+  } deriving (Show, Eq, Typeable)
 
 $(deriveJSON defaultOptions { fieldLabelModifier = (L.map toLower . L.dropWhile isLower) } ''BlockIx)
 
@@ -148,7 +151,7 @@ data Block payload = Block {
 
     -- | Payload bytes.
   , blkData   :: !payload
-  } deriving (Show, Eq)
+  } deriving (Show, Eq, Functor, Typeable)
 
 -- | Payload is ommitted.
 instance Pretty (Block Lazy.ByteString) where
diff --git a/src/Data/Torrent/Layout.hs b/src/Data/Torrent/Layout.hs
index d39c6c04..c1e26d48 100644
--- a/src/Data/Torrent/Layout.hs
+++ b/src/Data/Torrent/Layout.hs
@@ -50,7 +50,7 @@ module Data.Torrent.Layout
        , blockCount
 
          -- * Flat file layout
-       , Layout
+       , FileLayout
        , flatLayout
        , accumOffsets
        , fileOffset
@@ -286,13 +286,13 @@ blockCount blkSize ci = contentLength ci `sizeInBase` blkSize
 --   coalesce all the files in the given order to get the linear block
 --   address space.
 --
-type Layout a = [(FilePath, a)]
+type FileLayout a = [(FilePath, a)]
 
 -- | Extract files layout from torrent info with the given root path.
 flatLayout
-  :: FilePath        -- ^ Root path for the all torrent files.
-  -> LayoutInfo      -- ^ Torrent content information.
-  -> Layout FileSize -- ^ The all file paths prefixed with the given root.
+  :: FilePath            -- ^ Root path for the all torrent files.
+  -> LayoutInfo          -- ^ Torrent content information.
+  -> FileLayout FileSize -- ^ The all file paths prefixed with the given root.
 flatLayout prefixPath SingleFile { liFile = FileInfo {..} }
     = [(prefixPath </> BC.unpack fiName, fiLength)]
 flatLayout prefixPath MultiFile  {..}     = L.map mkPath liFiles
@@ -303,14 +303,14 @@ flatLayout prefixPath MultiFile  {..}     = L.map mkPath liFiles
            </> joinPath (L.map BC.unpack fiName)
 
 -- | Calculate offset of each file based on its length, incrementally.
-accumOffsets :: Layout FileSize -> Layout FileOffset
+accumOffsets :: FileLayout FileSize -> FileLayout FileOffset
 accumOffsets = go 0
   where
     go !_ [] = []
     go !offset ((n, s) : xs) = (n, offset) : go (offset + s) xs
 
 -- | Gives global offset of a content file for a given full path.
-fileOffset :: FilePath -> Layout FileOffset -> Maybe FileOffset
+fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset
 fileOffset = lookup
 {-# INLINE fileOffset #-}
 
diff --git a/src/Data/Torrent/Piece.hs b/src/Data/Torrent/Piece.hs
index f7c6257b..31680ce8 100644
--- a/src/Data/Torrent/Piece.hs
+++ b/src/Data/Torrent/Piece.hs
@@ -7,8 +7,9 @@
 --
 --   Pieces are used to validate torrent content.
 --
-{-# LANGUAGE TemplateHaskell    #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Data.Torrent.Piece
        ( -- * Piece attributes
@@ -115,7 +116,7 @@ data Piece a = Piece
 
     -- | Payload.
   , pieceData  :: !a
-  } deriving (Show, Read, Eq, Typeable)
+  } deriving (Show, Read, Eq, Functor, Typeable)
 
 $(deriveJSON defaultOptions { fieldLabelModifier =  (L.map toLower . L.dropWhile isLower) } ''Piece)
 
diff --git a/src/Network/BitTorrent/Tracker/RPC/Message.hs b/src/Network/BitTorrent/Tracker/RPC/Message.hs
index 213f1e83..3900ff64 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