Redesign tracker subsustem

6 files changed, 145 insertions, 64 deletions

diff --git a/src/Network/BitTorrent/Tracker/Extension.hs b/src/Network/BitTorrent/Tracker/Extension.hs
new file mode 100644
index 00000000..57e346d6
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/Extension.hs
@@ -0,0 +1,7 @@
+module Network.BitTorrent.Tracker.Extension
+       (
+       ) where
+
+data Extension
+  = NoPeerId
+  | CompactPeers
\ No newline at end of file
diff --git a/src/Network/BitTorrent/Tracker/RPC.hs b/src/Network/BitTorrent/Tracker/RPC.hs
new file mode 100644
index 00000000..c5aaeb03
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/RPC.hs
@@ -0,0 +1,41 @@
+module Network.BitTorrent.Tracker.RPC
+       ( module Network.BitTorrent.Tracker.RPC.Message
+       , TrackerRPC (..)
+       ) where
+
+import Network.BitTorrent.Tracker.RPC.Message
+import Network.BitTorrent.Tracker.RPC.HTTP as HTTP
+import Network.BitTorrent.Tracker.RPC.UDP  as UDP
+
+-- | Set of tracker RPCs.
+class Tracker s where
+  connect  :: URI -> IO s
+  announce :: s -> AnnounceQuery -> IO AnnounceInfo
+  scrape   :: s -> ScrapeQuery   -> IO Scrape
+
+instance Tracker HTTP.Tracker where
+  connect  = return . HTTP.Tracker
+  announce = HTTP.announce
+  scrape   = undefined
+
+instance Tracker UDP.Tracker where
+  connect  = initialTracker
+  announce = announce
+  scrape   = undefined
+
+data BitTracker = HTTPTr HTTPTracker
+                | UDPTr UDPTracker
+
+instance Tracker BitTracker where
+  connect uri @ URI {..}
+    | uriScheme == "udp:"  = UDPTr  <$> connect uri
+    | uriScheme == "http:" = HTTPTr <$> connect uri
+    |       otherwise      = throwIO $ userError msg
+    where
+      msg = "unknown tracker protocol scheme: " ++ show uriScheme
+
+  announce (HTTPTr t) = Tracker.announce t
+  announce (UDPTr  t) = Tracker.announce t
+
+  scrape (HTTPTr t) = scrape t
+  scrape (UDPTr  t) = scrape t
diff --git a/src/Network/BitTorrent/Tracker/HTTP.hs b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
index b466b49e..0eef2b7e 100644
--- a/src/Network/BitTorrent/Tracker/HTTP.hs
+++ b/src/Network/BitTorrent/Tracker/RPC/HTTP.hs
@@ -13,78 +13,50 @@
 --   For more information see:
 --   <https://wiki.theory.org/BitTorrentSpecification#Tracker_HTTP.2FHTTPS_Protocol>
 --
