handshake for server and client

[functorrent.git] / src / FuncTorrent / Peer.hs

diff --git a/src/FuncTorrent/Peer.hs b/src/FuncTorrent/Peer.hs
index 2db57064fcf6a1737ebeeecb0ecf53dfe188eabe..2caf377ac6849a79d3e38afe4424d50ee77c32d0 100644 (file)
--- a/src/FuncTorrent/Peer.hs
+++ b/src/FuncTorrent/Peer.hs
@@ -1,26 +1,27 @@
 {-# LANGUAGE OverloadedStrings #-}
 module FuncTorrent.Peer
     (Peer(..),
+     PieceMap,
      handlePeerMsgs,
-     bytesDownloaded
+     bytesDownloaded,
+     initPieceMap,
+     pieceMapFromFile
     ) where
 
-import Prelude hiding (lookup, concat, replicate, splitAt, take, filter)
+import Prelude hiding (lookup, concat, replicate, splitAt, take, drop, filter)
 
-import System.IO (Handle, BufferMode(..), hSetBuffering)
-import Data.ByteString (ByteString, unpack, concat, hGet, hPut, take, empty)
+import System.IO (Handle, BufferMode(..), hSetBuffering, hClose)
+import Data.ByteString (ByteString, unpack, concat, hGet, hPut, take, drop, empty)
 import qualified Data.ByteString.Char8 as BC (length)
 import Network (connectTo, PortID(..))
 import Control.Monad.State
 import Data.Bits
 import Data.Word (Word8)
-import Data.Map (Map, fromList, toList, (!), mapWithKey, adjust, filter)
-import qualified Crypto.Hash.SHA1 as SHA1 (hash)
+import Data.Map (Map, fromList, toList, (!), mapWithKey, traverseWithKey, adjust, filter)
 import Safe (headMay)
 
 import FuncTorrent.Metainfo (Info(..), Metainfo(..))
-import FuncTorrent.Utils (splitN, splitNum)
-import FuncTorrent.Fileops (createDummyFile, writeFileAtOffset)
+import FuncTorrent.Utils (splitN, splitNum, writeFileAtOffset, readFileAtOffset, verifyHash)
 import FuncTorrent.PeerMsgs (Peer(..), PeerMsg(..), sendMsg, getMsg, genHandshakeMsg)
 
 data PState = PState { handle :: Handle
@@ -49,14 +50,28 @@ type PieceMap = Map Integer PieceData
 
 -- Make the initial Piece map, with the assumption that no peer has the
 -- piece and that every piece is pending download.
-mkPieceMap :: Integer -> ByteString -> [Integer] -> PieceMap
-mkPieceMap numPieces pieceHash pLengths = fromList kvs
-  where kvs = [(i, PieceData { peers = []
-                             , dlstate = Pending
-                             , hash = h
-                             , len = pLen })
-              | (i, h, pLen) <- zip3 [0..numPieces] hashes pLengths]
-        hashes = splitN 20 pieceHash
+initPieceMap :: ByteString  -> Integer -> Integer -> PieceMap
+initPieceMap pieceHash fileLen pieceLen = fromList kvs
+  where
+    numPieces = (toInteger . (`quot` 20) . BC.length) pieceHash
+    kvs = [(i, PieceData { peers = []
+                         , dlstate = Pending
+                         , hash = h
+                         , len = pLen })
+          | (i, h, pLen) <- zip3 [0..numPieces] hashes pLengths]
+    hashes = splitN 20 pieceHash
+    pLengths = (splitNum fileLen pieceLen)
+
+pieceMapFromFile :: FilePath -> PieceMap -> IO PieceMap
+pieceMapFromFile filePath pieceMap = do
+  traverseWithKey f pieceMap
+    where
+      f k v = do
+        let offset = if k == 0 then 0 else k * len (pieceMap ! (k - 1))
+        isHashValid <- (flip verifyHash) (hash v) <$> (readFileAtOffset filePath offset (len v))
+        if isHashValid
+          then return $ v { dlstate = Have }
+          else return $ v
 
 havePiece :: PieceMap -> Integer -> Bool
 havePiece pm index =
@@ -68,14 +83,31 @@ connectToPeer (Peer _ ip port) = do
   hSetBuffering h LineBuffering
   return h
 
-doHandshake :: Handle -> Peer -> ByteString -> String -> IO ()
-doHandshake h peer infoHash peerid = do
+doHandshake :: Bool -> Handle -> Peer -> ByteString -> String -> IO ()
+doHandshake isClient h peer infoHash peerid =
   let hs = genHandshakeMsg infoHash peerid
-  hPut h hs
-  putStrLn $ "--> handhake to peer: " ++ show peer
-  _ <- hGet h (length (unpack hs))
-  putStrLn $ "<-- handshake from peer: " ++ show peer
-  return ()
+  in
+   if isClient
+   then do
+     hPut h hs
+     putStrLn $ "--> handhake to peer: " ++ show peer
+     _ <- hGet h (length (unpack hs))
+     putStrLn $ "<-- handshake from peer: " ++ show peer
+     return ()
+   else do
+     putStrLn $ "waiting for a handshake"
+     hsMsg <- hGet h (length (unpack hs))
+     putStrLn $ "<-- handshake from peer: " ++ show peer
+     let rxInfoHash = take 20 $ drop 28 hsMsg
+     if rxInfoHash /= infoHash
+       then do
+       putStrLn $ "infoHashes does not match"
+       hClose h
+       return ()
+       else do
+       _ <- hPut h hs
+       putStrLn $ "--> handhake to peer: " ++ show peer
+       return ()
 
 bitfieldToList :: [Word8] -> [Integer]
 bitfieldToList bs = go bs 0
@@ -117,19 +149,13 @@ updatePieceAvailability pieceStatus p pieceList =
                        then (pd { peers = p : peers pd })
                        else pd) pieceStatus
 
-handlePeerMsgs :: Peer -> String -> Metainfo -> IO ()
-handlePeerMsgs p peerId m = do
+handlePeerMsgs :: Peer -> String -> Metainfo -> PieceMap -> Bool -> IO ()
+handlePeerMsgs p peerId m pieceMap isClient = do
   h <- connectToPeer p
-  doHandshake h p (infoHash m) peerId
+  doHandshake isClient h p (infoHash m) peerId
   let pstate = toPeerState h p False False True True
-      pieceHash = pieces (info m)
-      numPieces = (toInteger . (`quot` 20) . BC.length) pieceHash
-      pLen = pieceLength (info m)
-      fileLen = lengthInBytes (info m)
-      fileName = name (info m)
-      pieceStatus = mkPieceMap numPieces pieceHash (splitNum fileLen pLen)
-  createDummyFile fileName (fromIntegral fileLen)
-  _ <- runStateT (msgLoop pieceStatus fileName) pstate
+      filePath = name (info m)
+  _ <- runStateT (msgLoop pieceMap filePath) pstate
   return ()
 
 msgLoop :: PieceMap -> FilePath -> StateT PState IO ()
@@ -151,7 +177,7 @@ msgLoop pieceStatus file = do
           pBS <- liftIO $ downloadPiece h workPiece pLen
           if not $ verifyHash pBS (hash (pieceStatus ! workPiece))
             then
-            liftIO $ putStrLn $ "Hash mismatch: " ++ show (hash (pieceStatus ! workPiece)) ++ " vs " ++ show (take 20 (SHA1.hash pBS))
+            liftIO $ putStrLn $ "Hash mismatch"
             else do
             let fileOffset = if workPiece == 0 then 0 else workPiece * len (pieceStatus ! (workPiece - 1))
             liftIO $ putStrLn $ "Write into file at offset: " ++ show fileOffset
@@ -199,6 +225,3 @@ downloadPiece h index pieceLength = do
                                                   putStrLn "ignoring irrelevant msg"
                                                   return empty)
 
-verifyHash :: ByteString -> ByteString -> Bool
-verifyHash bs pieceHash =
-  take 20 (SHA1.hash bs) == pieceHash