From 757ce3b4fa3de2d6e84307f79184a44b48ec0a29 Mon Sep 17 00:00:00 2001 From: Sam T Date: Fri, 7 Jun 2013 23:42:34 +0400 Subject: ~ Rename Message to Protocol. --- src/Network/BitTorrent/PeerWire/Protocol.hs | 155 ++++++++++++++++++++++++++++ 1 file changed, 155 insertions(+) create mode 100644 src/Network/BitTorrent/PeerWire/Protocol.hs (limited to 'src/Network/BitTorrent/PeerWire/Protocol.hs') diff --git a/src/Network/BitTorrent/PeerWire/Protocol.hs b/src/Network/BitTorrent/PeerWire/Protocol.hs new file mode 100644 index 00000000..a4d987e6 --- /dev/null +++ b/src/Network/BitTorrent/PeerWire/Protocol.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.BitTorrent.PeerWire.Protocol + ( + -- * Messages + Message(..) + , ppMessage + ) where + +import Control.Applicative +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lazy +import Data.Serialize +import Text.PrettyPrint +import Network + +import Network.BitTorrent.PeerWire.Block +import Data.Bitfield + + + +-- | Messages used in communication between peers. +-- +-- Note: If some extensions are disabled (not present in extension +-- mask) and client receive message used by the disabled +-- extension then the client MUST close the connection. +-- +data Message = KeepAlive + | Choke + | Unchoke + | Interested + | NotInterested + + -- | Zero-based index of a piece that has just been + -- successfully downloaded and verified via the hash. + | Have !PieceIx + + -- | The bitfield message may only be sent immediately + -- after the handshaking sequence is complete, and + -- before any other message are sent. If client have no + -- pieces then bitfield need not to be sent. + | Bitfield !Bitfield + + -- | Request for a particular block. If a client is + -- requested a block that another peer do not have the + -- peer might not answer at all. + | Request !BlockIx + + -- | Response for a request for a block. + | Piece !Block + + -- | Used to cancel block requests. It is typically + -- used during "End Game". + | Cancel !BlockIx + + | Port !PortNumber + + -- | BEP 6: Then peer have all pieces it might send the + -- 'HaveAll' message instead of 'Bitfield' + -- message. Used to save bandwidth. + | HaveAll + + -- | BEP 6: Then peer have no pieces it might send + -- 'HaveNone' message intead of 'Bitfield' + -- message. Used to save bandwidth. + | HaveNone + + -- | BEP 6: This is an advisory message meaning "you + -- might like to download this piece." Used to avoid + -- excessive disk seeks and amount of IO. + | SuggestPiece !PieceIx + + -- | BEP 6: Notifies a requesting peer that its request + -- will not be satisfied. + | RejectRequest !BlockIx + + -- | BEP 6: This is an advisory messsage meaning "if + -- you ask for this piece, I'll give it to you even if + -- you're choked." Used to shorten starting phase. + | AllowedFast !PieceIx + deriving (Show, Eq) + + +instance Serialize Message where + get = do + len <- getInt +-- _ <- lookAhead $ ensure len + if len == 0 then return KeepAlive + else do + mid <- getWord8 + case mid of + 0x00 -> return Choke + 0x01 -> return Unchoke + 0x02 -> return Interested + 0x03 -> return NotInterested + 0x04 -> Have <$> getInt + 0x05 -> (Bitfield . fromBitmap) <$> getByteString (pred len) + 0x06 -> Request <$> get + 0x07 -> Piece <$> getBlock (len - 9) + 0x08 -> Cancel <$> get + 0x09 -> (Port . fromIntegral) <$> getWord16be + 0x0E -> return HaveAll + 0x0F -> return HaveNone + 0x0D -> SuggestPiece <$> getInt + 0x10 -> RejectRequest <$> get + 0x11 -> AllowedFast <$> getInt + _ -> do + rm <- remaining >>= getBytes + fail $ "unknown message ID: " ++ show mid ++ "\n" + ++ "remaining available bytes: " ++ show rm + + where + getBlock :: Int -> Get Block + getBlock len = Block <$> getInt <*> getInt <*> getBytes len + {-# INLINE getBlock #-} + + + put KeepAlive = putInt 0 + put Choke = putInt 1 >> putWord8 0x00 + put Unchoke = putInt 1 >> putWord8 0x01 + put Interested = putInt 1 >> putWord8 0x02 + put NotInterested = putInt 1 >> putWord8 0x03 + put (Have i) = putInt 5 >> putWord8 0x04 >> putInt i + put (Bitfield bf) = putInt l >> putWord8 0x05 >> putLazyByteString b + where b = toBitmap bf + l = succ (fromIntegral (Lazy.length b)) + {-# INLINE l #-} + put (Request blk) = putInt 13 >> putWord8 0x06 >> put blk + put (Piece blk) = putInt l >> putWord8 0x07 >> putBlock + where l = 9 + B.length (blkData blk) + {-# INLINE l #-} + putBlock = do putInt (blkPiece blk) + putInt (blkOffset blk) + putByteString (blkData blk) + {-# INLINE putBlock #-} + + put (Cancel blk) = putInt 13 >> putWord8 0x08 >> put blk + put (Port p ) = putInt 3 >> putWord8 0x09 >> putWord16be (fromIntegral p) + put HaveAll = putInt 1 >> putWord8 0x0E + put HaveNone = putInt 1 >> putWord8 0x0F + put (SuggestPiece pix) = putInt 5 >> putWord8 0x0D >> putInt pix + put (RejectRequest ix) = putInt 13 >> putWord8 0x10 >> put ix + put (AllowedFast ix) = putInt 5 >> putWord8 0x11 >> putInt ix + + +-- | Format messages in human readable form. Note that output is +-- compact and suitable for logging: only useful information but not +-- payload bytes. +-- +ppMessage :: Message -> Doc +ppMessage (Bitfield _) = "Bitfield" +ppMessage (Piece blk) = "Piece" <+> ppBlock blk +ppMessage (Cancel ix) = "Cancel" <+> ppBlockIx ix +ppMessage (SuggestPiece pix) = "Suggest" <+> int pix +ppMessage (RejectRequest ix) = "Reject" <+> ppBlockIx ix +ppMessage msg = text (show msg) \ No newline at end of file -- cgit v1.2.3