-module Network.BitTorrent.Tracker.HTTP
-       ( HTTPTracker
-
-         -- * Extra
---       , scrapeURL
+module Network.BitTorrent.Tracker.RPC.HTTP
+       ( Connection
+       , connect
+       , announce
+       , scrape
        ) where
 
+import Control.Applicative
 import Control.Exception
-import Data.BEncode
+import Data.BEncode as BE
 import Data.ByteString as B
 import Data.ByteString.Char8 as BC
+import Data.ByteString.Lazy  as BL
 import Data.List as L
 import Data.Map as M
 import Data.Monoid
-import Data.URLEncoded as URL
 import Network.URI
-import Network.HTTP
+import Network.HTTP.Conduit
 
 import Data.Torrent.InfoHash
-import Network.BitTorrent.Tracker.Message
+import Network.BitTorrent.Tracker.RPC.Message
 
--- | Set of tracker RPCs.
-class Tracker s where
-  connect  :: URI -> IO s
-  announce :: s -> AnnounceQuery -> IO AnnounceInfo
-  scrape   :: s -> ScrapeQuery   -> IO Scrape
 
--- | More particular version of 'scrape', just for one torrent.
---
-scrapeOne :: Tracker t => t -> InfoHash -> IO ScrapeInfo
-scrapeOne uri ih = scrape uri [ih] >>= maybe err return . M.lookup ih
-  where
-    err = throwIO $ userError "unable to find info hash in response dict"
-
-data HTTPTracker = HTTPTracker
+data Connection = Connection
   { announceURI :: URI
   } deriving Show
 
-instance Tracker HTTPTracker where
-  connect  = return . HTTPTracker
-  announce = announceHTTP
---  scrape   = scrapeHTTP
-
-{-----------------------------------------------------------------------
-  Announce
------------------------------------------------------------------------}
-
-mkGET :: URI -> Request ByteString
-mkGET uri = Request uri GET [] ""
+connect :: URI -> IO Connection
+connect = return . Connection
 
 -- | Send request and receive response from the tracker specified in
 -- announce list. This function throws 'IOException' if it couldn't
 -- send request or receive response or decode response.
 --
-announceHTTP :: HTTPTracker -> AnnounceQuery -> IO AnnounceInfo
-announceHTTP HTTPTracker {..} req = do
-    let r = mkGET (renderAnnounceQuery announceURI req)
+announce :: AnnounceQuery -> Connection -> IO (Result AnnounceInfo)
+announce req = do
+  let uri = undefined
+  resp  <- BL.toStrict <$> simpleHttp uri
+  return $ BE.decode resp
 
-    rawResp  <- simpleHTTP r
-    respBody <- getResponseBody rawResp
-    checkResult $ decode respBody
-  where
-    checkResult (Left err)
-      = ioError $ userError $ err ++ " in tracker response"
-    checkResult (Right (Failure err))
-      = ioError $ userError $ show err ++ " in tracker response"
-    checkResult (Right resp)          = return resp
-{-
-{-----------------------------------------------------------------------
-  Scrape
------------------------------------------------------------------------}
+scrape :: ScrapeQuery -> Connection -> IO (Result Scrape)
+scrape = undefined
 
+{-
 -- | Trying to convert /announce/ URL to /scrape/ URL. If 'scrapeURL'
 --   gives 'Nothing' then tracker do not support scraping. The info hash
 --   list is used to restrict the tracker's report to that particular
@@ -123,4 +95,12 @@ scrapeHTTP HTTPTracker {..} ihs
       Right r -> return r
 
   | otherwise = throwIO $ userError "Tracker do not support scraping"
+
+-- | More particular version of 'scrape', just for one torrent.
+--
+scrapeOne :: Tracker t => t -> InfoHash -> IO ScrapeInfo
+scrapeOne uri ih = scrape uri [ih] >>= maybe err return . M.lookup ih
+  where
+    err = throwIO $ userError "unable to find info hash in response dict"
+
 -}
\ No newline at end of file
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/RPC/Message.hs
index dde13155..18c1a4c7 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/RPC/Message.hs
@@ -23,7 +23,7 @@
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# OPTIONS -fno-warn-orphans           #-}
-module Network.BitTorrent.Tracker.Message
+module Network.BitTorrent.Tracker.RPC.Message
        ( -- * Announce
          -- ** Request
          Event(..)
@@ -132,7 +132,7 @@ getEvent = do
 data AnnounceQuery = AnnounceQuery
    {
      -- | Hash of info part of the torrent usually obtained from
-     -- 'Torrent'.
+     -- 'Torrent' or 'Magnet'.
      reqInfoHash   :: !InfoHash
 
      -- | ID of the peer doing request.
diff --git a/src/Network/BitTorrent/Tracker/UDP.hs b/src/Network/BitTorrent/Tracker/RPC/UDP.hs
index 59714317..beff6b4f 100644
--- a/src/Network/BitTorrent/Tracker/UDP.hs
+++ b/src/Network/BitTorrent/Tracker/RPC/UDP.hs
@@ -13,8 +13,12 @@
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeFamilies               #-}
-module Network.BitTorrent.Tracker.UDP
+module Network.BitTorrent.Tracker.RPC.UDP
        ( UDPTracker
+       , connect
+       , announce
+       , scrape
+       , retransmission
 
          -- * Debug
        , putTracker
@@ -42,7 +46,7 @@ import System.Entropy
 import System.Timeout
 import Numeric
 
-import Network.BitTorrent.Tracker.Protocol
+import Network.BitTorrent.Tracker.RPC.Message
 
 {-----------------------------------------------------------------------
   Tokens
@@ -301,16 +305,16 @@ freshConnection tracker @ UDPTracker {..} = do
     connId <- connectUDP tracker
     updateConnection connId tracker
 
-announceUDP :: UDPTracker -> AnnounceQuery -> IO AnnounceInfo
-announceUDP tracker ann = do
+announce :: UDPTracker -> AnnounceQuery -> IO AnnounceInfo
+announce tracker ann = do
   freshConnection tracker
   resp <- transaction tracker (Announce ann)
   case resp of
     Announced info -> return info
     _              -> fail "announce: response type mismatch"
 
-scrapeUDP :: UDPTracker -> ScrapeQuery -> IO Scrape
-scrapeUDP tracker scr = do
+scrape :: UDPTracker -> ScrapeQuery -> IO Scrape
+scrape tracker scr = do
   freshConnection tracker
   resp <- transaction tracker (Scrape scr)
   case resp of
@@ -338,10 +342,3 @@ retransmission action = go minTimeout
       |       otherwise         = do
         r <- timeout curTimeout action
         maybe (go (2 * curTimeout)) return r
-
-{----------------------------------------------------------------------}
-
-instance Tracker UDPTracker where
-  connect    = initialTracker
-  announce t = retransmission . announceUDP t
-  scrape   t = retransmission . scrapeUDP   t
diff --git a/src/Network/BitTorrent/Tracker/Session.hs b/src/Network/BitTorrent/Tracker/Session.hs
new file mode 100644
index 00000000..3cfc4b52
--- /dev/null
+++ b/src/Network/BitTorrent/Tracker/Session.hs
@@ -0,0 +1,56 @@
+module Network.BitTorrent.Tracker.Session
+       (
+       ) where
+
+import Data.Torrent.Progress
+import Data.Torrent.InfoHash
+import Network.BitTorrent.Core.PeerAddr
+import Network.BitTorrent.Tracker.Message
+
+data PeerInfo = PeerInfo
+  { peerId   :: PeerId
+  , peerPort :: PortNumber
+  , peerIP   :: Maybe HostAddress
+  }
+
+data Session  = Session
+  { sesInfoHash :: !InfoHash
+  , sesPeerInfo :: !PeerInfo
+  }
+
+data SAnnounceQuery = SAnnounceQuery
+  { sreqProgress :: Progress
+  , sreqNumWant  :: Maybe Int
+  , sreqEvent    :: Maybe Event
+  }
+
+type SAnnounceInfo = [PeerAddr]
+
+f :: Session  ->  SAnnounceQuery  ->    AnnounceQuery
+f    Session {..} SAnnounceQuery {..} = AnnounceQuery
+  { reqInfoHash = sesInfoHash
+  , reqPeerInfo = sesPeerInfo
+  , reqProgress = sreqProgress
+  , reqNumWant  = undefined
+  , reqEvent    = sreqEvent
+  }
+
+data Settings = Settings
+
+data Manager  = Manager
+  {
+  }
+
+
+g :: Session -> AnnounceInfo -> SAnnounceInfo
+g Session {..} SAnnounceInfo {..} = undefined
+
+
+reannounce :: HTracker -> IO ()
+reannounce = undefined
+
+forceReannounce :: HTracker -> IO ()
+forceReannounce = undefined
+
+scrape :: HTracker -> IO ()
+scrape = undefined