diff options
Diffstat (limited to 'src/Network')
-rw-r--r-- | src/Network/BitTorrent/Exchange/Protocol.hs | 66 | ||||
-rw-r--r-- | src/Network/BitTorrent/Exchange/Status.hs | 65 |
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 | ||
39 | import Control.Applicative | 54 | import Control.Applicative |
@@ -384,4 +399,53 @@ ppMessage (Piece blk) = "Piece" <+> ppBlock blk | |||
384 | ppMessage (Cancel ix) = "Cancel" <+> ppBlockIx ix | 399 | ppMessage (Cancel ix) = "Cancel" <+> ppBlockIx ix |
385 | ppMessage (SuggestPiece pix) = "Suggest" <+> int pix | 400 | ppMessage (SuggestPiece pix) = "Suggest" <+> int pix |
386 | ppMessage (RejectRequest ix) = "Reject" <+> ppBlockIx ix | 401 | ppMessage (RejectRequest ix) = "Reject" <+> ppBlockIx ix |
387 | ppMessage msg = text (show msg) \ No newline at end of file | 402 | ppMessage msg = text (show msg) |
403 | |||
404 | {----------------------------------------------------------------------- | ||
405 | Peer Status | ||
406 | -----------------------------------------------------------------------} | ||
407 | |||
408 | data PeerStatus = PeerStatus { | ||
409 | psChoking :: Bool | ||
410 | , psInterested :: Bool | ||
411 | } | ||
412 | |||
413 | -- | Any session between peers starts as choking and not interested. | ||
414 | initPeerStatus :: PeerStatus | ||
415 | initPeerStatus = PeerStatus True False | ||
416 | |||
417 | setChoking :: Bool -> PeerStatus -> PeerStatus | ||
418 | setChoking b ps = ps { psChoking = b } | ||
419 | |||
420 | setInterested :: Bool -> PeerStatus -> PeerStatus | ||
421 | setInterested b ps = ps { psInterested = b } | ||
422 | |||
423 | |||
424 | |||
425 | data SessionStatus = SessionStatus { | ||
426 | seClientStatus :: PeerStatus | ||
427 | , sePeerStatus :: PeerStatus | ||
428 | } | ||
429 | |||
430 | initSessionStatus :: SessionStatus | ||
431 | initSessionStatus = SessionStatus initPeerStatus initPeerStatus | ||
432 | |||
433 | setClientStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus | ||
434 | setClientStatus f ss = ss { seClientStatus = f (seClientStatus ss) } | ||
435 | |||
436 | setPeerStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus | ||
437 | setPeerStatus f ss = ss { sePeerStatus = f (sePeerStatus ss) } | ||
438 | |||
439 | -- | Can the /client/ to upload to the /peer/? | ||
440 | canUpload :: SessionStatus -> Bool | ||
441 | canUpload SessionStatus { seClientStatus = client, sePeerStatus = peer} = | ||
442 | psInterested peer && not (psChoking client) | ||
443 | |||
444 | -- | Can the /client/ download from the /peer/? | ||
445 | canDownload :: SessionStatus -> Bool | ||
446 | canDownload SessionStatus { seClientStatus = client, sePeerStatus = peer } = | ||
447 | psInterested client && not (psChoking peer) | ||
448 | |||
449 | -- | Indicates have many peers are allowed to download from the client. | ||
450 | defaultUnchokeSlots :: Int | ||
451 | defaultUnchokeSlots = 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 | -- | ||
8 | module 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 | |||
22 | data PeerStatus = PeerStatus { | ||
23 | psChoking :: Bool | ||
24 | , psInterested :: Bool | ||
25 | } | ||
26 | |||
27 | -- | Any session between peers starts as choking and not interested. | ||
28 | initPeerStatus :: PeerStatus | ||
29 | initPeerStatus = PeerStatus True False | ||
30 | |||
31 | setChoking :: Bool -> PeerStatus -> PeerStatus | ||
32 | setChoking b ps = ps { psChoking = b } | ||
33 | |||
34 | setInterested :: Bool -> PeerStatus -> PeerStatus | ||
35 | setInterested b ps = ps { psInterested = b } | ||
36 | |||
37 | |||
38 | |||
39 | data SessionStatus = SessionStatus { | ||
40 | seClientStatus :: PeerStatus | ||
41 | , sePeerStatus :: PeerStatus | ||
42 | } | ||
43 | |||
44 | initSessionStatus :: SessionStatus | ||
45 | initSessionStatus = SessionStatus initPeerStatus initPeerStatus | ||
46 | |||
47 | setClientStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus | ||
48 | setClientStatus f ss = ss { seClientStatus = f (seClientStatus ss) } | ||
49 | |||
50 | setPeerStatus :: (PeerStatus -> PeerStatus) -> SessionStatus -> SessionStatus | ||
51 | setPeerStatus f ss = ss { sePeerStatus = f (sePeerStatus ss) } | ||
52 | |||
53 | -- | Can the /client/ to upload to the /peer/? | ||
54 | canUpload :: SessionStatus -> Bool | ||
55 | canUpload SessionStatus { seClientStatus = client, sePeerStatus = peer} = | ||
56 | psInterested peer && not (psChoking client) | ||
57 | |||
58 | -- | Can the /client/ download from the /peer/? | ||
59 | canDownload :: SessionStatus -> Bool | ||
60 | canDownload SessionStatus { seClientStatus = client, sePeerStatus = peer } = | ||
61 | psInterested client && not (psChoking peer) | ||
62 | |||
63 | -- | Indicates have many peers are allowed to download from the client. | ||
64 | defaultUnchokeSlots :: Int | ||
65 | defaultUnchokeSlots = 4 \ No newline at end of file | ||