~ Group AnnounceQuery progress fields to Progress.

4 files changed, 96 insertions, 87 deletions

diff --git a/src/Network/BitTorrent/Peer.hs b/src/Network/BitTorrent/Peer.hs
index a4d026dc..d951a1cd 100644
--- a/src/Network/BitTorrent/Peer.hs
+++ b/src/Network/BitTorrent/Peer.hs
@@ -28,6 +28,7 @@
 --     capabilities (such as supported enchancements), this should be
 --     done using 'Network.BitTorrent.Extension'!
 --
+{-# LANGUAGE ViewPatterns               #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TemplateHaskell            #-}
@@ -56,6 +57,19 @@ module Network.BitTorrent.Peer
        , connectToPeer
        , ppPeer
 
+         -- * Peer progress
+       , Progress (..)
+       , left
+       , uploaded
+       , downloaded
+
+       , startProgress
+
+       , downloadedProgress
+       , enqueuedProgress
+       , uploadedProgress
+       , dequeuedProgress
+
          -- * Client version detection
          -- ** Info
        , ClientInfo(..), clientInfo, ppClientInfo, unknownClient
@@ -70,18 +84,19 @@ module Network.BitTorrent.Peer
 
 
 import Control.Applicative
+import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
 import Data.BEncode
 import Data.Bits
-import Data.Char
-import Data.List as L
-import Data.Word
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Lazy.Builder as B
+import Data.Char
+import Data.List as L
+import Data.Word
 import Data.Foldable    (foldMap)
 import Data.Monoid      ((<>))
 import Data.Serialize
@@ -577,3 +592,70 @@ ppPeer p @ PeerAddr {..} = case peerID of
     Nothing  -> paddr
   where
     paddr = text (show (peerSockAddr p))
+
+{-----------------------------------------------------------------------
+  Progress
+-----------------------------------------------------------------------}
+
+-- TODO: Use Word64?
+-- TODO: Use atomic bits?
+
+-- | 'Progress' contains upload/download/left stats about
+--   current client state and used to notify the tracker.
+--
+-- Progress data is considered as dynamic within one client
+-- session. This data also should be shared across client application
+-- sessions (e.g. files), otherwise use 'startProgress' to get initial
+-- 'Progress'.
+--
+data Progress = Progress
+  { _downloaded :: !Integer -- ^ Total amount of bytes downloaded;
+  , _left       :: !Integer -- ^ Total amount of bytes left;
+  , _uploaded   :: !Integer -- ^ Total amount of bytes uploaded.
+  } deriving (Show, Read, Eq)
+
+$(makeLenses ''Progress)
+$(deriveJSON (L.tail) ''Progress)
+
+instance Serialize Progress where
+  put Progress {..} = do
+    putWord64be $ fromIntegral _downloaded
+    putWord64be $ fromIntegral _left
+    putWord64be $ fromIntegral _uploaded
+
+  get = Progress
+    <$> (fromIntegral <$> getWord64be)
+    <*> (fromIntegral <$> getWord64be)
+    <*> (fromIntegral <$> getWord64be)
+
+-- | Initial progress is used when there are no session before.
+--
+-- Please note that tracker might penalize client some way if the do
+-- not accumulate progress. If possible and save 'Progress' between
+-- client sessions to avoid that.
+--
+startProgress :: Integer -> Progress
+startProgress = Progress 0 0
+
+-- | Used when the client download some data from /any/ peer.
+downloadedProgress :: Int -> Progress -> Progress
+downloadedProgress (fromIntegral -> amount)
+                 = (left         -~ amount)
+                 . (downloaded   +~ amount)
+{-# INLINE downloadedProgress #-}
+
+-- | Used when the client upload some data to /any/ peer.
+uploadedProgress :: Int -> Progress -> Progress
+uploadedProgress (fromIntegral -> amount) = uploaded +~ amount
+{-# INLINE uploadedProgress #-}
+
+-- | Used when leecher join client session.
+enqueuedProgress :: Integer -> Progress -> Progress
+enqueuedProgress amount = left +~ amount
+{-# INLINE enqueuedProgress #-}
+
+-- | Used when leecher leave client session.
+--   (e.g. user deletes not completed torrent)
+dequeuedProgress :: Integer -> Progress -> Progress
+dequeuedProgress amount = left -~ amount
+{-# INLINE dequeuedProgress #-}
diff --git a/src/Network/BitTorrent/Sessions/Types.lhs b/src/Network/BitTorrent/Sessions/Types.lhs
index 3dde1853..7ee7cbec 100644
--- a/src/Network/BitTorrent/Sessions/Types.lhs
+++ b/src/Network/BitTorrent/Sessions/Types.lhs
@@ -17,11 +17,6 @@
 >        , TorrentLoc (..)
 >        , TorrentMap
 >
->        , Progress (..)
->        , left, uploaded, downloaded
->        , startProgress
->        , enqueuedProgress, uploadedProgress, dequeuedProgress
->
 >        , ClientSession (..)
 >
 >        , SwarmSession (..)
@@ -65,7 +60,6 @@
 > import Network.BitTorrent.Extension
 > import Network.BitTorrent.Peer
 > import Network.BitTorrent.Exchange.Protocol as BT
-> import Network.BitTorrent.Tracker.Protocol as BT
 > import System.Torrent.Storage
 
 Thread layout
@@ -173,58 +167,6 @@ so we need to do this on demand: if a peer asks for a block, we
 validate corresponding piece and only after read and send the block
 back.
 
-Progress
-------------------------------------------------------------------------
-
-Progress data is considered as dynamic within one client session. This
-data also should be shared across client application sessions
-(e.g. files), otherwise use 'startProgress' to get initial 'Progress'.
-
-> -- | 'Progress' contains upload/download/left stats about
-> --   current client state and used to notify the tracker.
-> data Progress = Progress {
->     _uploaded   :: !Integer -- ^ Total amount of bytes uploaded.
->   , _downloaded :: !Integer -- ^ Total amount of bytes downloaded.
->   , _left       :: !Integer -- ^ Total amount of bytes left.
->   } deriving (Show, Read, Eq)
->
-> $(makeLenses ''Progress)
-
-**TODO:** Use Word64?
-
-**TODO:** Use atomic bits?
-
-Please note that tracker might penalize client some way if the do
-not accumulate progress. If possible and save 'Progress' between
-client sessions to avoid that.
-
-> -- | Initial progress is used when there are no session before.
-> startProgress :: Integer -> Progress
-> startProgress = Progress 0 0
-
-> -- | Used when the client download some data from /any/ peer.
-> downloadedProgress :: Int -> Progress -> Progress
-> downloadedProgress (fromIntegral -> amount)
->                  = (left         -~ amount)
->                  . (downloaded   +~ amount)
-> {-# INLINE downloadedProgress #-}
-
-> -- | Used when the client upload some data to /any/ peer.
-> uploadedProgress :: Int -> Progress -> Progress
-> uploadedProgress (fromIntegral -> amount) = uploaded +~ amount
-> {-# INLINE uploadedProgress #-}
-
-> -- | Used when leecher join client session.
-> enqueuedProgress :: Integer -> Progress -> Progress
-> enqueuedProgress amount = left +~ amount
-> {-# INLINE enqueuedProgress #-}
-
-> -- | Used when leecher leave client session.
-> --   (e.g. user deletes not completed torrent)
-> dequeuedProgress :: Integer -> Progress -> Progress
-> dequeuedProgress amount = left -~ amount
-> {-# INLINE dequeuedProgress #-}
-
 Client Sessions
 ------------------------------------------------------------------------
 
diff --git a/src/Network/BitTorrent/Tracker.hs b/src/Network/BitTorrent/Tracker.hs
index e98f1e94..c707cedd 100644
--- a/src/Network/BitTorrent/Tracker.hs
+++ b/src/Network/BitTorrent/Tracker.hs
@@ -41,7 +41,6 @@ import Network.URI
 
 import Data.Torrent.Metainfo
 import Network.BitTorrent.Peer
-import Network.BitTorrent.Sessions.Types
 import Network.BitTorrent.Tracker.Protocol
 import Network.BitTorrent.Tracker.HTTP
 
@@ -73,9 +72,7 @@ genericReq ses pr =   AnnounceQuery {
   , reqPeerId     = tconnPeerId   ses
   , reqPort       = tconnPort     ses
 
-  , reqUploaded   = _uploaded   pr
-  , reqDownloaded = _downloaded pr
-  , reqLeft       = _left       pr
+  , reqProgress   = pr
 
   , reqIP         = Nothing
   , reqNumWant    = Nothing
diff --git a/src/Network/BitTorrent/Tracker/Protocol.hs b/src/Network/BitTorrent/Tracker/Protocol.hs
index e7755a10..3f264aed 100644
--- a/src/Network/BitTorrent/Tracker/Protocol.hs
+++ b/src/Network/BitTorrent/Tracker/Protocol.hs
@@ -63,6 +63,7 @@ import Network
 import Network.Socket
 
 import Network.BitTorrent.Peer
+import Network.BitTorrent.Sessions.Types
 
 {-----------------------------------------------------------------------
   Announce messages
@@ -97,14 +98,8 @@ data AnnounceQuery = AnnounceQuery {
      -- peers. Normally, tracker should respond with this port when
      -- some peer request the tracker with the same info hash.
 
-   , reqUploaded   :: !Integer
-     -- ^ Number of bytes that the peer has uploaded in the swarm.
-
-   , reqDownloaded :: !Integer
-     -- ^ Number of bytes downloaded in the swarm by the peer.
-
-   , reqLeft       :: !Integer
-     -- ^ Number of bytes needed in order to complete download.
+   , reqProgress   :: !Progress
+     -- ^ Current progress of peer doing request.
 
    , reqIP         :: Maybe HostAddress
      -- ^ The peer IP. Needed only when client communicated with
@@ -213,9 +208,9 @@ instance URLEncode AnnounceQuery where
   urlEncode AnnounceQuery {..} = mconcat
       [ s "peer_id"    %=  reqPeerId
       , s "port"       %=  reqPort
-      , s "uploaded"   %=  reqUploaded
-      , s "downloaded" %=  reqDownloaded
-      , s "left"       %=  reqLeft
+      , s "uploaded"   %=  _uploaded   reqProgress
+      , s "left"       %=  _left       reqProgress
+      , s "downloaded" %=  _downloaded reqProgress
       , s "ip"         %=? reqIP
       , s "numwant"    %=? reqNumWant
       , s "event"      %=? reqEvent
@@ -248,15 +243,12 @@ getEvent = do
     3 -> return $ Just Stopped
     _ -> fail "unknown event id"
 
+
 instance Serialize AnnounceQuery where
   put AnnounceQuery {..} = do
     put           reqInfoHash
     put           reqPeerId
-
-    putWord64be $ fromIntegral reqDownloaded
-    putWord64be $ fromIntegral reqLeft
-    putWord64be $ fromIntegral reqUploaded
-
+    put           reqProgress
     putEvent      reqEvent
     putWord32be $ fromMaybe 0 reqIP
     putWord32be $ 0 -- TODO what the fuck is "key"?
@@ -268,9 +260,7 @@ instance Serialize AnnounceQuery where
     ih   <- get
     pid  <- get
 
-    down <- getWord64be
-    left <- getWord64be
-    up   <- getWord64be
+    progress <- get
 
     ev   <- getEvent
     ip   <- getWord32be
@@ -283,9 +273,7 @@ instance Serialize AnnounceQuery where
         reqInfoHash   = ih
       , reqPeerId     = pid
       , reqPort       = port
-      , reqUploaded   = fromIntegral up
-      , reqDownloaded = fromIntegral down
-      , reqLeft       = fromIntegral left
+      , reqProgress   = progress
       , reqIP         = if ip == 0 then Nothing else Just ip
       , reqNumWant    = if want == -1 then Nothing else Just (fromIntegral want)
       , reqEvent      = ev