diff options
-rw-r--r-- | bench/serialization.hs | 3 | ||||
-rw-r--r-- | network-bittorrent.cabal | 3 | ||||
-rw-r--r-- | src/Network/BitTorrent/PeerWire.hs | 1 | ||||
-rw-r--r-- | src/Network/BitTorrent/PeerWire/Bitfield.hs | 39 | ||||
-rw-r--r-- | src/Network/BitTorrent/PeerWire/Message.hs | 10 | ||||
-rw-r--r-- | tests/encoding.hs | 4 |
6 files changed, 55 insertions, 5 deletions
diff --git a/bench/serialization.hs b/bench/serialization.hs index 8ed90958..c6d14328 100644 --- a/bench/serialization.hs +++ b/bench/serialization.hs | |||
@@ -15,6 +15,9 @@ instance NFData BlockIx where | |||
15 | instance NFData Block where | 15 | instance NFData Block where |
16 | rnf (Block a b c) = a `deepseq` b `deepseq` rnf c | 16 | rnf (Block a b c) = a `deepseq` b `deepseq` rnf c |
17 | 17 | ||
18 | instance NFData Bitfield where | ||
19 | rnf = rnf . bfBits | ||
20 | |||
18 | instance NFData Message where | 21 | instance NFData Message where |
19 | rnf (Have i) = rnf i | 22 | rnf (Have i) = rnf i |
20 | rnf (Bitfield b) = rnf b | 23 | rnf (Bitfield b) = rnf b |
diff --git a/network-bittorrent.cabal b/network-bittorrent.cabal index a26068f6..00ed2162 100644 --- a/network-bittorrent.cabal +++ b/network-bittorrent.cabal | |||
@@ -32,8 +32,9 @@ library | |||
32 | , Network.BitTorrent.Tracker.Scrape | 32 | , Network.BitTorrent.Tracker.Scrape |
33 | 33 | ||
34 | , Network.BitTorrent.PeerWire | 34 | , Network.BitTorrent.PeerWire |
35 | , Network.BitTorrent.PeerWire.ClientInfo | 35 | , Network.BitTorrent.PeerWire.Bitfield |
36 | , Network.BitTorrent.PeerWire.Block | 36 | , Network.BitTorrent.PeerWire.Block |
37 | , Network.BitTorrent.PeerWire.ClientInfo | ||
37 | , Network.BitTorrent.PeerWire.Message | 38 | , Network.BitTorrent.PeerWire.Message |
38 | , Network.BitTorrent.PeerWire.Handshake | 39 | , Network.BitTorrent.PeerWire.Handshake |
39 | 40 | ||
diff --git a/src/Network/BitTorrent/PeerWire.hs b/src/Network/BitTorrent/PeerWire.hs index fde98695..9f1e02ca 100644 --- a/src/Network/BitTorrent/PeerWire.hs +++ b/src/Network/BitTorrent/PeerWire.hs | |||
@@ -8,6 +8,7 @@ | |||
8 | {-# LANGUAGE DoAndIfThenElse #-} | 8 | {-# LANGUAGE DoAndIfThenElse #-} |
9 | module Network.BitTorrent.PeerWire (module PW) where | 9 | module Network.BitTorrent.PeerWire (module PW) where |
10 | 10 | ||
11 | import Network.BitTorrent.PeerWire.Bitfield as PW | ||
11 | import Network.BitTorrent.PeerWire.Block as PW | 12 | import Network.BitTorrent.PeerWire.Block as PW |
12 | import Network.BitTorrent.PeerWire.Message as PW | 13 | import Network.BitTorrent.PeerWire.Message as PW |
13 | import Network.BitTorrent.PeerWire.Handshake as PW | 14 | import Network.BitTorrent.PeerWire.Handshake as PW |
diff --git a/src/Network/BitTorrent/PeerWire/Bitfield.hs b/src/Network/BitTorrent/PeerWire/Bitfield.hs new file mode 100644 index 00000000..c9357a25 --- /dev/null +++ b/src/Network/BitTorrent/PeerWire/Bitfield.hs | |||
@@ -0,0 +1,39 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam T. 2013 | ||
3 | -- License : MIT | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- | ||
9 | -- This module provides Bitfield datatype used to represent sets of | ||
10 | -- piece indexes any peer have. All associated operations should be | ||
11 | -- defined here as well. | ||
12 | -- | ||
13 | module Network.BitTorrent.PeerWire.Bitfield | ||
14 | ( Bitfield(..) | ||
15 | , getBitfield, putBitfield, bitfieldByteCount | ||
16 | ) where | ||
17 | |||
18 | import Control.Applicative | ||
19 | import Data.ByteString (ByteString) | ||
20 | import qualified Data.ByteString as B | ||
21 | |||
22 | import Data.Serialize | ||
23 | |||
24 | |||
25 | newtype Bitfield = MkBitfield { | ||
26 | bfBits :: ByteString | ||
27 | } deriving (Show, Eq, Ord) | ||
28 | |||
29 | bitfieldByteCount :: Bitfield -> Int | ||
30 | bitfieldByteCount = B.length . bfBits | ||
31 | {-# INLINE bitfieldByteCount #-} | ||
32 | |||
33 | getBitfield :: Int -> Get Bitfield | ||
34 | getBitfield n = MkBitfield <$> getBytes n | ||
35 | {-# INLINE getBitfield #-} | ||
36 | |||
37 | putBitfield :: Bitfield -> Put | ||
38 | putBitfield = putByteString . bfBits | ||
39 | {-# INLINE putBitfield #-} \ No newline at end of file | ||
diff --git a/src/Network/BitTorrent/PeerWire/Message.hs b/src/Network/BitTorrent/PeerWire/Message.hs index 3f6647dd..9cbc2e38 100644 --- a/src/Network/BitTorrent/PeerWire/Message.hs +++ b/src/Network/BitTorrent/PeerWire/Message.hs | |||
@@ -1,5 +1,6 @@ | |||
1 | module Network.BitTorrent.PeerWire.Message | 1 | module Network.BitTorrent.PeerWire.Message |
2 | ( Message(..) | 2 | ( Message(..) |
3 | , Bitfield | ||
3 | , ppMessage | 4 | , ppMessage |
4 | ) where | 5 | ) where |
5 | 6 | ||
@@ -10,6 +11,7 @@ import qualified Data.ByteString as B | |||
10 | import Data.Serialize | 11 | import Data.Serialize |
11 | 12 | ||
12 | import Network.BitTorrent.PeerWire.Block | 13 | import Network.BitTorrent.PeerWire.Block |
14 | import Network.BitTorrent.PeerWire.Bitfield | ||
13 | 15 | ||
14 | 16 | ||
15 | -- | Messages used in communication between peers. | 17 | -- | Messages used in communication between peers. |
@@ -32,7 +34,7 @@ data Message = KeepAlive | |||
32 | -- after the handshaking sequence is complete, and | 34 | -- after the handshaking sequence is complete, and |
33 | -- before any other message are sent. If client have no | 35 | -- before any other message are sent. If client have no |
34 | -- pieces then bitfield need not to be sent. | 36 | -- pieces then bitfield need not to be sent. |
35 | | Bitfield ByteString | 37 | | Bitfield Bitfield |
36 | 38 | ||
37 | -- | Request for a particular block. If a client is | 39 | -- | Request for a particular block. If a client is |
38 | -- requested a block that another peer do not have the | 40 | -- requested a block that another peer do not have the |
@@ -87,7 +89,7 @@ instance Serialize Message where | |||
87 | 0x02 -> return Interested | 89 | 0x02 -> return Interested |
88 | 0x03 -> return NotInterested | 90 | 0x03 -> return NotInterested |
89 | 0x04 -> Have <$> getInt | 91 | 0x04 -> Have <$> getInt |
90 | 0x05 -> Bitfield <$> getBytes (pred len) | 92 | 0x05 -> Bitfield <$> getBitfield (pred len) |
91 | 0x06 -> Request <$> get | 93 | 0x06 -> Request <$> get |
92 | 0x07 -> Piece <$> getBlock (len - 9) | 94 | 0x07 -> Piece <$> getBlock (len - 9) |
93 | 0x08 -> Cancel <$> get | 95 | 0x08 -> Cancel <$> get |
@@ -111,8 +113,8 @@ instance Serialize Message where | |||
111 | put Interested = putInt 1 >> putWord8 0x02 | 113 | put Interested = putInt 1 >> putWord8 0x02 |
112 | put NotInterested = putInt 1 >> putWord8 0x03 | 114 | put NotInterested = putInt 1 >> putWord8 0x03 |
113 | put (Have i) = putInt 5 >> putWord8 0x04 >> putInt i | 115 | put (Have i) = putInt 5 >> putWord8 0x04 >> putInt i |
114 | put (Bitfield b) = putInt l >> putWord8 0x05 >> putByteString b | 116 | put (Bitfield b) = putInt l >> putWord8 0x05 >> putBitfield b |
115 | where l = succ (B.length b) | 117 | where l = succ (bitfieldByteCount b) |
116 | {-# INLINE l #-} | 118 | {-# INLINE l #-} |
117 | put (Request blk) = putInt 13 >> putWord8 0x06 >> put blk | 119 | put (Request blk) = putInt 13 >> putWord8 0x06 >> put blk |
118 | put (Piece blk) = putInt l >> putWord8 0x07 >> putBlock | 120 | put (Piece blk) = putInt l >> putWord8 0x07 >> putBlock |
diff --git a/tests/encoding.hs b/tests/encoding.hs index a8490551..405d2eb1 100644 --- a/tests/encoding.hs +++ b/tests/encoding.hs | |||
@@ -1,3 +1,5 @@ | |||
1 | {-# LANGUAGE StandaloneDeriving #-} | ||
2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
1 | {-# OPTIONS -fno-warn-orphans #-} | 3 | {-# OPTIONS -fno-warn-orphans #-} |
2 | module Main (main) where | 4 | module Main (main) where |
3 | 5 | ||
@@ -29,6 +31,8 @@ instance Arbitrary BlockIx where | |||
29 | instance Arbitrary Block where | 31 | instance Arbitrary Block where |
30 | arbitrary = Block <$> positive <*> positive <*> arbitrary | 32 | arbitrary = Block <$> positive <*> positive <*> arbitrary |
31 | 33 | ||
34 | deriving instance Arbitrary Bitfield | ||
35 | |||
32 | instance Arbitrary Message where | 36 | instance Arbitrary Message where |
33 | arbitrary = oneof | 37 | arbitrary = oneof |
34 | [ pure KeepAlive | 38 | [ pure KeepAlive |