-createDummyFile :: FilePath -> Int -> IO ()
-createDummyFile path size =
- writeFile path (BC.replicate size '\0')
-
--- write into a file at a specific offet
-writeFileAtOffset :: FilePath -> Integer -> ByteString -> IO ()
-writeFileAtOffset path offset block =
- withFile path WriteMode $ (\h -> do
- _ <- hSeek h AbsoluteSeek offset
- hPut h block)
-
--- recvMsg :: Peer -> Handle -> Msg
-msgLoop :: PeerState -> PieceMap -> IO ()
-msgLoop pState pieceStatus | meInterested pState == False &&
- heChoking pState == True = do
- -- if me NOT Interested and she is Choking, tell her that
- -- I am interested.
- let h = handle pState
- sendMsg h InterestedMsg
- putStrLn $ "--> InterestedMsg to peer: " ++ show (peer pState)
- msgLoop (pState { meInterested = True }) pieceStatus
- | meInterested pState == True &&
- heChoking pState == False =
- -- if me Interested and she not Choking, send her a request
- -- for a piece.
- case pickPiece pieceStatus of
- Nothing -> putStrLn "Nothing to download"
- Just workPiece -> do
- let pLen = len (pieceStatus ! workPiece)
- pBS <- downloadPiece (handle pState) workPiece pLen
- if not $ verifyHash pBS (hash (pieceStatus ! workPiece))
- then
- putStrLn $ "Hash mismatch: " ++ show (hash (pieceStatus ! workPiece)) ++ " vs " ++ show (take 20 (SHA1.hash pBS))
- else
- msgLoop pState (adjust (\pieceData -> pieceData { state = Have }) workPiece pieceStatus)
- | otherwise = do
- msg <- getMsg (handle pState)
- putStrLn $ "<-- " ++ show msg ++ "from peer: " ++ show (peer pState)
- case msg of
- KeepAliveMsg -> do
- sendMsg (handle pState) KeepAliveMsg
- putStrLn $ "--> " ++ "KeepAliveMsg to peer: " ++ show (peer pState)
- msgLoop pState pieceStatus
- BitFieldMsg bss -> do
- let pieceList = bitfieldToList (unpack bss)
- pieceStatus' = updatePieceAvailability pieceStatus (peer pState) pieceList
- print pieceList
- -- for each pieceIndex in pieceList, make an entry in the pieceStatus
- -- map with pieceIndex as the key and modify the value to add the peer.
- -- download each of the piece in order
- msgLoop pState pieceStatus'
- UnChokeMsg -> do
- msgLoop (pState { heChoking = False }) pieceStatus
- _ -> do
- msgLoop pState pieceStatus
-
--- simple algorithm to pick piece.
--- pick the first piece from 0 that is not downloaded yet.
-pickPiece :: PieceMap -> Maybe Integer
-pickPiece m =
- let pieceList = toList m
- allPending = filter (\(_, v) -> state v == Pending) pieceList
- in
- case allPending of
- [] -> Nothing
- ((i, _):_) -> Just i
+-- helper functions to manipulate PeerState
+toPeerState :: Handle
+ -> Peer
+ -> Bool -- ^ meChoking
+ -> Bool -- ^ meInterested
+ -> Bool -- ^ heChoking
+ -> Bool -- ^ heInterested
+ -> PState
+toPeerState h p meCh meIn heCh heIn =
+ PState { handle = h
+ , peer = p
+ , heChoking = heCh
+ , heInterested = heIn
+ , meChoking = meCh
+ , meInterested = meIn }
+
+handlePeerMsgs :: Peer -> String -> Metainfo -> PieceMap -> Bool -> FS.MsgChannel -> IO ()
+handlePeerMsgs p peerId m pieceMap isClient c = do
+ h <- connectToPeer p
+ doHandshake isClient h p (infoHash m) peerId
+ let pstate = toPeerState h p False False True True
+ _ <- runStateT (msgLoop pieceMap c) pstate
+ return ()
+
+msgLoop :: PieceMap -> FS.MsgChannel -> StateT PState IO ()
+msgLoop pieceStatus msgchannel = do
+ h <- gets handle
+ st <- get
+ case st of
+ PState { meInterested = False, heChoking = True } -> do
+ liftIO $ sendMsg h InterestedMsg
+ gets peer >>= (\p -> liftIO $ putStrLn $ "--> InterestedMsg to peer: " ++ show p)
+ modify (\st' -> st' { meInterested = True })
+ msgLoop pieceStatus msgchannel
+ PState { meInterested = True, heChoking = False } ->
+ case pickPiece pieceStatus of
+ Nothing -> liftIO $ putStrLn "Nothing to download"
+ Just workPiece -> do
+ let pLen = len (pieceStatus ! workPiece)
+ liftIO $ putStrLn $ "piece length = " ++ show pLen
+ pBS <- liftIO $ downloadPiece h workPiece pLen
+ if not $ verifyHash pBS (hash (pieceStatus ! workPiece))
+ then
+ liftIO $ putStrLn "Hash mismatch"
+ else do
+ liftIO $ putStrLn $ "Write piece: " ++ show workPiece
+ liftIO $ FS.writePieceToDisk msgchannel workPiece pBS
+ msgLoop (adjust (\pieceData -> pieceData { dlstate = Have }) workPiece pieceStatus) msgchannel
+ _ -> do
+ msg <- liftIO $ getMsg h
+ gets peer >>= (\p -> liftIO $ putStrLn $ "<-- " ++ show msg ++ " from peer: " ++ show p)
+ case msg of
+ KeepAliveMsg -> do
+ liftIO $ sendMsg h KeepAliveMsg
+ gets peer >>= (\p -> liftIO $ putStrLn $ "--> " ++ "KeepAliveMsg to peer: " ++ show p)
+ msgLoop pieceStatus msgchannel
+ BitFieldMsg bss -> do
+ p <- gets peer
+ let pieceList = bitfieldToList (unpack bss)
+ pieceStatus' = updatePieceAvailability pieceStatus p pieceList
+ liftIO $ putStrLn $ show (length pieceList) ++ " Pieces"
+ -- for each pieceIndex in pieceList, make an entry in the pieceStatus
+ -- map with pieceIndex as the key and modify the value to add the peer.
+ -- download each of the piece in order
+ msgLoop pieceStatus' msgchannel
+ UnChokeMsg -> do
+ modify (\st' -> st' {heChoking = False })
+ msgLoop pieceStatus msgchannel
+ ChokeMsg -> do
+ modify (\st' -> st' {heChoking = True })
+ msgLoop pieceStatus msgchannel
+ InterestedMsg -> do
+ modify (\st' -> st' {heInterested = True})
+ msgLoop pieceStatus msgchannel
+ NotInterestedMsg -> do
+ modify (\st' -> st' {heInterested = False})
+ msgLoop pieceStatus msgchannel
+ CancelMsg _ _ _ -> -- check if valid index, begin, length
+ msgLoop pieceStatus msgchannel
+ PortMsg _ ->
+ msgLoop pieceStatus msgchannel
+ HaveMsg idx -> do
+ p <- gets peer
+ let pieceStatus' = updatePieceAvailability pieceStatus p [idx]
+ msgLoop pieceStatus' msgchannel
+ _ -> do
+ liftIO $ putStrLn $ ".. not doing anything with the msg"
+ msgLoop pieceStatus msgchannel
+ -- No need to handle PieceMsg and RequestMsg here.