improve p2p protocol implementation

Tested it in ghci a little now.

2 files changed, 24 insertions, 16 deletions

diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs
index fbd6c2463..1e1519560 100644
--- a/Remote/Helper/P2P.hs
+++ b/Remote/Helper/P2P.hs
@@ -134,6 +134,7 @@ data NetF c
 	| ReceiveMessage (Message -> c)
 	| SendBytes Len L.ByteString c
 	| ReceiveBytes Len (L.ByteString -> c)
+	| CheckAuthToken UUID AuthToken (Bool -> c)
 	| Relay RelayHandle
 		(RelayData -> Net (Maybe ExitCode))
 		(ExitCode -> c)
@@ -173,7 +174,6 @@ data LocalF c
 	-- Note: The ByteString may not contain the entire remaining content
 	-- of the key. Only once the key file size == Len has the whole
 	-- content been transferred.
-	| CheckAuthToken UUID AuthToken (Bool -> c)
 	| SetPresent Key UUID c
 	| CheckContentPresent Key (Bool -> c)
 	-- ^ Checks if the whole content of the key is locally present.
@@ -203,6 +203,7 @@ runNet (ReceiveMessage _) [] = [("not enough Messages provided", Nothing)]
 runNet (ReceiveMessage next) (m:ms) = ("<", Just m):runPure (next m) ms
 runNet (SendBytes _ _ next) ms = ("> bytes", Nothing):runPure next ms
 runNet (ReceiveBytes _ next) ms = ("< bytes", Nothing):runPure (next L.empty) ms
+runNet (CheckAuthToken _ _ next) ms = runPure (next True) ms
 runNet (Relay _ _ next) ms = runPure (next ExitSuccess) ms
 runNet (RelayService _ _ next) ms = runPure (next ExitSuccess) ms
 runNet (WriteRelay _ _ next) ms = runPure next ms
@@ -211,7 +212,6 @@ runLocal :: Show r => LocalF (Proto r) -> [Message] -> [(String, Maybe Message)]
 runLocal (KeyFileSize _ next) ms = runPure (next (Len 100)) ms
 runLocal (ReadKeyFile _ _ next) ms = runPure (next L.empty) ms
 runLocal (WriteKeyFile _ _ _ _ next) ms = runPure (next True) ms
-runLocal (CheckAuthToken _ _ next) ms = runPure (next True) ms
 runLocal (SetPresent _ _ next) ms = runPure next ms
 runLocal (CheckContentPresent _ next) ms = runPure (next False) ms
 runLocal (RemoveKeyFile _ next) ms = runPure (next True) ms
@@ -298,7 +298,7 @@ serve myuuid = go Nothing
 		r <- net receiveMessage
 		case r of
 			AUTH theiruuid authtoken -> do
-				ok <- local $ checkAuthToken theiruuid authtoken
+				ok <- net $ checkAuthToken theiruuid authtoken
 				if ok
 					then do
 						net $ sendMessage (AUTH_SUCCESS myuuid)
diff --git a/Remote/Helper/P2P/IO.hs b/Remote/Helper/P2P/IO.hs
index 82ba2d6f9..6908fd68c 100644
--- a/Remote/Helper/P2P/IO.hs
+++ b/Remote/Helper/P2P/IO.hs
@@ -14,6 +14,7 @@ module Remote.Helper.P2P.IO
 
 import Remote.Helper.P2P
 import Utility.Process
+import Types.UUID
 import Git
 import Git.Command
 import Utility.SafeCommand
@@ -33,39 +34,46 @@ type RunProto = forall a m. MonadIO m => Proto a -> m a
 
 data S = S
 	{ repo :: Repo
-	, hdl :: Handle
+	, ihdl :: Handle
+	, ohdl :: Handle
 	}
 
 -- Implementation of the protocol, communicating with a peer
 -- over a Handle. No Local actions will be run.
-runNetProtoHandle :: MonadIO m => Handle -> Repo -> Proto a -> m a
-runNetProtoHandle h r = go
+runNetProtoHandle :: MonadIO m => Handle -> Handle -> Repo -> Proto a -> m a
+runNetProtoHandle i o r = go
   where
 	go :: RunProto
 	go (Pure a) = pure a
-	go (Free (Net n)) = runNetHandle (S r h) go n
+	go (Free (Net n)) = runNetHandle (S r i o) go n
 	go (Free (Local _)) = error "local actions not allowed"
 
 runNetHandle :: MonadIO m => S -> RunProto -> NetF (Proto a) -> m a
 runNetHandle s runner f = case f of
 	SendMessage m next -> do
 		liftIO $ do
-			hPutStrLn (hdl s) (unwords (formatMessage m))
-			hFlush (hdl s)
+			hPutStrLn (ohdl s) (unwords (formatMessage m))
+			hFlush (ohdl s)
 		runner next
 	ReceiveMessage next -> do
-		l <- liftIO $ hGetLine (hdl s)
-		let m = fromMaybe (ERROR "protocol parse error")
-			(parseMessage l)
-		runner (next m)
+		l <- liftIO $ hGetLine (ihdl s)
+		case parseMessage l of
+			Just m -> runner (next m)
+			Nothing -> runner $ do
+				let e = ERROR "protocol parse error"
+				net $ sendMessage e
+				next e
 	SendBytes _len b next -> do
 		liftIO $ do
-			L.hPut (hdl s) b
-			hFlush (hdl s)
+			L.hPut (ohdl s) b
+			hFlush (ohdl s)
 		runner next
 	ReceiveBytes (Len n) next -> do
-		b <- liftIO $ L.hGet (hdl s) (fromIntegral n)
+		b <- liftIO $ L.hGet (ihdl s) (fromIntegral n)
 		runner (next b)
+	CheckAuthToken u t next -> do
+		authed <- return True -- TODO XXX FIXME really check
+		runner (next authed)
 	Relay hout callback next ->
 		runRelay runner hout callback >>= runner . next
 	RelayService service callback next ->