diff options
Diffstat (limited to 'Remote/Helper/P2P/IO.hs')
| -rw-r--r-- | Remote/Helper/P2P/IO.hs | 64 |
1 files changed, 41 insertions, 23 deletions
diff --git a/Remote/Helper/P2P/IO.hs b/Remote/Helper/P2P/IO.hs index 6908fd68c..c6a80cdbf 100644 --- a/Remote/Helper/P2P/IO.hs +++ b/Remote/Helper/P2P/IO.hs @@ -19,6 +19,7 @@ import Git import Git.Command import Utility.SafeCommand import Utility.SimpleProtocol +import Utility.Exception import Control.Monad import Control.Monad.Free @@ -30,7 +31,7 @@ import Control.Concurrent import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -type RunProto = forall a m. MonadIO m => Proto a -> m a +type RunProto = forall a m. (MonadIO m, MonadMask m) => Proto a -> m a data S = S { repo :: Repo @@ -40,7 +41,7 @@ data S = S -- Implementation of the protocol, communicating with a peer -- over a Handle. No Local actions will be run. -runNetProtoHandle :: MonadIO m => Handle -> Handle -> Repo -> Proto a -> m a +runNetProtoHandle :: (MonadIO m, MonadMask m) => Handle -> Handle -> Repo -> Proto a -> m a runNetProtoHandle i o r = go where go :: RunProto @@ -48,7 +49,7 @@ runNetProtoHandle i o r = go 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 :: (MonadIO m, MonadMask m) => S -> RunProto -> NetF (Proto a) -> m a runNetHandle s runner f = case f of SendMessage m next -> do liftIO $ do @@ -57,10 +58,11 @@ runNetHandle s runner f = case f of runner next ReceiveMessage next -> do l <- liftIO $ hGetLine (ihdl s) + -- liftIO $ hPutStrLn stderr ("< " ++ show l) case parseMessage l of Just m -> runner (next m) Nothing -> runner $ do - let e = ERROR "protocol parse error" + let e = ERROR $ "protocol parse error: " ++ show l net $ sendMessage e next e SendBytes _len b next -> do @@ -70,6 +72,7 @@ runNetHandle s runner f = case f of runner next ReceiveBytes (Len n) next -> do b <- liftIO $ L.hGet (ihdl s) (fromIntegral n) + --liftIO $ hPutStrLn stderr $ "!!!" ++ show (L.length b) runner (next b) CheckAuthToken u t next -> do authed <- return True -- TODO XXX FIXME really check @@ -80,7 +83,8 @@ runNetHandle s runner f = case f of runRelayService s runner service callback >>= runner . next WriteRelay (RelayHandle h) b next -> do liftIO $ do - L.hPut h b + -- L.hPut h b + hPutStrLn h (show ("relay got:", b, L.length b)) hFlush h runner next @@ -112,43 +116,57 @@ runRelay runner (RelayHandle hout) callback = do drain v = do d <- takeMVar v + liftIO $ hPutStrLn stderr (show d) r <- runner $ net $ callback d case r of Nothing -> drain v Just exitcode -> return exitcode runRelayService - :: MonadIO m + :: (MonadIO m, MonadMask m) => S -> RunProto -> Service -> (RelayHandle -> RelayData -> Net (Maybe ExitCode)) -> m ExitCode -runRelayService s runner service callback = do - v <- liftIO newEmptyMVar - (Just hin, Just hout, _, pid) <- liftIO $ createProcess serviceproc - { std_out = CreatePipe - , std_in = CreatePipe - } - _ <- liftIO $ forkIO $ readout v hout - feeder <- liftIO $ forkIO $ feedin v - _ <- liftIO $ forkIO $ putMVar v . Left =<< waitForProcess pid - exitcode <- liftIO $ drain v hin - liftIO $ killThread feeder - return exitcode +runRelayService s runner service callback = bracket setup cleanup go where cmd = case service of UploadPack -> "upload-pack" ReceivePack -> "receive-pack" - serviceproc = gitCreateProcess [Param cmd, File (repoPath (repo s))] (repo s) + + serviceproc = gitCreateProcess + [ Param cmd + , File (repoPath (repo s)) + ] (repo s) + + setup = do + v <- liftIO newEmptyMVar + (Just hin, Just hout, _, pid) <- liftIO $ + createProcess serviceproc + { std_out = CreatePipe + , std_in = CreatePipe + } + feeder <- liftIO $ forkIO $ feedin v + return (v, feeder, hin, hout, pid) + + cleanup (_, feeder, hin, hout, pid) = liftIO $ do + hClose hin + hClose hout + liftIO $ killThread feeder + void $ waitForProcess pid + + go (v, _, hin, hout, pid) = do + _ <- liftIO $ forkIO $ readout v hout + _ <- liftIO $ forkIO $ putMVar v . Left =<< waitForProcess pid + liftIO $ drain v hin drain v hin = do d <- takeMVar v case d of - Left exitcode -> do - hClose hin - return exitcode + Left exitcode -> return exitcode Right relaydata -> do + liftIO $ hPutStrLn stderr ("> " ++ show relaydata) _ <- runner $ net $ callback (RelayHandle hin) relaydata drain v hin @@ -156,7 +174,7 @@ runRelayService s runner service callback = do readout v hout = do b <- B.hGetSome hout 65536 if B.null b - then hClose hout + then return () else do putMVar v $ Right $ RelayData (L.fromChunks [b]) |