mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

convert P2P runners from Maybe to Either String

Browse source 
So we get some useful error messages when things fail.

This commit was sponsored by Peter Hogg on Patreon.
This commit is contained in:
Joey Hess 2016-12-08 15:47:49 -04:00
parent c05f4eb631
commit af41519126
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
7 changed files with 69 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
CmdLine/GitRemoteTorAnnex.hs
View file

@ -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

5
Command/P2P.hs
View file

@ -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 ++ ")"

17
P2P/Annex.hs
View file

@ -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 ->

59
P2P/IO.hs
View file

@ -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.

25
Remote/P2P.hs
View file

@ -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 "Unable to connect to peer."
Left e -> do
warning e
liftIO $ closeConnection conn
return ClosedConnection
Left e -> do
warning $ "Unable to connect to peer. (" ++ show e ++ ")"
return ClosedConnection

9
RemoteDaemon/Transport/Tor.hs
View file

@ -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"

2
doc/todo/tor.mdwn
View file

@ -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?