handshake for server and client

Earlier implementation used a wrong handhake sequence for the server.
This commit fixes it. It is untested at the moment.

diff --git a/src/FuncTorrent/Peer.hs b/src/FuncTorrent/Peer.hs
index e4d7a7222e2849d9c3d9572a3532fa0f25951c96..2caf377ac6849a79d3e38afe4424d50ee77c32d0 100644 (file)
--- a/src/FuncTorrent/Peer.hs
+++ b/src/FuncTorrent/Peer.hs
@@ -8,10 +8,10 @@ module FuncTorrent.Peer
      pieceMapFromFile
     ) where
 
      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 qualified Data.ByteString.Char8 as BC (length)
 import Network (connectTo, PortID(..))
 import Control.Monad.State


@@ -83,14 +83,31 @@ connectToPeer (Peer _ ip port) = do
   hSetBuffering h LineBuffering
   return h
 
   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
   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
 
 bitfieldToList :: [Word8] -> [Integer]
 bitfieldToList bs = go bs 0


@@ -132,10 +149,10 @@ updatePieceAvailability pieceStatus p pieceList =
                        then (pd { peers = p : peers pd })
                        else pd) pieceStatus
 
                        then (pd { peers = p : peers pd })
                        else pd) pieceStatus
 

-handlePeerMsgs :: Peer -> String -> Metainfo -> PieceMap -> IO ()
-handlePeerMsgs p peerId m pieceMap = do
+handlePeerMsgs :: Peer -> String -> Metainfo -> PieceMap -> Bool -> IO ()
+handlePeerMsgs p peerId m pieceMap isClient = do

   h <- connectToPeer p
   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
       filePath = name (info m)
   _ <- runStateT (msgLoop pieceMap filePath) pstate
   let pstate = toPeerState h p False False True True
       filePath = name (info m)
   _ <- runStateT (msgLoop pieceMap filePath) pstate

diff --git a/src/FuncTorrent/Server.hs b/src/FuncTorrent/Server.hs
index b78be297b935628a90bf10101f8dd836d0578042..766ac4e77aea22510569ace8598767dc77e294f3 100644 (file)
--- a/src/FuncTorrent/Server.hs
+++ b/src/FuncTorrent/Server.hs
@@ -22,4 +22,4 @@ run listenSock peerid m pieceMap = forever $ do
   (handle, ip, port) <- accept listenSock
   let peer = Peer "" ip (fromIntegral port)
   hSetBuffering handle NoBuffering
   (handle, ip, port) <- accept listenSock
   let peer = Peer "" ip (fromIntegral port)
   hSetBuffering handle NoBuffering

-  forkIO $ handlePeerMsgs peer peerid m pieceMap
+  forkIO $ handlePeerMsgs peer peerid m pieceMap False

diff --git a/src/main/Main.hs b/src/main/Main.hs
index 79cd9bf7f06fc7497d8ba81f02aa644f49c7e644..b67b6b282160826689a14fa4b82eb5abf9b9e54f 100644 (file)
--- a/src/main/Main.hs
+++ b/src/main/Main.hs
@@ -88,5 +88,5 @@ main = do
         Right peerList -> do
           log $ "Peers List : " ++ (show . peers $ peerList)
           let p1 = head (peers peerList)
         Right peerList -> do
           log $ "Peers List : " ++ (show . peers $ peerList)
           let p1 = head (peers peerList)

-          handlePeerMsgs p1 peerId m pieceMap
+          handlePeerMsgs p1 peerId m pieceMap True

     logStop logR
     logStop logR