diff options
Diffstat (limited to 'src/Network/BitTorrent/Exchange')
-rw-r--r-- | src/Network/BitTorrent/Exchange/Protocol.hs | 65 | ||||
-rw-r--r-- | src/Network/BitTorrent/Exchange/Status.hs | 67 |
2 files changed, 68 insertions, 64 deletions
diff --git a/src/Network/BitTorrent/Exchange/Protocol.hs b/src/Network/BitTorrent/Exchange/Protocol.hs index 7af99335..037ef31f 100644 --- a/src/Network/BitTorrent/Exchange/Protocol.hs +++ b/src/Network/BitTorrent/Exchange/Protocol.hs | |||
@@ -43,25 +43,11 @@ module Network.BitTorrent.Exchange.Protocol | |||
43 | 43 | ||
44 | -- * Regular messages | 44 | -- * Regular messages |
45 | , Message(..) | 45 | , Message(..) |
46 | |||
47 | -- * control | ||
48 | , PeerStatus(..) | ||
49 | , choking, interested | ||
50 | |||
51 | , SessionStatus(..) | ||
52 | , inverseStatus | ||
53 | , clientStatus, peerStatus | ||
54 | , canUpload, canDownload | ||
55 | |||
56 | -- ** Defaults | ||
57 | , defaultUnchokeSlots | ||
58 | ) where | 46 | ) where |
59 | 47 | ||
60 | import Control.Applicative | 48 | import Control.Applicative |
61 | import Control.Exception | 49 | import Control.Exception |
62 | import Control.Monad | 50 | import Control.Monad |
63 | import Control.Lens | ||
64 | import Data.Aeson.TH | ||
65 | import Data.Binary as B | 51 | import Data.Binary as B |
66 | import Data.Binary.Get as B | 52 | import Data.Binary.Get as B |
67 | import Data.Binary.Put as B | 53 | import Data.Binary.Put as B |
@@ -69,9 +55,7 @@ import Data.ByteString as BS | |||
69 | import Data.ByteString.Char8 as BC | 55 | import Data.ByteString.Char8 as BC |
70 | import Data.ByteString.Lazy as BL | 56 | import Data.ByteString.Lazy as BL |
71 | import Data.Default | 57 | import Data.Default |
72 | import Data.List as L | ||
73 | import Data.Serialize as S | 58 | import Data.Serialize as S |
74 | import Data.Word | ||
75 | import Network | 59 | import Network |
76 | import Network.Socket.ByteString | 60 | import Network.Socket.ByteString |
77 | import Text.PrettyPrint | 61 | import Text.PrettyPrint |
@@ -80,10 +64,9 @@ import Text.PrettyPrint.Class | |||
80 | import Data.Torrent.Bitfield | 64 | import Data.Torrent.Bitfield |
81 | import Data.Torrent.Block | 65 | import Data.Torrent.Block |
82 | import Data.Torrent.InfoHash | 66 | import Data.Torrent.InfoHash |
83 | import Data.Torrent | ||
84 | import Network.BitTorrent.Extension | 67 | import Network.BitTorrent.Extension |
85 | import Network.BitTorrent.Core.PeerId | 68 | import Network.BitTorrent.Core.PeerId |
86 | import Network.BitTorrent.Core.PeerAddr | 69 | import Network.BitTorrent.Core.PeerAddr () |
87 | 70 | ||
88 | 71 | ||
89 | getInt :: S.Get Int | 72 | getInt :: S.Get Int |
@@ -398,49 +381,3 @@ instance Binary Message where | |||
398 | put (SuggestPiece pix) = putIntB 5 >> B.putWord8 0x0D >> putIntB pix | 381 | put (SuggestPiece pix) = putIntB 5 >> B.putWord8 0x0D >> putIntB pix |
399 | put (RejectRequest i ) = putIntB 13 >> B.putWord8 0x10 >> B.put i | 382 | put (RejectRequest i ) = putIntB 13 >> B.putWord8 0x10 >> B.put i |
400 | put (AllowedFast i ) = putIntB 5 >> B.putWord8 0x11 >> putIntB i | 383 | put (AllowedFast i ) = putIntB 5 >> B.putWord8 0x11 >> putIntB i |
401 | |||
402 | {----------------------------------------------------------------------- | ||
403 | Peer Status | ||
404 | -----------------------------------------------------------------------} | ||
405 | |||
406 | -- | | ||
407 | data PeerStatus = PeerStatus { | ||
408 | _choking :: !Bool | ||
409 | , _interested :: !Bool | ||
410 | } deriving (Show, Eq) | ||
411 | |||
412 | $(makeLenses ''PeerStatus) | ||
413 | $(deriveJSON (L.dropWhile (== '_')) ''PeerStatus) | ||
414 | |||
415 | instance Default PeerStatus where | ||
416 | def = PeerStatus True False | ||
417 | |||
418 | -- | | ||
419 | data SessionStatus = SessionStatus { | ||
420 | _clientStatus :: !PeerStatus | ||
421 | , _peerStatus :: !PeerStatus | ||
422 | } deriving (Show, Eq) | ||
423 | |||
424 | $(makeLenses ''SessionStatus) | ||
425 | $(deriveJSON (L.dropWhile (== '_')) ''SessionStatus) | ||
426 | |||
427 | instance Default SessionStatus where | ||
428 | def = SessionStatus def def | ||
429 | |||
430 | -- | Can the /client/ transfer to the /peer/? | ||
431 | canUpload :: SessionStatus -> Bool | ||
432 | canUpload SessionStatus {..} | ||
433 | = _interested _peerStatus && not (_choking _clientStatus) | ||
434 | |||
435 | -- | Can the /client/ transfer from the /peer/? | ||
436 | canDownload :: SessionStatus -> Bool | ||
437 | canDownload SessionStatus {..} | ||
438 | = _interested _clientStatus && not (_choking _peerStatus) | ||
439 | |||
440 | inverseStatus :: SessionStatus -> SessionStatus | ||
441 | inverseStatus SessionStatus {..} = SessionStatus _peerStatus _clientStatus | ||
442 | |||
443 | -- | Indicates how many peers are allowed to download from the client | ||
444 | -- by default. | ||
445 | defaultUnchokeSlots :: Int | ||
446 | defaultUnchokeSlots = 4 \ No newline at end of file | ||
diff --git a/src/Network/BitTorrent/Exchange/Status.hs b/src/Network/BitTorrent/Exchange/Status.hs new file mode 100644 index 00000000..683ac594 --- /dev/null +++ b/src/Network/BitTorrent/Exchange/Status.hs | |||
@@ -0,0 +1,67 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | ||
2 | module Network.BitTorrent.Exchange.Status | ||
3 | ( -- * Peer status | ||
4 | PeerStatus(..) | ||
5 | , choking | ||
6 | , interested | ||
7 | |||
8 | -- * Session status | ||
9 | , SessionStatus(..) | ||
10 | , clientStatus | ||
11 | , peerStatus | ||
12 | |||
13 | -- ** Query | ||
14 | , canUpload | ||
15 | , canDownload | ||
16 | |||
17 | -- * Extra | ||
18 | , inverseStatus | ||
19 | , defaultUnchokeSlots | ||
20 | ) where | ||
21 | |||
22 | import Control.Lens | ||
23 | import Data.Aeson.TH | ||
24 | import Data.List as L | ||
25 | import Data.Default | ||
26 | |||
27 | -- | | ||
28 | data PeerStatus = PeerStatus { | ||
29 | _choking :: !Bool | ||
30 | , _interested :: !Bool | ||
31 | } deriving (Show, Eq) | ||
32 | |||
33 | $(makeLenses ''PeerStatus) | ||
34 | $(deriveJSON L.tail ''PeerStatus) | ||
35 | |||
36 | instance Default PeerStatus where | ||
37 | def = PeerStatus True False | ||
38 | |||
39 | -- | | ||
40 | data SessionStatus = SessionStatus { | ||
41 | _clientStatus :: !PeerStatus | ||
42 | , _peerStatus :: !PeerStatus | ||
43 | } deriving (Show, Eq) | ||
44 | |||
45 | $(makeLenses ''SessionStatus) | ||
46 | $(deriveJSON L.tail ''SessionStatus) | ||
47 | |||
48 | instance Default SessionStatus where | ||
49 | def = SessionStatus def def | ||
50 | |||
51 | -- | Can the /client/ transfer to the /peer/? | ||
52 | canUpload :: SessionStatus -> Bool | ||
53 | canUpload SessionStatus {..} | ||
54 | = _interested _peerStatus && not (_choking _clientStatus) | ||
55 | |||
56 | -- | Can the /client/ transfer from the /peer/? | ||
57 | canDownload :: SessionStatus -> Bool | ||
58 | canDownload SessionStatus {..} | ||
59 | = _interested _clientStatus && not (_choking _peerStatus) | ||
60 | |||
61 | inverseStatus :: SessionStatus -> SessionStatus | ||
62 | inverseStatus SessionStatus {..} = SessionStatus _peerStatus _clientStatus | ||
63 | |||
64 | -- | Indicates how many peers are allowed to download from the client | ||
65 | -- by default. | ||
66 | defaultUnchokeSlots :: Int | ||
67 | defaultUnchokeSlots = 4 \ No newline at end of file | ||