diff options
-rw-r--r-- | CmdLine/GitRemoteTorAnnex.hs | 6 | ||||
-rw-r--r-- | Command/P2P.hs | 5 | ||||
-rw-r--r-- | P2P/Annex.hs | 17 | ||||
-rw-r--r-- | P2P/IO.hs | 59 | ||||
-rw-r--r-- | Remote/P2P.hs | 25 | ||||
-rw-r--r-- | RemoteDaemon/Transport/Tor.hs | 9 | ||||
-rw-r--r-- | doc/todo/tor.mdwn | 2 |
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 -> @@ -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? |