Refactor tracker messages

2 files changed, 136 insertions, 128 deletions

diff --git a/src/Data/Torrent/Progress.hs b/src/Data/Torrent/Progress.hs
index c42af248..18a9cd7d 100644
--- a/src/Data/Torrent/Progress.hs
+++ b/src/Data/Torrent/Progress.hs
@@ -34,13 +34,14 @@ module Data.Torrent.Progress
        ) where
 
 import Control.Applicative
-import Control.Lens
+import Control.Lens hiding ((%=))
 import Data.Aeson.TH
 import Data.Default
 import Data.List as L
 import Data.Monoid
 import Data.Serialize as S
 import Data.Ratio
+import Data.URLEncoded
 import Data.Word
 
 
@@ -58,6 +59,7 @@ data Progress = Progress
 $(makeLenses ''Progress)
 $(deriveJSON L.tail ''Progress)
 
+-- | UDP tracker compatible encoding.
 instance Serialize Progress where
   put Progress {..} = do
     putWord64be $ fromIntegral _downloaded
@@ -73,6 +75,7 @@ instance Default Progress where
   def = Progress 0 0 0
   {-# INLINE def #-}
 
+-- | Can be used to aggregate total progress.
 instance Monoid Progress where
   mempty  = def
   {-# INLINE mempty #-}
@@ -84,6 +87,19 @@ instance Monoid Progress where
     }
   {-# INLINE mappend #-}
 
+instance URLShow Word64 where
+  urlShow = show
+  {-# INLINE urlShow #-}
+
+-- | HTTP Tracker protocol compatible encoding.
+instance URLEncode Progress where
+  urlEncode Progress {..} = mconcat
+    [ s "uploaded"   %=  _uploaded
+    , s "left"       %=  _left
+    , s "downloaded" %=  _downloaded
+    ]
+    where s :: String -> String;  s = id; {-# INLINE s #-}
+
 -- | Initial progress is used when there are no session before.
 --
 -- Please note that tracker might penalize client some way if the do
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index 8f4c9228..469ca0ec 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -23,7 +23,7 @@
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# OPTIONS -fno-warn-orphans           #-}
-module Network.BitTorrent.Tracker.Protocol
+module Network.BitTorrent.Tracker.Message
        ( -- * Announce
          Event(..)
        , AnnounceQuery(..)
@@ -71,8 +71,9 @@ import Data.Torrent.Progress
 import Network.BitTorrent.Core.PeerId
 import Network.BitTorrent.Core.PeerAddr
 
+
 {-----------------------------------------------------------------------
-  Announce messages
+--  Events
 -----------------------------------------------------------------------}
 
 -- | Events used to specify which kind of tracker request is performed.
@@ -86,6 +87,40 @@ data Event = Started
 
 $(deriveJSON (L.map toLower . L.dropWhile isLower) ''Event)
 
+-- | HTTP tracker protocol compatible encoding.
+instance URLShow Event where
+  urlShow e = urlShow (Char.toLower x : xs)
+    where
+      -- INVARIANT: this is always nonempty list
+      (x : xs) = show e
+
+type EventId = Word32
+
+-- | UDP tracker encoding event codes.
+eventId :: Event -> EventId
+eventId Completed = 1
+eventId Started   = 2
+eventId Stopped   = 3
+
+-- TODO add Regular event
+putEvent :: Putter (Maybe Event)
+putEvent Nothing  = putWord32be 0
+putEvent (Just e) = putWord32be (eventId e)
+
+getEvent :: S.Get (Maybe Event)
+getEvent = do
+  eid <- getWord32be
+  case eid of
+    0 -> return Nothing
+    1 -> return $ Just Completed
+    2 -> return $ Just Started
+    3 -> return $ Just Stopped
+    _ -> fail "unknown event id"
+
+{-----------------------------------------------------------------------
+  Announce query
+-----------------------------------------------------------------------}
+
 -- | A tracker request is HTTP GET request; used to include metrics
 --   from clients that help the tracker keep overall statistics about
 --   the torrent. The most important, requests are used by the tracker
@@ -121,9 +156,74 @@ data AnnounceQuery = AnnounceQuery {
 
 $(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceQuery)
 
+instance URLShow PortNumber where
+  urlShow = urlShow . fromEnum
+
+instance URLShow Word32 where
+  urlShow = show
+  {-# INLINE urlShow #-}
+
+-- | HTTP tracker protocol compatible encoding.
+instance URLEncode AnnounceQuery where
+  urlEncode AnnounceQuery {..} = mconcat
+      [ s "peer_id"    %=  reqPeerId
+      , s "port"       %=  reqPort
+      , urlEncode reqProgress
+      , s "ip"         %=? reqIP
+      , s "numwant"    %=? reqNumWant
+      , s "event"      %=? reqEvent
+      ]
+    where s :: String -> String;  s = id; {-# INLINE s #-}
+
+-- | UDP tracker protocol compatible encoding.
+instance Serialize AnnounceQuery where
+  put AnnounceQuery {..} = do
+    put           reqInfoHash
+    put           reqPeerId
+    put           reqProgress
+    putEvent      reqEvent
+    putWord32be $ fromMaybe 0 reqIP
+    putWord32be $ 0 -- TODO what the fuck is "key"?
+    putWord32be $ fromIntegral $ fromMaybe (-1) reqNumWant
+
+    put           reqPort
+
+  get = do
+    ih   <- get
+    pid  <- get
+
+    progress <- get
+
+    ev   <- getEvent
+    ip   <- getWord32be
+--    key  <- getWord32be -- TODO
+    want <- getWord32be
+
+    port <- get
+
+    return $ AnnounceQuery {
+        reqInfoHash   = ih
+      , reqPeerId     = pid
+      , reqPort       = port
+      , reqProgress   = progress
+      , reqIP         = if ip == 0 then Nothing else Just ip
+      , reqNumWant    = if want == -1 then Nothing else Just (fromIntegral want)
+      , reqEvent      = ev
+      }
+
+{-----------------------------------------------------------------------
+--  Announce response
+-----------------------------------------------------------------------}
+
 newtype PeerList = PeerList { getPeerList :: [PeerAddr] }
                    deriving (Show, Eq, ToJSON, FromJSON, Typeable)
 
+instance BEncode PeerList where
+  toBEncode   (PeerList xs) = toBEncode xs
+  fromBEncode (BList    l ) = PeerList <$> fromBEncode (BList l)
+  fromBEncode (BString  s ) = PeerList <$> runGet getCompactPeerList s
+  fromBEncode  _            = decodingError "Peer list"
+
 -- | The tracker response includes a peer list that helps the client
 --   participate in the torrent. The most important is 'respPeer' list
 --   used to join the swarm.
@@ -155,31 +255,6 @@ data AnnounceInfo =
 
 $(deriveJSON (L.map toLower . L.dropWhile isLower) ''AnnounceInfo)
 
--- | Ports typically reserved for bittorrent P2P listener.
-defaultPorts :: [PortNumber]
-defaultPorts =  [6881..6889]
-
--- | Above 25, new peers are highly unlikely to increase download
---   speed.  Even 30 peers is /plenty/, the official client version 3
---   in fact only actively forms new connections if it has less than
---   30 peers and will refuse connections if it has 55.
---
---   So the default value is set to 50 because usually 30-50% of peers
---   are not responding.
---
-defaultNumWant :: Int
-defaultNumWant = 50
-
-{-----------------------------------------------------------------------
-  Bencode announce encoding
------------------------------------------------------------------------}
-
-instance BEncode PeerList where
-  toBEncode   (PeerList xs) = toBEncode xs
-  fromBEncode (BList    l ) = PeerList <$> fromBEncode (BList l)
-  fromBEncode (BString  s ) = PeerList <$> runGet getCompactPeerList s
-  fromBEncode  _            = decodingError "Peer list"
-
 -- | HTTP tracker protocol compatible encoding.
 instance BEncode AnnounceInfo where
   toBEncode (Failure t)        = toDict $
@@ -207,105 +282,6 @@ instance BEncode AnnounceInfo where
         <*>? "warning message"
   fromBEncode _ = decodingError "Announce info"
 
-instance URLShow PortNumber where
-  urlShow = urlShow . fromEnum
-
-instance URLShow Word32 where
-  urlShow = show
-
-instance URLShow Event where
-  urlShow e = urlShow (Char.toLower x : xs)
-    where
-      -- INVARIANT: this is always nonempty list
-      (x : xs) = show e
-
-instance URLShow Word64 where
-  urlShow = show
-
-instance URLEncode Progress where
-  urlEncode Progress {..} = mconcat
-    [ s "uploaded"   %=  _uploaded
-    , s "left"       %=  _left
-    , s "downloaded" %=  _downloaded
-    ]
-    where s :: String -> String;  s = id; {-# INLINE s #-}
-
--- | HTTP tracker protocol compatible encoding.
-instance URLEncode AnnounceQuery where
-  urlEncode AnnounceQuery {..} = mconcat
-      [ s "peer_id"    %=  reqPeerId
-      , s "port"       %=  reqPort
-      , urlEncode reqProgress
-
-
-      , s "ip"         %=? reqIP
-      , s "numwant"    %=? reqNumWant
-      , s "event"      %=? reqEvent
-      ]
-    where s :: String -> String;  s = id; {-# INLINE s #-}
-
-{-----------------------------------------------------------------------
-  Binary announce encoding
------------------------------------------------------------------------}
-
-type EventId = Word32
-
-eventId :: Event -> EventId
-eventId Completed = 1
-eventId Started   = 2
-eventId Stopped   = 3
-
--- TODO add Regular event
-putEvent :: Putter (Maybe Event)
-putEvent Nothing  = putWord32be 0
-putEvent (Just e) = putWord32be (eventId e)
-
-getEvent :: S.Get (Maybe Event)
-getEvent = do
-  eid <- getWord32be
-  case eid of
-    0 -> return Nothing
-    1 -> return $ Just Completed
-    2 -> return $ Just Started
-    3 -> return $ Just Stopped
-    _ -> fail "unknown event id"
-
--- | UDP tracker protocol compatible encoding.
-instance Serialize AnnounceQuery where
-  put AnnounceQuery {..} = do
-    put           reqInfoHash
-    put           reqPeerId
-    put           reqProgress
-    putEvent      reqEvent
-    putWord32be $ fromMaybe 0 reqIP
-    putWord32be $ 0 -- TODO what the fuck is "key"?
-    putWord32be $ fromIntegral $ fromMaybe (-1) reqNumWant
-
-    put           reqPort
-
-  get = do
-    ih   <- get
-    pid  <- get
-
-    progress <- get
-
-    ev   <- getEvent
-    ip   <- getWord32be
---    key  <- getWord32be -- TODO
-    want <- getWord32be
-
-    port <- get
-
-    return $ AnnounceQuery {
-        reqInfoHash   = ih
-      , reqPeerId     = pid
-      , reqPort       = port
-      , reqProgress   = progress
-      , reqIP         = if ip == 0 then Nothing else Just ip
-      , reqNumWant    = if want == -1 then Nothing else Just (fromIntegral want)
-      , reqEvent      = ev
-      }
-
 -- | UDP tracker protocol compatible encoding.
 instance Serialize AnnounceInfo where
   put (Failure msg) = put $ encodeUtf8 msg
@@ -330,8 +306,24 @@ instance Serialize AnnounceInfo where
       , respPeers       = PeerList peers
       }
 
+-- TODO move this somewhere else
+-- | Ports typically reserved for bittorrent P2P listener.
+defaultPorts :: [PortNumber]
+defaultPorts =  [6881..6889]
+
+-- | Above 25, new peers are highly unlikely to increase download
+--   speed.  Even 30 peers is /plenty/, the official client version 3
+--   in fact only actively forms new connections if it has less than
+--   30 peers and will refuse connections if it has 55.
+--
+--   So the default value is set to 50 because usually 30-50% of peers
+--   are not responding.
+--
+defaultNumWant :: Int
+defaultNumWant = 50
+
 {-----------------------------------------------------------------------
-  Scrape messages
+  Scrape message
 -----------------------------------------------------------------------}
 
 type ScrapeQuery = [InfoHash]