diff options
Diffstat (limited to 'Remote/Helper')
| -rw-r--r-- | Remote/Helper/P2P.hs | 67 | ||||
| -rw-r--r-- | Remote/Helper/Ssh.hs | 98 |
2 files changed, 162 insertions, 3 deletions
diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs new file mode 100644 index 000000000..272489755 --- /dev/null +++ b/Remote/Helper/P2P.hs @@ -0,0 +1,67 @@ +{- Helpers for remotes using the git-annex P2P protocol. + - + - Copyright 2016-2018 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes #-} + +module Remote.Helper.P2P where + +import Annex.Common +import qualified P2P.Protocol as P2P +import P2P.IO +import Types.Remote +import Annex.Content +import Config.Cost +import Messages.Progress +import Utility.Metered +import Types.NumCopies + +import Control.Concurrent + +-- Runs a Proto action using a connection it sets up. +type ProtoRunner a = P2P.Proto a -> Annex (Maybe a) + +-- Runs a Proto action using a ClosableConnection. +type ProtoConnRunner c = forall a. P2P.Proto a -> ClosableConnection c -> Annex (ClosableConnection c, Maybe a) + +-- Runs an Annex action with a connection from the pool, adding it back to +-- the pool when done. +type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a + +store :: ProtoRunner Bool -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool +store runner k af p = do + let getsrcfile = fmap fst <$> prepSendAnnex k + metered (Just p) k getsrcfile $ \p' -> + fromMaybe False + <$> runner (P2P.put k af p') + +retrieve :: ProtoRunner Bool -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification) +retrieve runner k af dest p = unVerified $ + metered (Just p) k (return Nothing) $ \p' -> fromMaybe False + <$> runner (P2P.get dest k af p') + +remove :: ProtoRunner Bool -> Key -> Annex Bool +remove runner k = fromMaybe False <$> runner (P2P.remove k) + +checkpresent :: ProtoRunner Bool -> Key -> Annex Bool +checkpresent runner k = maybe unavail return =<< runner (P2P.checkPresent k) + where + unavail = giveup "can't connect to remote" + +lock :: WithConn a c -> ProtoConnRunner c -> UUID -> Key -> (VerifiedCopy -> Annex a) -> Annex a +lock withconn connrunner u k callback = withconn $ \conn -> do + connv <- liftIO $ newMVar conn + let runproto d p = do + c <- liftIO $ takeMVar connv + (c', mr) <- connrunner p c + liftIO $ putMVar connv c' + return (fromMaybe d mr) + r <- P2P.lockContentWhile runproto k go + conn' <- liftIO $ takeMVar connv + return (conn', r) + where + go False = giveup "can't lock content" + go True = withVerifiedCopy LockedCopy u (return True) callback diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index a4d91ab92..84a1ee8cc 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -1,6 +1,6 @@ {- git-annex remote access with ssh and git-annex-shell - - - Copyright 2011-2013 Joey Hess <id@joeyh.name> + - Copyright 2011-2018 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} @@ -23,6 +23,10 @@ import Utility.SshHost import Types.Remote import Types.Transfer import Config +import qualified P2P.Protocol as P2P +import qualified P2P.IO as P2P + +import Control.Concurrent.STM toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam]) toRepo cs r gc remotecmd = do @@ -91,9 +95,9 @@ onRemote cs r (with, errorval) command params fields = do inAnnex :: Git.Repo -> Key -> Annex Bool inAnnex r k = do showChecking r - onRemote NoConsumeStdin r (check, cantCheck r) "inannex" [Param $ key2file k] [] + onRemote NoConsumeStdin r (runcheck, cantCheck r) "inannex" [Param $ key2file k] [] where - check c p = dispatch =<< safeSystem c p + runcheck c p = dispatch =<< safeSystem c p dispatch ExitSuccess = return True dispatch (ExitFailure 1) = return False dispatch _ = cantCheck r @@ -179,3 +183,91 @@ rsyncParams r direction = do -- successfully locked. contentLockedMarker :: String contentLockedMarker = "OK" + +-- A connection over ssh to git-annex shell speaking the P2P protocol. +type P2PSshConnection = P2P.ClosableConnection (P2P.P2PConnection, ProcessHandle) + +closeP2PSshConnection :: P2PSshConnection -> IO P2PSshConnection +closeP2PSshConnection P2P.ClosedConnection = return P2P.ClosedConnection +closeP2PSshConnection (P2P.OpenConnection (conn, pid)) = do + P2P.closeConnection conn + void $ waitForProcess pid + return P2P.ClosedConnection + +-- Pool of connections over ssh to git-annex-shell p2pstdio. +type P2PSshConnectionPool = TVar (Maybe P2PSshConnectionPoolState) + +data P2PSshConnectionPoolState + = P2PSshConnections [P2PSshConnection] + -- Remotes using an old version of git-annex-shell don't support P2P + | P2PSshUnsupported + +mkP2PSshConnectionPool :: Annex P2PSshConnectionPool +mkP2PSshConnectionPool = liftIO $ newTVarIO Nothing + +-- Takes a connection from the pool, if any are available, otherwise +-- tries to open a new one. +getP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection) +getP2PSshConnection r connpool = getexistingconn >>= \case + Nothing -> return Nothing + Just Nothing -> openP2PSshConnection r connpool + Just (Just c) -> return (Just c) + where + getexistingconn = liftIO $ atomically $ readTVar connpool >>= \case + Just P2PSshUnsupported -> return Nothing + Just (P2PSshConnections (c:cs)) -> do + writeTVar connpool (Just (P2PSshConnections cs)) + return (Just (Just c)) + Just (P2PSshConnections []) -> return (Just Nothing) + Nothing -> return (Just Nothing) + +-- Add a connection to the pool, unless it's closed. +storeP2PSshConnection :: P2PSshConnectionPool -> P2PSshConnection -> IO () +storeP2PSshConnection _ P2P.ClosedConnection = return () +storeP2PSshConnection connpool conn = atomically $ modifyTVar' connpool $ \case + Just (P2PSshConnections cs) -> Just (P2PSshConnections (conn:cs)) + _ -> Just (P2PSshConnections [conn]) + +-- Try to open a P2PSshConnection. +-- The new connection is not added to the pool, so it's available +-- for the caller to use. +-- If the remote does not support the P2P protocol, that's remembered in +-- the connection pool. +openP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection) +openP2PSshConnection r connpool = do + u <- getUUID + let ps = [Param (fromUUID u)] + git_annex_shell ConsumeStdin (repo r) "p2pstdio" ps [] >>= \case + Nothing -> do + liftIO $ rememberunsupported + return Nothing + Just (cmd, params) -> start cmd params + where + start cmd params = liftIO $ withNullHandle $ \nullh -> do + -- stderr is discarded because old versions of git-annex + -- shell always error + (Just from, Just to, Nothing, pid) <- createProcess $ + (proc cmd (toCommand params)) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = UseHandle nullh + } + let conn = P2P.P2PConnection + { P2P.connRepo = repo r + , P2P.connCheckAuth = const False + , P2P.connIhdl = to + , P2P.connOhdl = from + } + let c = P2P.OpenConnection (conn, pid) + -- When the connection is successful, the remote + -- will send an AUTH_SUCCESS with its uuid. + tryNonAsync (P2P.runNetProto conn $ P2P.postAuth) >>= \case + Right (Right (Just theiruuid)) | theiruuid == uuid r -> + return $ Just c + _ -> do + void $ closeP2PSshConnection c + rememberunsupported + return Nothing + rememberunsupported = atomically $ + modifyTVar' connpool $ + maybe (Just P2PSshUnsupported) Just |