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 | otherwise = parseAddressPort address
go service = do go service = do
ready ready
res <- connectService onionaddress onionport service either giveup exitWith
exitWith (fromMaybe (ExitFailure 1) res) =<< connectService onionaddress onionport service
ready = do ready = do
putStrLn "" putStrLn ""
hFlush stdout hFlush stdout
@ -50,7 +50,7 @@ parseAddressPort s =
Nothing -> giveup "onion address must include port number" Nothing -> giveup "onion address must include port number"
Just p -> (OnionAddress a, p) 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 connectService address port service = do
state <- Annex.new =<< Git.CurrentRepo.get state <- Annex.new =<< Git.CurrentRepo.get
Annex.eval state $ do Annex.eval state $ do

5
Command/P2P.hs
View file

@ -85,7 +85,7 @@ linkRemote remotename = do
u <- getUUID u <- getUUID
v <- liftIO $ runNetProto conn $ P2P.auth u authtoken v <- liftIO $ runNetProto conn $ P2P.auth u authtoken
case v of case v of
Just (Just theiruuid) -> do Right (Just theiruuid) -> do
ok <- inRepo $ Git.Command.runBool ok <- inRepo $ Git.Command.runBool
[ Param "remote", Param "add" [ Param "remote", Param "add"
, Param remotename , Param remotename
@ -95,5 +95,6 @@ linkRemote remotename = do
storeUUIDIn (remoteConfig remotename "uuid") theiruuid storeUUIDIn (remoteConfig remotename "uuid") theiruuid
storeP2PRemoteAuthToken addr authtoken storeP2PRemoteAuthToken addr authtoken
return ok 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 ++ ")" 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 | Client
-- Full interpreter for Proto, that can receive and send objects. -- 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 runFullProto runmode conn = go
where where
go :: RunProto Annex 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 (Net n)) = runNet conn go n
go (Free (Local l)) = runLocal runmode go l 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 runLocal runmode runner a = case a of
TmpContentSize k next -> do TmpContentSize k next -> do
tmp <- fromRepo $ gitAnnexTmpObjectLocation k tmp <- fromRepo $ gitAnnexTmpObjectLocation k
@ -68,9 +68,10 @@ runLocal runmode runner a = case a of
hSeek h AbsoluteSeek o hSeek h AbsoluteSeek o
L.hGetContents h L.hGetContents h
case v' of case v' of
Left _ -> return Nothing Left e -> return (Left (show e))
Right b -> runner (next b) 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 StoreContent k af o l b next -> do
ok <- flip catchNonAsync (const $ return False) $ ok <- flip catchNonAsync (const $ return False) $
transfer download k af $ transfer download k af $
@ -84,12 +85,12 @@ runLocal runmode runner a = case a of
SetPresent k u next -> do SetPresent k u next -> do
v <- tryNonAsync $ logChange k u InfoPresent v <- tryNonAsync $ logChange k u InfoPresent
case v of case v of
Left _ -> return Nothing Left e -> return (Left (show e))
Right () -> runner next Right () -> runner next
CheckContentPresent k next -> do CheckContentPresent k next -> do
v <- tryNonAsync $ inAnnex k v <- tryNonAsync $ inAnnex k
case v of case v of
Left _ -> return Nothing Left e -> return (Left (show e))
Right result -> runner (next result) Right result -> runner (next result)
RemoveContent k next -> do RemoveContent k next -> do
v <- tryNonAsync $ lockContentForRemoval k $ \contentlock -> do v <- tryNonAsync $ lockContentForRemoval k $ \contentlock -> do
@ -97,7 +98,7 @@ runLocal runmode runner a = case a of
logStatus k InfoMissing logStatus k InfoMissing
return True return True
case v of case v of
Left _ -> return Nothing Left e -> return (Left (show e))
Right result -> runner (next result) Right result -> runner (next result)
TryLockContent k protoaction next -> do TryLockContent k protoaction next -> do
v <- tryNonAsync $ lockContentShared k $ \verifiedcopy -> 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 import qualified Data.ByteString.Lazy as L
-- Type of interpreters of the Proto free monad. -- 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 data P2PConnection = P2PConnection
{ connRepo :: Repo { connRepo :: Repo
@ -80,31 +80,31 @@ setupHandle s = do
-- This only runs Net actions. No Local actions will be run -- This only runs Net actions. No Local actions will be run
-- (those need the Annex monad) -- if the interpreter reaches any, -- (those need the Annex monad) -- if the interpreter reaches any,
-- it returns Nothing. -- it returns Nothing.
runNetProto :: P2PConnection -> Proto a -> IO (Maybe a) runNetProto :: P2PConnection -> Proto a -> IO (Either String a)
runNetProto conn = go runNetProto conn = go
where where
go :: RunProto IO 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 (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. -- Interpreter of the Net part of Proto.
-- --
-- An interpreter of Proto has to be provided, to handle the rest of Proto -- An interpreter of Proto has to be provided, to handle the rest of Proto
-- actions. -- 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 runNet conn runner f = case f of
SendMessage m next -> do SendMessage m next -> do
v <- liftIO $ tryNonAsync $ do v <- liftIO $ tryNonAsync $ do
hPutStrLn (connOhdl conn) (unwords (formatMessage m)) hPutStrLn (connOhdl conn) (unwords (formatMessage m))
hFlush (connOhdl conn) hFlush (connOhdl conn)
case v of case v of
Left _e -> return Nothing Left e -> return (Left (show e))
Right () -> runner next Right () -> runner next
ReceiveMessage next -> do ReceiveMessage next -> do
v <- liftIO $ tryNonAsync $ hGetLine (connIhdl conn) v <- liftIO $ tryNonAsync $ hGetLine (connIhdl conn)
case v of case v of
Left _e -> return Nothing Left e -> return (Left (show e))
Right l -> case parseMessage l of Right l -> case parseMessage l of
Just m -> runner (next m) Just m -> runner (next m)
Nothing -> runner $ do Nothing -> runner $ do
@ -118,11 +118,12 @@ runNet conn runner f = case f of
return ok return ok
case v of case v of
Right True -> runner next Right True -> runner next
_ -> return Nothing Right False -> return (Left "short data write")
Left e -> return (Left (show e))
ReceiveBytes len p next -> do ReceiveBytes len p next -> do
v <- liftIO $ tryNonAsync $ receiveExactly len (connIhdl conn) p v <- liftIO $ tryNonAsync $ receiveExactly len (connIhdl conn) p
case v of case v of
Left _e -> return Nothing Left e -> return (Left (show e))
Right b -> runner (next b) Right b -> runner (next b)
CheckAuthToken _u t next -> do CheckAuthToken _u t next -> do
let authed = connCheckAuth conn t let authed = connCheckAuth conn t
@ -130,13 +131,13 @@ runNet conn runner f = case f of
Relay hin hout next -> do Relay hin hout next -> do
v <- liftIO $ runRelay runnerio hin hout v <- liftIO $ runRelay runnerio hin hout
case v of case v of
Nothing -> return Nothing Left e -> return (Left e)
Just exitcode -> runner (next exitcode) Right exitcode -> runner (next exitcode)
RelayService service next -> do RelayService service next -> do
v <- liftIO $ runRelayService conn runnerio service v <- liftIO $ runRelayService conn runnerio service
case v of case v of
Nothing -> return Nothing Left e -> return (Left e)
Just () -> runner next Right () -> runner next
where where
-- This is only used for running Net actions when relaying, -- This is only used for running Net actions when relaying,
-- so it's ok to use runNetProto, despite it not supporting -- 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 -> Handle -> MeterUpdate -> IO L.ByteString
receiveExactly (Len n) h p = hGetMetered h (Just n) p receiveExactly (Len n) h p = hGetMetered h (Just n) p
runRelay :: RunProto IO -> RelayHandle -> RelayHandle -> IO (Maybe ExitCode) runRelay :: RunProto IO -> RelayHandle -> RelayHandle -> IO (Either String ExitCode)
runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go runRelay runner (RelayHandle hout) (RelayHandle hin) =
bracket setup cleanup go
`catchNonAsync` (return . Left . show)
where where
setup = do setup = do
v <- newEmptyMVar v <- newEmptyMVar
@ -177,8 +180,10 @@ runRelay runner (RelayHandle hout) (RelayHandle hin) = bracket setup cleanup go
go v = relayHelper runner v go v = relayHelper runner v
runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Maybe ()) runRelayService :: P2PConnection -> RunProto IO -> Service -> IO (Either String ())
runRelayService conn runner service = bracket setup cleanup go runRelayService conn runner service =
bracket setup cleanup go
`catchNonAsync` (return . Left . show)
where where
cmd = case service of cmd = case service of
UploadPack -> "upload-pack" UploadPack -> "upload-pack"
@ -209,13 +214,13 @@ runRelayService conn runner service = bracket setup cleanup go
go (v, _, _, _, _) = do go (v, _, _, _, _) = do
r <- relayHelper runner v r <- relayHelper runner v
case r of case r of
Nothing -> return Nothing Left e -> return (Left (show e))
Just exitcode -> runner $ net $ relayToPeer (RelayDone exitcode) Right exitcode -> runner $ net $ relayToPeer (RelayDone exitcode)
waitexit v pid = putMVar v . RelayDone =<< waitForProcess pid waitexit v pid = putMVar v . RelayDone =<< waitForProcess pid
-- Processes RelayData as it is put into the MVar. -- 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 relayHelper runner v = loop
where where
loop = do loop = do
@ -224,11 +229,11 @@ relayHelper runner v = loop
RelayToPeer b -> do RelayToPeer b -> do
r <- runner $ net $ relayToPeer (RelayToPeer b) r <- runner $ net $ relayToPeer (RelayToPeer b)
case r of case r of
Nothing -> return Nothing Left e -> return (Left e)
Just () -> loop Right () -> loop
RelayDone exitcode -> do RelayDone exitcode -> do
_ <- runner $ net $ relayToPeer (RelayDone exitcode) _ <- runner $ net $ relayToPeer (RelayDone exitcode)
return (Just exitcode) return (Right exitcode)
RelayFromPeer _ -> loop -- not handled here RelayFromPeer _ -> loop -- not handled here
-- Takes input from the peer, and sends it to the relay process's stdin. -- 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 loop = do
mrd <- runner $ net relayFromPeer mrd <- runner $ net relayFromPeer
case mrd of case mrd of
Nothing -> Left _e ->
putMVar v (RelayDone (ExitFailure 1)) putMVar v (RelayDone (ExitFailure 1))
Just (RelayDone exitcode) -> Right (RelayDone exitcode) ->
putMVar v (RelayDone exitcode) putMVar v (RelayDone exitcode)
Just (RelayFromPeer b) -> do Right (RelayFromPeer b) -> do
L.hPut hin b L.hPut hin b
hFlush hin hFlush hin
loop 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 -- Reads input from the Handle and puts it into the MVar for relaying to
-- the peer. Continues until EOF on the Handle. -- 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' :: P2P.Proto a -> Connection -> Annex (Connection, Maybe a)
runProto' _ ClosedConnection = return (ClosedConnection, Nothing) runProto' _ ClosedConnection = return (ClosedConnection, Nothing)
runProto' a (OpenConnection conn) = do runProto' a (OpenConnection conn) = do
r <- runFullProto Client conn a v <- runFullProto Client conn a
-- When runFullProto fails, the connection is no longer usable, -- When runFullProto fails, the connection is no longer usable,
-- so close it. -- so close it.
if isJust r case v of
then return (OpenConnection conn, r) Left e -> do
else do warning e
liftIO $ closeConnection conn 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; -- Uses an open connection if one is available in the ConnectionPool;
-- otherwise opens a new connection. -- otherwise opens a new connection.
@ -176,16 +177,20 @@ openConnection u addr = do
res <- liftIO $ runNetProto conn $ res <- liftIO $ runNetProto conn $
P2P.auth myuuid authtoken P2P.auth myuuid authtoken
case res of case res of
Just (Just theiruuid) Right (Just theiruuid)
| u == theiruuid -> return (OpenConnection conn) | u == theiruuid -> return (OpenConnection conn)
| otherwise -> do | otherwise -> do
liftIO $ closeConnection conn liftIO $ closeConnection conn
warning "Remote peer uuid seems to have changed." warning "Remote peer uuid seems to have changed."
return ClosedConnection return ClosedConnection
_ -> do Right Nothing -> do
liftIO $ closeConnection conn
warning "Unable to authenticate with peer." warning "Unable to authenticate with peer."
liftIO $ closeConnection conn
return ClosedConnection return ClosedConnection
Left _e -> do Left e -> do
warning "Unable to connect to peer." warning e
liftIO $ closeConnection conn
return ClosedConnection
Left e -> do
warning $ "Unable to connect to peer. (" ++ show e ++ ")"
return ClosedConnection 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 v <- liftIO $ runNetProto conn $ serveAuth u
case v of case v of
Just (Just theiruuid) -> void $ Right (Just theiruuid) -> void $
runFullProto (Serving theiruuid) conn $ runFullProto (Serving theiruuid) conn $
serveAuthed u 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. -- Merge the duplicated state back in.
liftAnnex th $ mergeState st' liftAnnex th $ mergeState st'
debugM "remotedaemon" "done with TOR connection" 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.. memory, more than I'd expect. Check if this is a memory leak..
* Resuming an interrupted transfer fails at the end, despite having gotten * Resuming an interrupted transfer fails at the end, despite having gotten
the whole correct file content. 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 * update progress logs in remotedaemon send/receive
* Think about locking some more. What happens if the connection to the peer * 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? is dropped while we think we're locking content there from being dropped?