From a62ff37228afd1d13cfee8f86e45e33e6b7f2a10 Mon Sep 17 00:00:00 2001
From: Ramakrishnan Muthukrishnan <ram@rkrishnan.org>
Date: Fri, 18 Sep 2015 08:28:51 +0530
Subject: [PATCH] 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.
---
 src/FuncTorrent/Peer.hs   | 43 +++++++++++++++++++++++++++------------
 src/FuncTorrent/Server.hs |  2 +-
 src/main/Main.hs          |  2 +-
 3 files changed, 32 insertions(+), 15 deletions(-)

diff --git a/src/FuncTorrent/Peer.hs b/src/FuncTorrent/Peer.hs
index e4d7a72..2caf377 100644
--- a/src/FuncTorrent/Peer.hs
+++ b/src/FuncTorrent/Peer.hs
@@ -8,10 +8,10 @@ module FuncTorrent.Peer
      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
@@ -83,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
@@ -132,10 +149,10 @@ updatePieceAvailability pieceStatus p pieceList =
                        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
-  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
diff --git a/src/FuncTorrent/Server.hs b/src/FuncTorrent/Server.hs
index b78be29..766ac4e 100644
--- 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
-  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 79cd9bf..b67b6b2 100644
--- 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)
-          handlePeerMsgs p1 peerId m pieceMap
+          handlePeerMsgs p1 peerId m pieceMap True
     logStop logR
-- 
2.37.2