+++ /dev/null
-{-
- - Copyright (C) 2015-2016 Ramakrishnan Muthukrishnan <ram@rkrishnan.org>
- -
- - This file is part of FuncTorrent.
- -
- - FuncTorrent is free software; you can redistribute it and/or modify
- - it under the terms of the GNU General Public License as published by
- - the Free Software Foundation; either version 3 of the License, or
- - (at your option) any later version.
- -
- - FuncTorrent is distributed in the hope that it will be useful,
- - but WITHOUT ANY WARRANTY; without even the implied warranty of
- - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- - GNU General Public License for more details.
- -
- - You should have received a copy of the GNU General Public License
- - along with FuncTorrent; if not, see <http://www.gnu.org/licenses/>
- -}
-
-{-# LANGUAGE OverloadedStrings #-}
-
-module FuncTorrent.PeerMsgs
- (genHandshakeMsg,
- sendMsg,
- getMsg,
- Peer(..),
- makePeer,
- PeerMsg(..)
- ) where
-
-import Prelude hiding (lookup, concat, replicate, splitAt, take)
-
-import System.IO (Handle)
-import Data.ByteString (ByteString, pack, unpack, concat, hGet, hPut, singleton)
-import Data.ByteString.Lazy (fromStrict, fromChunks, toStrict)
-import Data.ByteString.Char8 as BC (splitAt)
-import qualified Data.ByteString.Char8 as BC (replicate, pack)
-import Control.Monad (replicateM, liftM)
-import Control.Applicative (liftA3)
-
-import Data.Binary (Binary(..), decode, encode)
-import Data.Binary.Put (putWord32be, putWord16be, putWord8)
-import Data.Binary.Get (getWord32be, getWord16be, getWord8, runGet)
-
-import FuncTorrent.Utils (toIP, toPort)
-
--- | Peer is a IP address, port tuple
-data Peer = Peer IP Port
- deriving (Show, Eq)
-
-type ID = String
-type IP = String
-type Port = Integer
-
-data PeerMsg = KeepAliveMsg
- | ChokeMsg
- | UnChokeMsg
- | InterestedMsg
- | NotInterestedMsg
- | HaveMsg Integer
- | BitFieldMsg ByteString
- | RequestMsg Integer Integer Integer
- | PieceMsg Integer Integer ByteString
- | CancelMsg Integer Integer Integer
- | PortMsg Port
- deriving (Show)
-
-instance Binary PeerMsg where
- put msg = case msg of
- KeepAliveMsg -> putWord32be 0
- ChokeMsg -> do putWord32be 1
- putWord8 0
- UnChokeMsg -> do putWord32be 1
- putWord8 1
- InterestedMsg -> do putWord32be 1
- putWord8 2
- NotInterestedMsg -> do putWord32be 1
- putWord8 3
- HaveMsg i -> do putWord32be 5
- putWord8 4
- putWord32be (fromIntegral i)
- BitFieldMsg bf -> do putWord32be $ fromIntegral (1 + bfListLen)
- putWord8 5
- mapM_ putWord8 bfList
- where bfList = unpack bf
- bfListLen = length bfList
- RequestMsg i o l -> do putWord32be 13
- putWord8 6
- putIndexOffsetLength i o l
- PieceMsg i o b -> do putWord32be $ fromIntegral (9 + blocklen)
- putWord8 7
- putWord32be (fromIntegral i)
- putWord32be (fromIntegral o)
- mapM_ putWord8 blockList
- where blockList = unpack b
- blocklen = length blockList
- CancelMsg i o l -> do putWord32be 13
- putWord8 8
- putIndexOffsetLength i o l
- PortMsg p -> do putWord32be 3
- putWord8 9
- putWord16be (fromIntegral p)
- where putIndexOffsetLength i o l = do
- putWord32be (fromIntegral i)
- putWord32be (fromIntegral o)
- putWord32be (fromIntegral l)
-
- get = do
- l <- getWord32be
- msgid <- getWord8
- case msgid of
- 0 -> return ChokeMsg
- 1 -> return UnChokeMsg
- 2 -> return InterestedMsg
- 3 -> return NotInterestedMsg
- 4 -> fmap (HaveMsg . fromIntegral) getWord32be
- 5 -> fmap (BitFieldMsg . pack) (replicateM (fromIntegral l - 1) getWord8)
- 6 -> liftA3 RequestMsg getInteger getInteger getInteger
- where getInteger = fromIntegral <$> getWord32be
- 7 -> liftA3 PieceMsg getInteger getInteger (pack <$> replicateM (fromIntegral l - 9) getWord8)
- where getInteger = fromIntegral <$> getWord32be
- 8 -> liftA3 CancelMsg getInteger getInteger getInteger
- where getInteger = fromIntegral <$> getWord32be
- 9 -> fmap (PortMsg . fromIntegral) getWord16be
- _ -> error ("unknown message ID: " ++ show msgid)
-
-getMsg :: Handle -> IO PeerMsg
-getMsg h = do
- lBS <- hGet h 4
- let l = bsToInt lBS
- if l == 0
- then return KeepAliveMsg
- else do
- msg <- hGet h l
- return $ decode $ fromStrict $ concat [lBS, msg]
-
-sendMsg :: Handle -> PeerMsg -> IO ()
-sendMsg h msg = hPut h bsMsg
- where bsMsg = toStrict $ encode msg
-
-genHandshakeMsg :: ByteString -> String -> ByteString
-genHandshakeMsg infoHash peer_id = concat [pstrlen, pstr, reserved, infoHash, peerID]
- where pstrlen = singleton 19
- pstr = BC.pack "BitTorrent protocol"
- reserved = BC.replicate 8 '\0'
- peerID = BC.pack peer_id
-
-bsToInt :: ByteString -> Int
-bsToInt x = fromIntegral (runGet getWord32be (fromChunks (return x)))
-
-makePeer :: ByteString -> Peer
-makePeer peer = Peer (toIP ip') (toPort port')
- where (ip', port') = splitAt 4 peer
projects / functorrent.git / blobdiff