summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CmdLine/GitRemoteTorAnnex.hs6
-rw-r--r--Command/P2P.hs5
-rw-r--r--P2P/Annex.hs17
-rw-r--r--P2P/IO.hs59
-rw-r--r--Remote/P2P.hs25
-rw-r--r--RemoteDaemon/Transport/Tor.hs9
-rw-r--r--doc/todo/tor.mdwn2
7 files changed, 69 insertions, 54 deletions
diff --git a/CmdLine/GitRemoteTorAnnex.hs b/CmdLine/GitRemoteTorAnnex.hs
index c4bf26c85..5208a47ca 100644
--- a/CmdLine/GitRemoteTorAnnex.hs
+++ b/CmdLine/GitRemoteTorAnnex.hs
@@ -34,8 +34,8 @@ run (_remotename:address:[]) = forever $ do
| otherwise = parseAddressPort address
go service = do
ready
- res <- connectService onionaddress onionport service
- exitWith (fromMaybe (ExitFailure 1) res)
+ either giveup exitWith
+ =<< connectService onionaddress onionport service
ready = do
putStrLn ""
hFlush stdout
@@ -50,7 +50,7 @@ parseAddressPort s =
Nothing -> giveup "onion address must include port number"
Just p -> (OnionAddress a, p)
-connectService :: OnionAddress -> OnionPort -> Service -> IO (Maybe ExitCode)
+connectService :: OnionAddress -> OnionPort -> Service -> IO (Either String ExitCode)
connectService address port service = do
state <- Annex.new =<< Git.CurrentRepo.get
Annex.eval state $ do
diff --git a/Command/P2P.hs b/Command/P2P.hs
index db69eff97..ea4dd7c65 100644
--- a/Command/P2P.hs
+++ b/Command/P2P.hs
@@ -85,7 +85,7 @@ linkRemote remotename = do
u <- getUUID
v <- liftIO $ runNetProto conn $ P2P.auth u authtoken
case v of
- Just (Just theiruuid) -> do
+ Right (Just theiruuid) -> do
ok <- inRepo $ Git.Command.runBool
[ Param "remote", Param "add"
, Param remotename
@@ -95,5 +95,6 @@ linkRemote remotename = do
storeUUIDIn (remoteConfig remotename "uuid") theiruuid
storeP2PRemoteAuthToken addr authtoken
return ok
- _ -> giveup "Unable to authenticate with peer. Please check the address and try again."
+ Right Nothing -> giveup "Unable to authenticate with peer. Please check the address and try again."
+ Left e -> giveup $ "Unable to authenticate with peer: " ++ e
connerror e = giveup $ "Unable to connect with peer. Please check that the peer is connected to the network, and try again. (" ++ show e ++ ")"
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.
diff --git a/Remote/P2P.hs b/Remote/P2P.hs
index 1d7ede30f..bc0e2f923 100644
--- a/Remote/P2P.hs
+++ b/Remote/P2P.hs
@@ -127,14 +127,15 @@ runProto u addr connpool a = withConnection u addr connpool (runProto' a)
runProto' :: P2P.Proto a -> Connection -> Annex (Connection, Maybe a)
runProto' _ ClosedConnection = return (ClosedConnection, Nothing)
runProto' a (OpenConnection conn) = do
- r <- runFullProto Client conn a
+ v <- runFullProto Client conn a
-- When runFullProto fails, the connection is no longer usable,
-- so close it.
- if isJust r
- then return (OpenConnection conn, r)
- else do
+ case v of
+ Left e -> do
+ warning e
liftIO $ closeConnection conn
- return (ClosedConnection, r)
+ return (ClosedConnection, Nothing)
+ Right r -> return (OpenConnection conn, Just r)
-- Uses an open connection if one is available in the ConnectionPool;
-- otherwise opens a new connection.
@@ -176,16 +177,20 @@ openConnection u addr = do
res <- liftIO $ runNetProto conn $
P2P.auth myuuid authtoken
case res of
- Just (Just theiruuid)
+ Right (Just theiruuid)
| u == theiruuid -> return (OpenConnection conn)
| otherwise -> do
liftIO $ closeConnection conn
warning "Remote peer uuid seems to have changed."
return ClosedConnection
- _ -> do
- liftIO $ closeConnection conn
+ Right Nothing -> do
warning "Unable to authenticate with peer."
+ liftIO $ closeConnection conn
+ return ClosedConnection
+ Left e -> do
+ warning e
+ liftIO $ closeConnection conn
return ClosedConnection
- Left _e -> do
- warning "Unable to connect to peer."
+ Left e -> do
+ warning $ "Unable to connect to peer. (" ++ show e ++ ")"
return ClosedConnection
diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs
index e5d4e97ad..ab794a77e 100644
--- a/RemoteDaemon/Transport/Tor.hs
+++ b/RemoteDaemon/Transport/Tor.hs
@@ -92,10 +92,15 @@ serveClient th u r q = bracket setup cleanup go
}
v <- liftIO $ runNetProto conn $ serveAuth u
case v of
- Just (Just theiruuid) -> void $
+ Right (Just theiruuid) -> void $
runFullProto (Serving theiruuid) conn $
serveAuthed u
- _ -> return ()
+ Right Nothing -> do
+ liftIO $ debugM "remotedaemon" "TOR connection failed to authenticate"
+ return ()
+ Left e -> do
+ warning e
+ return ()
-- Merge the duplicated state back in.
liftAnnex th $ mergeState st'
debugM "remotedaemon" "done with TOR connection"
diff --git a/doc/todo/tor.mdwn b/doc/todo/tor.mdwn
index fa078ac6b..12ef7561f 100644
--- a/doc/todo/tor.mdwn
+++ b/doc/todo/tor.mdwn
@@ -8,8 +8,6 @@ Current todo list:
memory, more than I'd expect. Check if this is a memory leak..
* Resuming an interrupted transfer fails at the end, despite having gotten
the whole correct file content.
-* There are no error messages when things fail. Need to convert P2P runner
- from Maybe to Either String.
* update progress logs in remotedaemon send/receive
* Think about locking some more. What happens if the connection to the peer
is dropped while we think we're locking content there from being dropped?
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-03 05:24:10 +0000