summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
authorSam T <pxqr.sta@gmail.com>2013-06-08 02:21:51 +0400
committerSam T <pxqr.sta@gmail.com>2013-06-08 02:21:51 +0400
commit55f7a4944ed4642d988c2634807ca2c4d74cd369 (patch)
treed2121bcde046e224fbeff745b0c0bfae0f0cc1fa /src/Network
parent2b617c99c60a5ed93eb2e9138f258663ab2603bd (diff)
~ Merge Status into Protocol.
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/BitTorrent/Exchange/Protocol.hs66
-rw-r--r--src/Network/BitTorrent/Exchange/Status.hs65
2 files changed, 65 insertions, 66 deletions
diff --git a/src/Network/BitTorrent/Exchange/Protocol.hs b/src/Network/BitTorrent/Exchange/Protocol.hs
index 8cfcc79d..505f6ac6 100644
--- a/src/Network/BitTorrent/Exchange/Protocol.hs
+++ b/src/Network/BitTorrent/Exchange/Protocol.hs
@@ -34,6 +34,21 @@ module Network.BitTorrent.Exchange.Protocol
34 -- * Regular messages 34 -- * Regular messages
35 , Message(..) 35 , Message(..)
36 , ppMessage 36 , ppMessage
37
38 -- * Exchange control
39 -- ** Peer status
40 , PeerStatus(..)
41 , setChoking, setInterested
42 , initPeerStatus
43
44 -- ** Session status
45 , SessionStatus(..)
46 , initSessionStatus
47 , setClientStatus, setPeerStatus
48 , canUpload, canDownload
49
50 -- ** Defaults
51 , defaultUnchokeSlots
37 ) where 52 ) where
38 53
39import Control.Applicative 54import Control.Applicative
@@ -384,4 +399,53 @@ ppMessage (Piece blk) = "Piece" <+> ppBlock blk
384ppMessage (Cancel ix) = "Cancel" <+> ppBlockIx ix 399ppMessage (Cancel ix) = "Cancel" <+> ppBlockIx ix
385ppMessage (SuggestPiece pix) = "Suggest" <+> int pix 400ppMessage (SuggestPiece pix) = "Suggest" <+> int pix
386ppMessage (RejectRequest ix) = "Reject" <+> ppBlockIx ix 401ppMessage (RejectRequest ix) = "Reject" <+> ppBlockIx ix
387ppMessage msg = text (show msg) \ No newline at end of file 402ppMessage msg = text (show msg)
403
404{-----------------------------------------------------------------------
405 Peer Status
406-----------------------------------------------------------------------}
407
408data PeerStatus = PeerStatus {
409 psChoking :: Bool
410 , psInterested :: Bool
411 }
412
413-- | Any session between peers starts as choking and not interested.
414initPeerStatus :: PeerStatus
415initPeerStatus = PeerStatus True False
416
417setChoking :: Bool -> PeerStatus -> PeerStatus
418setChoking b ps = ps { psChoking = b }
419
420setInterested :: Bool -> PeerStatus -> PeerStatus
421setInterested b ps = ps { psInterested = b }
422
423
424
425data SessionStatus = SessionStatus {
426 seClientStatus :: PeerStatus
427 , sePeerStatus :: PeerStatus
428 }
429
430initSessionStatus :: SessionStatus
431initSessionStatus = SessionStatus initPeerStatus initPeerStatus
432
433setClientStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus
434setClientStatus f ss = ss { seClientStatus = f (seClientStatus ss) }
435
436setPeerStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus
437setPeerStatus f ss = ss { sePeerStatus = f (sePeerStatus ss) }
438
439-- | Can the /client/ to upload to the /peer/?
440canUpload :: SessionStatus -> Bool
441canUpload SessionStatus { seClientStatus = client, sePeerStatus = peer} =
442 psInterested peer && not (psChoking client)
443
444-- | Can the /client/ download from the /peer/?
445canDownload :: SessionStatus -> Bool
446canDownload SessionStatus { seClientStatus = client, sePeerStatus = peer } =
447 psInterested client && not (psChoking peer)
448
449-- | Indicates have many peers are allowed to download from the client.
450defaultUnchokeSlots :: Int
451defaultUnchokeSlots = 4 \ No newline at end of file
diff --git a/src/Network/BitTorrent/Exchange/Status.hs b/src/Network/BitTorrent/Exchange/Status.hs
deleted file mode 100644
index 353ef14d..00000000
--- a/src/Network/BitTorrent/Exchange/Status.hs
+++ /dev/null
@@ -1,65 +0,0 @@
1-- |
2-- Copyright : (c) Sam T. 2013
3-- License : MIT
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8module Network.BitTorrent.Exchange.Status
9 ( PeerStatus(..)
10 , setChoking, setInterested
11 , initPeerStatus
12
13 , SessionStatus(..)
14 , initSessionStatus
15 , setClientStatus, setPeerStatus
16 , canUpload, canDownload
17
18 -- * Defaults
19 , defaultUnchokeSlots
20 ) where
21
22data PeerStatus = PeerStatus {
23 psChoking :: Bool
24 , psInterested :: Bool
25 }
26
27-- | Any session between peers starts as choking and not interested.
28initPeerStatus :: PeerStatus
29initPeerStatus = PeerStatus True False
30
31setChoking :: Bool -> PeerStatus -> PeerStatus
32setChoking b ps = ps { psChoking = b }
33
34setInterested :: Bool -> PeerStatus -> PeerStatus
35setInterested b ps = ps { psInterested = b }
36
37
38
39data SessionStatus = SessionStatus {
40 seClientStatus :: PeerStatus
41 , sePeerStatus :: PeerStatus
42 }
43
44initSessionStatus :: SessionStatus
45initSessionStatus = SessionStatus initPeerStatus initPeerStatus
46
47setClientStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus
48setClientStatus f ss = ss { seClientStatus = f (seClientStatus ss) }
49
50setPeerStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus
51setPeerStatus f ss = ss { sePeerStatus = f (sePeerStatus ss) }
52
53-- | Can the /client/ to upload to the /peer/?
54canUpload :: SessionStatus -> Bool
55canUpload SessionStatus { seClientStatus = client, sePeerStatus = peer} =
56 psInterested peer && not (psChoking client)
57
58-- | Can the /client/ download from the /peer/?
59canDownload :: SessionStatus -> Bool
60canDownload SessionStatus { seClientStatus = client, sePeerStatus = peer } =
61 psInterested client && not (psChoking peer)
62
63-- | Indicates have many peers are allowed to download from the client.
64defaultUnchokeSlots :: Int
65defaultUnchokeSlots = 4 \ No newline at end of file