src/FuncTorrent/Peer.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module FuncTorrent.Peer
   3     (Peer(..),
   4      handShake
   5     ) where
   6
   7 import Prelude hiding (lookup, concat, replicate, splitAt)
   8
   9 import System.IO
  10 import Data.ByteString (ByteString, unpack, concat, hGet, hPut, singleton)
  11 import Data.ByteString.Char8 (replicate, pack)
  12 import Network (connectTo, PortID(..))
  13
  14 type ID = String
  15 type IP = String
  16 type Port = Integer
  17
  18 data PeerState = PeerState { am_choking :: Bool
  19                            , am_interested :: Bool
  20                            , peer_choking :: Bool
  21                            , peer_interested :: Bool }
  22
  23 -- | Peer is a PeerID, IP address, port tuple
  24 data Peer = Peer ID IP Port
  25           deriving (Show, Eq)
  26
  27 data Msg = HandShakeMsg ByteString ID
  28          | KeepAliveMsg
  29          | ChokeMsg
  30          | UnChokeMsg
  31          | InterestedMsg
  32          | NotInterestedMsg
  33          | HaveMsg Integer
  34          | BitFieldMsg Integer
  35          | RequestMsg Integer Integer Integer
  36          | PieceMsg Integer Integer Integer
  37          | CancelMsg Integer Integer Integer
  38          | PortMsg Port
  39          deriving (Show)
  40
  41 genHandShakeMsg :: ByteString -> String -> ByteString
  42 genHandShakeMsg infoHash peer_id = concat [pstrlen, pstr, reserved, infoHash, peerID]
  43   where pstrlen = singleton 19
  44         pstr = pack "BitTorrent protocol"
  45         reserved = replicate 8 '\0'
  46         peerID = pack peer_id
  47
  48 handShake :: Peer -> ByteString -> String -> IO ByteString
  49 handShake (Peer _ ip port) infoHash peerid = do
  50   let hs = genHandShakeMsg infoHash peerid
  51   handle <- connectTo ip (PortNumber (fromIntegral port))
  52   hSetBuffering handle LineBuffering
  53   hPut handle hs
  54   rlenBS <- hGet handle 1
  55   let rlen = fromIntegral $ (unpack rlenBS) !! 0
  56   hGet handle rlen
  57
  58 -- sendMsg :: Peer -> Handle -> PeerMsg -> IO ()
  59 -- recvMsg :: Peer -> Handle -> Msg