From: Ramakrishnan Muthukrishnan Date: Fri, 24 Jul 2015 17:06:09 +0000 (+0530) Subject: fix file download to create a dummy and write into specific offsets X-Git-Url: https://git.rkrishnan.org/components/com_hotproperty/readonly?a=commitdiff_plain;h=84fc68af1814046d7ea2749f321b9b2bb97cbe8d;p=functorrent.git fix file download to create a dummy and write into specific offsets --- diff --git a/src/FuncTorrent/Peer.hs b/src/FuncTorrent/Peer.hs index 7802b08..6209017 100644 --- a/src/FuncTorrent/Peer.hs +++ b/src/FuncTorrent/Peer.hs @@ -7,7 +7,7 @@ module FuncTorrent.Peer import Prelude hiding (lookup, concat, replicate, splitAt, writeFile, take) import System.IO (Handle, BufferMode(..), IOMode(..), SeekMode(..), withFile, hSeek, hSetBuffering) -import Data.ByteString (ByteString, pack, unpack, concat, hGet, hPut, singleton, writeFile, take) +import Data.ByteString (ByteString, pack, unpack, concat, hGet, hPut, singleton, writeFile, take, empty) import Data.ByteString.Lazy (fromStrict, fromChunks, toStrict) import qualified Data.ByteString.Char8 as BC (replicate, pack, length) import Network (connectTo, PortID(..)) @@ -192,9 +192,9 @@ createDummyFile path size = -- 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) + withFile path ReadWriteMode $ (\h -> do + _ <- hSeek h AbsoluteSeek offset + hPut h block) -- recvMsg :: Peer -> Handle -> Msg msgLoop :: PeerState -> PieceMap -> IO () @@ -215,11 +215,12 @@ msgLoop pState pieceStatus | meInterested pState == False && 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) + -- if not $ verifyHash pBS (hash (pieceStatus ! workPiece)) + -- then + -- putStrLn $ "Hash mismatch: " ++ show (hash (pieceStatus ! workPiece)) ++ " vs " ++ show (take 20 (SHA1.hash pBS)) + -- else do + writeFileAtOffset "/tmp/download.file" (workPiece * pLen) pBS + msgLoop pState (adjust (\pieceData -> pieceData { state = Have }) workPiece pieceStatus) | otherwise = do msg <- getMsg (handle pState) putStrLn $ "<-- " ++ show msg ++ "from peer: " ++ show (peer pState) @@ -231,7 +232,7 @@ msgLoop pState pieceStatus | meInterested pState == False && BitFieldMsg bss -> do let pieceList = bitfieldToList (unpack bss) pieceStatus' = updatePieceAvailability pieceStatus (peer pState) pieceList - print pieceList + 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 @@ -272,6 +273,7 @@ handlePeerMsgs p m peerId = do pLen = pieceLength (info m) fileLen = lengthInBytes (info m) pieceStatus = mkPieceMap numPieces pieceHash (splitNum fileLen pLen) + createDummyFile "/tmp/download.file" (fromIntegral fileLen) msgLoop state pieceStatus downloadPiece :: Handle -> Integer -> Integer -> IO ByteString @@ -282,13 +284,17 @@ downloadPiece h index pieceLength = do putStrLn $ "--> " ++ "RequestMsg for Piece " ++ (show index) ++ ", part: " ++ show i ++ " of length: " ++ show pLen - -- TODO: non exhaustive pattern matching. :( - PieceMsg index begin block <- getMsg h - putStrLn $ " <-- PieceMsg for Piece: " - ++ show index - ++ ", offset: " - ++ show begin - return block) + msg <- getMsg h + case msg of + PieceMsg index begin block -> do + putStrLn $ " <-- PieceMsg for Piece: " + ++ show index + ++ ", offset: " + ++ show begin + return block + _ -> do + putStrLn "ignoring irrelevant msg" + return empty) verifyHash :: ByteString -> ByteString -> Bool verifyHash bs pieceHash =