1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
-- |
-- Copyright : (c) Sam Truzjan 2013
-- License : BSD3
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- 'Progress' used to track amount downloaded\/left\/upload bytes
-- either on per client or per torrent basis. This value is used to
-- notify the tracker and usually shown to the user. To aggregate
-- total progress you can use the Monoid instance.
--
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS -fno-warn-orphans #-}
module Network.BitTorrent.Internal.Progress
( -- * Progress
Progress (..)
-- * Lens
, left
, uploaded
, downloaded
-- * Construction
, startProgress
, downloadedProgress
, enqueuedProgress
, uploadedProgress
, dequeuedProgress
-- * Query
, canDownload
, canUpload
) where
import Control.Applicative
import Control.Lens hiding ((%=))
import Data.ByteString.Lazy.Builder as BS
import Data.ByteString.Lazy.Builder.ASCII as BS
import Data.Default
import Data.Monoid
import Data.Serialize as S
import Data.Ratio
import Data.Word
import Network.HTTP.Types.QueryLike
import Text.PrettyPrint as PP
import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
-- | 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' value.
--
data Progress = Progress
{ _downloaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes downloaded;
, _left :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes left;
, _uploaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes uploaded.
} deriving (Show, Read, Eq)
$(makeLenses ''Progress)
-- | UDP tracker compatible encoding.
instance Serialize Progress where
put Progress {..} = do
putWord64be $ fromIntegral _downloaded
putWord64be $ fromIntegral _left
putWord64be $ fromIntegral _uploaded
get = Progress
<$> (fromIntegral <$> getWord64be)
<*> (fromIntegral <$> getWord64be)
<*> (fromIntegral <$> getWord64be)
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 #-}
mappend (Progress da la ua) (Progress db lb ub) = Progress
{ _downloaded = da + db
, _left = la + lb
, _uploaded = ua + ub
}
{-# INLINE mappend #-}
instance QueryValueLike Builder where
toQueryValue = toQueryValue . BS.toLazyByteString
instance QueryValueLike Word64 where
toQueryValue = toQueryValue . BS.word64Dec
-- | HTTP Tracker protocol compatible encoding.
instance QueryLike Progress where
toQuery Progress {..} =
[ ("uploaded" , toQueryValue _uploaded)
, ("left" , toQueryValue _left)
, ("downloaded", toQueryValue _downloaded)
]
instance Pretty Progress where
pPrint Progress {..} =
"/\\" <+> PP.text (show _uploaded) $$
"\\/" <+> PP.text (show _downloaded) $$
"left" <+> PP.text (show _left)
-- | 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 . fromIntegral
{-# INLINE startProgress #-}
-- | 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 +~ fromIntegral amount
{-# INLINE enqueuedProgress #-}
-- | Used when leecher leave client session.
-- (e.g. user deletes not completed torrent)
dequeuedProgress :: Integer -> Progress -> Progress
dequeuedProgress amount = left -~ fromIntegral amount
{-# INLINE dequeuedProgress #-}
ri2rw64 :: Ratio Int -> Ratio Word64
ri2rw64 x = fromIntegral (numerator x) % fromIntegral (denominator x)
-- | Check global /download/ limit by uploaded \/ downloaded ratio.
canDownload :: Ratio Int -> Progress -> Bool
canDownload limit Progress {..} = _uploaded % _downloaded > ri2rw64 limit
-- | Check global /upload/ limit by downloaded \/ uploaded ratio.
canUpload :: Ratio Int -> Progress -> Bool
canUpload limit Progress {..} = _downloaded % _uploaded > ri2rw64 limit
|
