summaryrefslogtreecommitdiff
path: root/P2P
diff options
context:
space:
mode:
Diffstat (limited to 'P2P')
-rw-r--r--P2P/Annex.hs17
-rw-r--r--P2P/IO.hs59
2 files changed, 41 insertions, 35 deletions
diff --git a/P2P/Annex.hs b/P2P/Annex.hs
index 7e07038d3..d55d69bdb 100644
--- a/P2P/Annex.hs
+++ b/P2P/Annex.hs
@@ -31,15 +31,15 @@ data RunMode
| Client
-- Full interpreter for Proto, that can receive and send objects.
-runFullProto :: RunMode -> P2PConnection -> Proto a -> Annex (Maybe a)
+runFullProto :: RunMode -> P2PConnection -> Proto a -> Annex (Either String a)
runFullProto runmode conn = go
where
go :: RunProto Annex
- go (Pure v) = pure (Just v)
+ go (Pure v) = pure (Right v)
go (Free (Net n)) = runNet conn go n
go (Free (Local l)) = runLocal runmode go l
-runLocal :: RunMode -> RunProto Annex -> LocalF (Proto a) -> Annex (Maybe a)
+runLocal :: RunMode -> RunProto Annex -> LocalF (Proto a) -> Annex (Either String a)
runLocal runmode runner a = case a of
TmpContentSize k next -> do
tmp <- fromRepo $ gitAnnexTmpObjectLocation k
@@ -68,9 +68,10 @@ runLocal runmode runner a = case a of
hSeek h AbsoluteSeek o
L.hGetContents h
case v' of
- Left _ -> return Nothing
+ Left e -> return (Left (show e))
Right b -> runner (next b)
- _ -> return Nothing
+ Right Nothing -> return (Left "content not available")
+ Left e -> return (Left (show e))
StoreContent k af o l b next -> do
ok <- flip catchNonAsync (const $ return False) $
transfer download k af $
@@ -84,12 +85,12 @@ runLocal runmode runner a = case a of
SetPresent k u next -> do
v <- tryNonAsync $ logChange k u InfoPresent
case v of
- Left _ -> return Nothing
+ Left e -> return (Left (show e))
Right () -> runner next
CheckContentPresent k next -> do
v <- tryNonAsync $ inAnnex k
case v of
- Left _ -> return Nothing
+ Left e -> return (Left (show e))
Right result -> runner (next result)
RemoveContent k next -> do
v <- tryNonAsync $ lockContentForRemoval k $ \contentlock -> do
@@ -97,7 +98,7 @@ runLocal runmode runner a = case a of
logStatus k InfoMissing
return True
case v of
- Left _ -> return Nothing
+ Left e -> return (Left (show e))
Right result -> runner (next result)
TryLockContent k protoaction next -> do
v <- tryNonAsync $ lockContentShared k $ \verifiedcopy ->
diff --git a/P2P/IO.hs b/P2P/IO.hs
index b8e34333b..a2af5946c 100644
--- a/P2P/IO.hs
+++ b/P2P/IO.hs
@@ -42,7 +42,7 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
-- Type of interpreters of the Proto free monad.
-type RunProto m = forall a. (MonadIO m, MonadMask m) => Proto a -> m (Maybe a)
+type RunProto m = forall a. (MonadIO m, MonadMask m) => Proto a -> m (Either String a)
data P2PConnection = P2PConnection
{ connRepo :: Repo
@@ -80,31 +80,31 @@ setupHandle s = do
-- This only runs Net actions. No Local actions will be run
-- (those need the Annex monad) -- if the interpreter reaches any,
-- it returns Nothing.
-runNetProto :: P2PConnection -> Proto a -> IO (Maybe a)
+runNetProto :: P2PConnection -> Proto a -> IO (Either String a)
runNetProto conn = go
where
go :: RunProto IO
- go (Pure v) = pure (Just v)
+ go (Pure v) = pure (Right v)
go (Free (Net n)) = runNet conn go n
- go (Free (Local _)) = return Nothing
+ go (Free (Local _)) = return (Left "unexpected annex operation attempted")
-- Interpreter of the Net part of Proto.
--
-- An interpreter of Proto has to be provided, to handle the rest of Proto
-- actions.
-runNet :: (MonadIO m, MonadMask m) => P2PConnection -> RunProto m -> NetF (Proto a) -> m (Maybe a)
+runNet :: (MonadIO m, MonadMask m) => P2PConnection -> RunProto m -> NetF (Proto a) -> m (Either String a)
runNet conn runner f = case f of
SendMessage m next -> do
v <- liftIO $ tryNonAsync $ do
hPutStrLn (connOhdl conn) (unwords (formatMessage m))
hFlush (connOhdl conn)
case v of
- Left _e -> return Nothing
+ Left e -> return (Left (show e))
Right () -> runner next
ReceiveMessage next -> do
v <- liftIO $ tryNonAsync $ hGetLine (connIhdl conn)
case v of
- Left _e -> return Nothing
+ Left e -> return (Left (show e))
Right l -> case parseMessage l of
Just m -> runner (next m)
Nothing -> runner $ do
@@ -118,11 +118,12 @@ runNet conn runner f = case f of
return ok
case v of
Right True -> runner next
- _ -> return Nothing
+ Right False -> return (Left "short data write")
+ Left e -> return (Left (show e))
ReceiveBytes len p next -> do
v <- liftIO $ tryNonAsync $ receiveExactly len (connIhdl conn) p
case v of
- Left _e -> return Nothing
+ Left e -> return (Left (show e))
Right b -> runner (next b)
CheckAuthToken _u t next -> do
let authed = connCheckAuth conn t
@@ -130,13 +131,13 @@ runNet conn runner f = case f of
Relay hin hout next -> do
v <- liftIO $ runRelay runnerio hin hout
case v of
- Nothing -> return Nothing
- Just exitcode -> runner (next exitcode)
+ Left e -> return (Left e)
+ Right exitcode -> runner (next exitcode)
RelayService service next -> do
v <- liftIO $ runRelayService conn runnerio service
case v of
- Nothing -> return Nothing
- Just () -> runner next
+ Left e -> return (Left e)
+ Right () -> runner next
where
-- This is only used for running Net actions when relaying,
-- so it's ok to use runNetProto, despite it not supporting
@@ -162,8 +163,10 @@ sendExactly (Len n) b h p = do
receiveExactly :: Len -> Handle -> MeterUpdate -> IO L.ByteString
receiveExactly (Len n) h p = hGetMetered h (Just n) p
-runRelay :: RunProto IO -> RelayHandle -> RelayHandle -> IO (Maybe ExitCode)
-runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go
+runRelay :: RunProto IO -> RelayHandle -> RelayHandle -> IO (Either String ExitCode)
+runRelay runner (RelayHandle hout) (RelayHandle hin) =
+ bracket setup cleanup go
+ `catchNonAsync` (return . Left . show)
where
setup = do
v <- newEmptyMVar
@@ -177,8 +180,10 @@ runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go
go v = relayHelper runner v
-runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Maybe ())
-runRelayService conn runner service = bracket setup cleanup go
+runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Either String ())
+runRelayService conn runner service =
+ bracket setup cleanup go
+ `catchNonAsync` (return . Left . show)
where
cmd = case service of
UploadPack -> "upload-pack"
@@ -209,13 +214,13 @@ runRelayService conn runner service = bracket setup cleanup go
go (v, _, _, _, _) = do
r <- relayHelper runner v
case r of
- Nothing -> return Nothing
- Just exitcode -> runner $ net $ relayToPeer (RelayDone exitcode)
+ Left e -> return (Left (show e))
+ Right exitcode -> runner $ net $ relayToPeer (RelayDone exitcode)
waitexit v pid = putMVar v . RelayDone =<< waitForProcess pid
-- Processes RelayData as it is put into the MVar.
-relayHelper :: RunProto IO -> MVar RelayData -> IO (Maybe ExitCode)
+relayHelper :: RunProto IO -> MVar RelayData -> IO (Either String ExitCode)
relayHelper runner v = loop
where
loop = do
@@ -224,11 +229,11 @@ relayHelper runner v = loop
RelayToPeer b -> do
r <- runner $ net $ relayToPeer (RelayToPeer b)
case r of
- Nothing -> return Nothing
- Just () -> loop
+ Left e -> return (Left e)
+ Right () -> loop
RelayDone exitcode -> do
_ <- runner $ net $ relayToPeer (RelayDone exitcode)
- return (Just exitcode)
+ return (Right exitcode)
RelayFromPeer _ -> loop -- not handled here
-- Takes input from the peer, and sends it to the relay process's stdin.
@@ -239,15 +244,15 @@ relayFeeder runner v hin = loop
loop = do
mrd <- runner $ net relayFromPeer
case mrd of
- Nothing ->
+ Left _e ->
putMVar v (RelayDone (ExitFailure 1))
- Just (RelayDone exitcode) ->
+ Right (RelayDone exitcode) ->
putMVar v (RelayDone exitcode)
- Just (RelayFromPeer b) -> do
+ Right (RelayFromPeer b) -> do
L.hPut hin b
hFlush hin
loop
- Just (RelayToPeer _) -> loop -- not handled here
+ Right (RelayToPeer _) -> loop -- not handled here
-- Reads input from the Handle and puts it into the MVar for relaying to
-- the peer. Continues until EOF on the Handle.