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
|
-- |
-- Copyright : (c) Sam Truzjan 2013
-- License : BSD3
-- Maintainer : pxqr.sta@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- Each P2P connection endpoint should keep track status of both
-- sides.
--
{-# LANGUAGE TemplateHaskell #-}
module Network.BitTorrent.Exchange.Status
( -- * Peer status
PeerStatus(..)
, choking
, interested
-- ** Query
, updateStatus
, statusUpdates
-- * Session status
, SessionStatus(..)
, clientStatus
, remoteStatus
-- ** Query
, canUpload
, canDownload
-- * Extra
, defaultUnchokeSlots
, defaultRechokeInterval
) where
import Control.Lens
import Data.Aeson.TH
import Data.Default
import Data.Maybe
import Data.Monoid
import Text.PrettyPrint as PP hiding ((<>))
import Text.PrettyPrint.Class
import Data.Torrent.JSON
import Network.BitTorrent.Exchange.Message
{-----------------------------------------------------------------------
-- Peer status
-----------------------------------------------------------------------}
-- | Connections contain two bits of state on either end: choked or
-- not, and interested or not.
data PeerStatus = PeerStatus
{ -- | Choking is a notification that no data will be sent until
-- unchoking happens.
_choking :: !Bool
-- |
, _interested :: !Bool
} deriving (Show, Eq, Ord)
$(makeLenses ''PeerStatus)
$(deriveJSON omitLensPrefix ''PeerStatus)
instance Pretty PeerStatus where
pretty PeerStatus {..} =
pretty (Choking _choking) <+> "and" <+> pretty (Interested _interested)
-- | Connections start out choked and not interested.
instance Default PeerStatus where
def = PeerStatus True False
instance Monoid PeerStatus where
mempty = def
mappend a b = PeerStatus
{ _choking = _choking a && _choking b
, _interested = _interested a || _interested b
}
-- | Can be used to update remote peer status using incoming 'Status'
-- message.
updateStatus :: StatusUpdate -> PeerStatus -> PeerStatus
updateStatus (Choking b) = choking .~ b
updateStatus (Interested b) = interested .~ b
-- | Can be used to generate outcoming messages.
statusUpdates :: PeerStatus -> PeerStatus -> [StatusUpdate]
statusUpdates a b = catMaybes $
[ if _choking a == _choking b then Nothing
else Just $ Choking $ _choking b
, if _interested a == _interested b then Nothing
else Just $ Interested $ _interested b
]
{-----------------------------------------------------------------------
-- Session status
-----------------------------------------------------------------------}
-- | Status of the both endpoints.
data SessionStatus = SessionStatus
{ _clientStatus :: !PeerStatus
, _remoteStatus :: !PeerStatus
} deriving (Show, Eq)
$(makeLenses ''SessionStatus)
$(deriveJSON omitRecordPrefix ''SessionStatus)
instance Pretty SessionStatus where
pretty SessionStatus {..} =
"this " <+> pretty _clientStatus $$
"remote" <+> pretty _remoteStatus
-- | Connections start out choked and not interested.
instance Default SessionStatus where
def = SessionStatus def def
-- | Can the client transfer to the remote peer?
canUpload :: SessionStatus -> Bool
canUpload SessionStatus {..}
= _interested _remoteStatus && not (_choking _clientStatus)
-- | Can the client transfer from the remote peer?
canDownload :: SessionStatus -> Bool
canDownload SessionStatus {..}
= _interested _clientStatus && not (_choking _remoteStatus)
-- | Indicates how many peers are allowed to download from the client
-- by default.
defaultUnchokeSlots :: Int
defaultUnchokeSlots = 4
-- |
defaultRechokeInterval :: Int
defaultRechokeInterval = 10 * 1000 * 1000
|
