diff options
author | James Crayne <jim.crayne@gmail.com> | 2019-09-28 13:43:29 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 19:27:53 -0500 |
commit | 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch) | |
tree | 5716463275c2d3e902889db619908ded2a73971c /bittorrent/src/Network/BitTorrent/Internal/Progress.hs | |
parent | add2c76bced51fde5e9917e7449ef52be70faf87 (diff) |
Factor out some new libraries
word64-map:
Data.Word64Map
network-addr:
Network.Address
tox-crypto:
Crypto.Tox
lifted-concurrent:
Control.Concurrent.Lifted.Instrument
Control.Concurrent.Async.Lifted.Instrument
psq-wrap:
Data.Wrapper.PSQInt
Data.Wrapper.PSQ
minmax-psq:
Data.MinMaxPSQ
tasks:
Control.Concurrent.Tasks
kad:
Network.Kademlia
Network.Kademlia.Bootstrap
Network.Kademlia.Routing
Network.Kademlia.CommonAPI
Network.Kademlia.Persistence
Network.Kademlia.Search
Diffstat (limited to 'bittorrent/src/Network/BitTorrent/Internal/Progress.hs')
-rw-r--r-- | bittorrent/src/Network/BitTorrent/Internal/Progress.hs | 154 |
1 files changed, 0 insertions, 154 deletions
diff --git a/bittorrent/src/Network/BitTorrent/Internal/Progress.hs b/bittorrent/src/Network/BitTorrent/Internal/Progress.hs deleted file mode 100644 index 6ac889e2..00000000 --- a/bittorrent/src/Network/BitTorrent/Internal/Progress.hs +++ /dev/null | |||
@@ -1,154 +0,0 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- 'Progress' used to track amount downloaded\/left\/upload bytes | ||
9 | -- either on per client or per torrent basis. This value is used to | ||
10 | -- notify the tracker and usually shown to the user. To aggregate | ||
11 | -- total progress you can use the Monoid instance. | ||
12 | -- | ||
13 | {-# LANGUAGE TemplateHaskell #-} | ||
14 | {-# LANGUAGE ViewPatterns #-} | ||
15 | {-# OPTIONS -fno-warn-orphans #-} | ||
16 | module Network.BitTorrent.Internal.Progress | ||
17 | ( -- * Progress | ||
18 | Progress (..) | ||
19 | |||
20 | -- * Lens | ||
21 | , left | ||
22 | , uploaded | ||
23 | , downloaded | ||
24 | |||
25 | -- * Construction | ||
26 | , startProgress | ||
27 | , downloadedProgress | ||
28 | , enqueuedProgress | ||
29 | , uploadedProgress | ||
30 | , dequeuedProgress | ||
31 | |||
32 | -- * Query | ||
33 | , canDownload | ||
34 | , canUpload | ||
35 | ) where | ||
36 | |||
37 | import Control.Applicative | ||
38 | import Control.Lens hiding ((%=)) | ||
39 | import Data.ByteString.Lazy.Builder as BS | ||
40 | import Data.ByteString.Lazy.Builder.ASCII as BS | ||
41 | import Data.Default | ||
42 | import Data.Monoid | ||
43 | import Data.Serialize as S | ||
44 | import Data.Ratio | ||
45 | import Data.Word | ||
46 | import Network.HTTP.Types.QueryLike | ||
47 | import Text.PrettyPrint as PP | ||
48 | import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) | ||
49 | |||
50 | |||
51 | -- | Progress data is considered as dynamic within one client | ||
52 | -- session. This data also should be shared across client application | ||
53 | -- sessions (e.g. files), otherwise use 'startProgress' to get initial | ||
54 | -- 'Progress' value. | ||
55 | -- | ||
56 | data Progress = Progress | ||
57 | { _downloaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes downloaded; | ||
58 | , _left :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes left; | ||
59 | , _uploaded :: {-# UNPACK #-} !Word64 -- ^ Total amount of bytes uploaded. | ||
60 | } deriving (Show, Read, Eq) | ||
61 | |||
62 | $(makeLenses ''Progress) | ||
63 | |||
64 | -- | UDP tracker compatible encoding. | ||
65 | instance Serialize Progress where | ||
66 | put Progress {..} = do | ||
67 | putWord64be $ fromIntegral _downloaded | ||
68 | putWord64be $ fromIntegral _left | ||
69 | putWord64be $ fromIntegral _uploaded | ||
70 | |||
71 | get = Progress | ||
72 | <$> (fromIntegral <$> getWord64be) | ||
73 | <*> (fromIntegral <$> getWord64be) | ||
74 | <*> (fromIntegral <$> getWord64be) | ||
75 | |||
76 | instance Default Progress where | ||
77 | def = Progress 0 0 0 | ||
78 | {-# INLINE def #-} | ||
79 | |||
80 | -- | Can be used to aggregate total progress. | ||
81 | instance Monoid Progress where | ||
82 | mempty = def | ||
83 | {-# INLINE mempty #-} | ||
84 | |||
85 | mappend (Progress da la ua) (Progress db lb ub) = Progress | ||
86 | { _downloaded = da + db | ||
87 | , _left = la + lb | ||
88 | , _uploaded = ua + ub | ||
89 | } | ||
90 | {-# INLINE mappend #-} | ||
91 | |||
92 | instance QueryValueLike Builder where | ||
93 | toQueryValue = toQueryValue . BS.toLazyByteString | ||
94 | |||
95 | instance QueryValueLike Word64 where | ||
96 | toQueryValue = toQueryValue . BS.word64Dec | ||
97 | |||
98 | -- | HTTP Tracker protocol compatible encoding. | ||
99 | instance QueryLike Progress where | ||
100 | toQuery Progress {..} = | ||
101 | [ ("uploaded" , toQueryValue _uploaded) | ||
102 | , ("left" , toQueryValue _left) | ||
103 | , ("downloaded", toQueryValue _downloaded) | ||
104 | ] | ||
105 | |||
106 | instance Pretty Progress where | ||
107 | pPrint Progress {..} = | ||
108 | "/\\" <+> PP.text (show _uploaded) $$ | ||
109 | "\\/" <+> PP.text (show _downloaded) $$ | ||
110 | "left" <+> PP.text (show _left) | ||
111 | |||
112 | -- | Initial progress is used when there are no session before. | ||
113 | -- | ||
114 | -- Please note that tracker might penalize client some way if the do | ||
115 | -- not accumulate progress. If possible and save 'Progress' between | ||
116 | -- client sessions to avoid that. | ||
117 | -- | ||
118 | startProgress :: Integer -> Progress | ||
119 | startProgress = Progress 0 0 . fromIntegral | ||
120 | {-# INLINE startProgress #-} | ||
121 | |||
122 | -- | Used when the client download some data from /any/ peer. | ||
123 | downloadedProgress :: Int -> Progress -> Progress | ||
124 | downloadedProgress (fromIntegral -> amount) | ||
125 | = (left -~ amount) | ||
126 | . (downloaded +~ amount) | ||
127 | {-# INLINE downloadedProgress #-} | ||
128 | |||
129 | -- | Used when the client upload some data to /any/ peer. | ||
130 | uploadedProgress :: Int -> Progress -> Progress | ||
131 | uploadedProgress (fromIntegral -> amount) = uploaded +~ amount | ||
132 | {-# INLINE uploadedProgress #-} | ||
133 | |||
134 | -- | Used when leecher join client session. | ||
135 | enqueuedProgress :: Integer -> Progress -> Progress | ||
136 | enqueuedProgress amount = left +~ fromIntegral amount | ||
137 | {-# INLINE enqueuedProgress #-} | ||
138 | |||
139 | -- | Used when leecher leave client session. | ||
140 | -- (e.g. user deletes not completed torrent) | ||
141 | dequeuedProgress :: Integer -> Progress -> Progress | ||
142 | dequeuedProgress amount = left -~ fromIntegral amount | ||
143 | {-# INLINE dequeuedProgress #-} | ||
144 | |||
145 | ri2rw64 :: Ratio Int -> Ratio Word64 | ||
146 | ri2rw64 x = fromIntegral (numerator x) % fromIntegral (denominator x) | ||
147 | |||
148 | -- | Check global /download/ limit by uploaded \/ downloaded ratio. | ||
149 | canDownload :: Ratio Int -> Progress -> Bool | ||
150 | canDownload limit Progress {..} = _uploaded % _downloaded > ri2rw64 limit | ||
151 | |||
152 | -- | Check global /upload/ limit by downloaded \/ uploaded ratio. | ||
153 | canUpload :: Ratio Int -> Progress -> Bool | ||
154 | canUpload limit Progress {..} = _downloaded % _uploaded > ri2rw64 limit | ||