diff options
Diffstat (limited to 'Remote/Helper')
| -rw-r--r-- | Remote/Helper/P2P.hs | 6 | ||||
| -rw-r--r-- | Remote/Helper/P2P/IO.hs | 34 |
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 -> |