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

webdav: Made exporttree remotes faster by caching connection to the server

Browse source 
Followed example of Remote.S3.
This commit is contained in:
Joey Hess 2020-03-20 12:48:43 -04:00
parent 24255b3c96
commit 4b92bbe8d7
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 108 additions and 80 deletions
Download patch file Download diff file Expand all files Collapse all files

8
Assistant/WebApp/Configurators/WebDAV.hs
View file

@ -15,7 +15,7 @@ import Creds
import qualified Remote.WebDAV as WebDAV import qualified Remote.WebDAV as WebDAV
import Assistant.WebApp.MakeRemote import Assistant.WebApp.MakeRemote
import qualified Remote import qualified Remote
import Types.Remote (RemoteConfig) import Types.Remote (RemoteConfig, config)
import Types.StandardGroups import Types.StandardGroups
import Logs.Remote import Logs.Remote
import Git.Types (RemoteName) import Git.Types (RemoteName)
@ -89,16 +89,16 @@ postEnableWebDAVR _ = giveup "WebDAV not supported by this build"
#ifdef WITH_WEBDAV #ifdef WITH_WEBDAV
makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler () makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()
makeWebDavRemote maker name creds config = makeWebDavRemote maker name creds c =
setupCloudRemote TransferGroup Nothing $ setupCloudRemote TransferGroup Nothing $
maker name WebDAV.remote (Just creds) config maker name WebDAV.remote (Just creds) c
{- Only returns creds previously used for the same hostname. -} {- Only returns creds previously used for the same hostname. -}
previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair) previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)
previouslyUsedWebDAVCreds hostname = previouslyUsedWebDAVCreds hostname =
previouslyUsedCredPair WebDAV.davCreds WebDAV.remote samehost previouslyUsedCredPair WebDAV.davCreds WebDAV.remote samehost
where where
samehost url = case urlHost =<< WebDAV.configUrl url of samehost r = case urlHost =<< WebDAV.configUrl (config r) of
Nothing -> False Nothing -> False
Just h -> h == hostname Just h -> h == hostname
#endif #endif

2
CHANGELOG
View file

@ -1,5 +1,7 @@
git-annex (8.20200310) UNRELEASED; urgency=medium git-annex (8.20200310) UNRELEASED; urgency=medium
* webdav: Made exporttree remotes faster by caching connection to the
server.
* Fix a minor bug that caused options provided with -c to be passed * Fix a minor bug that caused options provided with -c to be passed
multiple times to git. multiple times to git.

176
Remote/WebDAV.hs
View file

@ -22,6 +22,7 @@ import System.IO.Error
import Control.Monad.Catch import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import System.Log.Logger (debugM) import System.Log.Logger (debugM)
import Control.Concurrent.STM hiding (check)
import Annex.Common import Annex.Common
import Types.Remote import Types.Remote
@ -64,15 +65,18 @@ davcredsField :: RemoteConfigField
davcredsField = Accepted "davcreds" davcredsField = Accepted "davcreds"
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u rc gc rs = new gen r u rc gc rs = do
<$> parsedRemoteConfig remote rc c <- parsedRemoteConfig remote rc
<*> remoteCost gc expensiveRemoteCost new
<$> pure c
<*> remoteCost gc expensiveRemoteCost
<*> mkDavHandleVar c gc u
where where
new c cst = Just $ specialRemote c new c cst hdl = Just $ specialRemote c
(prepareDAV this $ store chunkconfig) (simplyPrepare $ store hdl chunkconfig)
(prepareDAV this $ retrieve chunkconfig) (simplyPrepare $ retrieve hdl chunkconfig)
(prepareDAV this $ remove) (simplyPrepare $ remove hdl)
(prepareDAV this $ checkKey this chunkconfig) (simplyPrepare $ checkKey hdl this chunkconfig)
this this
where where
this = Remote this = Remote
@ -90,13 +94,13 @@ gen r u rc gc rs = new
, checkPresent = checkPresentDummy , checkPresent = checkPresentDummy
, checkPresentCheap = False , checkPresentCheap = False
, exportActions = ExportActions , exportActions = ExportActions
{ storeExport = storeExportDav this { storeExport = storeExportDav hdl
, retrieveExport = retrieveExportDav this , retrieveExport = retrieveExportDav hdl
, checkPresentExport = checkPresentExportDav this , checkPresentExport = checkPresentExportDav hdl this
, removeExport = removeExportDav this , removeExport = removeExportDav hdl
, removeExportDirectory = Just $ , removeExportDirectory = Just $
removeExportDirectoryDav this removeExportDirectoryDav hdl
, renameExport = renameExportDav this , renameExport = renameExportDav hdl
} }
, importActions = importUnsupported , importActions = importUnsupported
, whereisKey = Nothing , whereisKey = Nothing
@ -133,18 +137,20 @@ webdavSetup _ mu mcreds c gc = do
c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds
return (c'', u) return (c'', u)
prepareDAV :: Remote -> (Maybe DavHandle -> helper) -> Preparer helper store :: DavHandleVar -> ChunkConfig -> Storer
prepareDAV = resourcePrepare . const . withDAVHandle store hv (LegacyChunks chunksize) = fileStorer $ \k f p ->
withDavHandle hv $ \case
store :: ChunkConfig -> Maybe DavHandle -> Storer Nothing -> return False
store _ Nothing = byteStorer $ \_k _b _p -> return False Just dav -> liftIO $
store (LegacyChunks chunksize) (Just dav) = fileStorer $ \k f p -> liftIO $ withMeteredFile f p $ storeLegacyChunked chunksize k dav
withMeteredFile f p $ storeLegacyChunked chunksize k dav store hv _ = httpStorer $ \k reqbody ->
store _ (Just dav) = httpStorer $ \k reqbody -> liftIO $ goDAV dav $ do withDavHandle hv $ \case
let tmp = keyTmpLocation k Nothing -> return False
let dest = keyLocation k Just dav -> liftIO $ goDAV dav $ do
storeHelper dav tmp dest reqbody let tmp = keyTmpLocation k
return True let dest = keyLocation k
storeHelper dav tmp dest reqbody
return True
storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO () storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO ()
storeHelper dav tmp dest reqbody = do storeHelper dav tmp dest reqbody = do
@ -164,11 +170,14 @@ finalizeStore dav tmp dest = do
retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False retrieveCheap _ _ _ = return False
retrieve :: ChunkConfig -> Maybe DavHandle -> Retriever retrieve :: DavHandleVar -> ChunkConfig -> Retriever
retrieve _ Nothing = giveup "unable to connect" retrieve hv cc = fileRetriever $ \d k p ->
retrieve (LegacyChunks _) (Just dav) = retrieveLegacyChunked dav withDavHandle hv $ \case
retrieve _ (Just dav) = fileRetriever $ \d k p -> liftIO $ Nothing -> giveup "unable to connect"
goDAV dav $ retrieveHelper (keyLocation k) d p Just dav -> case cc of
LegacyChunks _ -> retrieveLegacyChunked d k p dav
_ -> liftIO $
goDAV dav $ retrieveHelper (keyLocation k) d p
retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO () retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO ()
retrieveHelper loc d p = do retrieveHelper loc d p = do
@ -176,12 +185,13 @@ retrieveHelper loc d p = do
inLocation loc $ inLocation loc $
withContentM $ httpBodyRetriever d p withContentM $ httpBodyRetriever d p
remove :: Maybe DavHandle -> Remover remove :: DavHandleVar -> Remover
remove Nothing _ = return False remove hv k = withDavHandle hv $ \case
remove (Just dav) k = liftIO $ goDAV dav $ Nothing -> return False
-- Delete the key's whole directory, including any Just dav -> liftIO $ goDAV dav $
-- legacy chunked files, etc, in a single action. -- Delete the key's whole directory, including any
removeHelper (keyDir k) -- legacy chunked files, etc, in a single action.
removeHelper (keyDir k)
removeHelper :: DavLocation -> DAVT IO Bool removeHelper :: DavLocation -> DAVT IO Bool
removeHelper d = do removeHelper d = do
@ -195,20 +205,21 @@ removeHelper d = do
Right False -> return True Right False -> return True
_ -> return False _ -> return False
checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent checkKey :: DavHandleVar -> Remote -> ChunkConfig -> CheckPresent
checkKey r _ Nothing _ = giveup $ name r ++ " not configured" checkKey hv r chunkconfig k = withDavHandle hv $ \case
checkKey r chunkconfig (Just dav) k = do Nothing -> giveup $ name r ++ " not configured"
showChecking r Just dav -> do
case chunkconfig of showChecking r
LegacyChunks _ -> checkKeyLegacyChunked dav k case chunkconfig of
_ -> do LegacyChunks _ -> checkKeyLegacyChunked dav k
v <- liftIO $ goDAV dav $ _ -> do
existsDAV (keyLocation k) v <- liftIO $ goDAV dav $
either giveup return v existsDAV (keyLocation k)
either giveup return v
storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool storeExportDav :: DavHandleVar -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
storeExportDav r f k loc p = case exportLocation loc of storeExportDav hdl f k loc p = case exportLocation loc of
Right dest -> withDAVHandle r $ \mh -> runExport mh $ \dav -> do Right dest -> withDavHandle hdl $ \mh -> runExport mh $ \dav -> do
reqbody <- liftIO $ httpBodyStorer f p reqbody <- liftIO $ httpBodyStorer f p
storeHelper dav (keyTmpLocation k) dest reqbody storeHelper dav (keyTmpLocation k) dest reqbody
return True return True
@ -216,25 +227,25 @@ storeExportDav r f k loc p = case exportLocation loc of
warning err warning err
return False return False
retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
retrieveExportDav r _k loc d p = case exportLocation loc of retrieveExportDav hdl _k loc d p = case exportLocation loc of
Right src -> withDAVHandle r $ \mh -> runExport mh $ \_dav -> do Right src -> withDavHandle hdl $ \mh -> runExport mh $ \_dav -> do
retrieveHelper src d p retrieveHelper src d p
return True return True
Left _err -> return False Left _err -> return False
checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool checkPresentExportDav :: DavHandleVar -> Remote -> Key -> ExportLocation -> Annex Bool
checkPresentExportDav r _k loc = case exportLocation loc of checkPresentExportDav hdl r _k loc = case exportLocation loc of
Right p -> withDAVHandle r $ \case Right p -> withDavHandle hdl $ \case
Nothing -> giveup $ name r ++ " not configured" Nothing -> giveup $ name r ++ " not configured"
Just h -> liftIO $ do Just h -> liftIO $ do
v <- goDAV h $ existsDAV p v <- goDAV h $ existsDAV p
either giveup return v either giveup return v
Left err -> giveup err Left err -> giveup err
removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool removeExportDav :: DavHandleVar-> Key -> ExportLocation -> Annex Bool
removeExportDav r _k loc = case exportLocation loc of removeExportDav hdl _k loc = case exportLocation loc of
Right p -> withDAVHandle r $ \mh -> runExport mh $ \_dav -> Right p -> withDavHandle hdl $ \mh -> runExport mh $ \_dav ->
removeHelper p removeHelper p
-- When the exportLocation is not legal for webdav, -- When the exportLocation is not legal for webdav,
-- the content is certianly not stored there, so it's ok for -- the content is certianly not stored there, so it's ok for
@ -243,16 +254,16 @@ removeExportDav r _k loc = case exportLocation loc of
-- this will be called to make sure it's gone. -- this will be called to make sure it's gone.
Left _err -> return True Left _err -> return True
removeExportDirectoryDav :: Remote -> ExportDirectory -> Annex Bool removeExportDirectoryDav :: DavHandleVar -> ExportDirectory -> Annex Bool
removeExportDirectoryDav r dir = withDAVHandle r $ \mh -> runExport mh $ \_dav -> do removeExportDirectoryDav hdl dir = withDavHandle hdl $ \mh -> runExport mh $ \_dav -> do
let d = fromRawFilePath $ fromExportDirectory dir let d = fromRawFilePath $ fromExportDirectory dir
debugDav $ "delContent " ++ d debugDav $ "delContent " ++ d
safely (inLocation d delContentM) safely (inLocation d delContentM)
>>= maybe (return False) (const $ return True) >>= maybe (return False) (const $ return True)
renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool) renameExportDav :: DavHandleVar -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe Bool)
renameExportDav r _k src dest = case (exportLocation src, exportLocation dest) of renameExportDav hdl _k src dest = case (exportLocation src, exportLocation dest) of
(Right srcl, Right destl) -> withDAVHandle r $ \case (Right srcl, Right destl) -> withDavHandle hdl $ \case
Just h Just h
-- box.com's DAV endpoint has buggy handling of renames, -- box.com's DAV endpoint has buggy handling of renames,
-- so avoid renaming when using it. -- so avoid renaming when using it.
@ -270,8 +281,8 @@ runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool
runExport Nothing _ = return False runExport Nothing _ = return False
runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h)) runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))
configUrl :: Remote -> Maybe URLString configUrl :: ParsedRemoteConfig -> Maybe URLString
configUrl r = fixup <$> getRemoteConfigValue urlField (config r) configUrl c = fixup <$> getRemoteConfigValue urlField c
where where
-- box.com DAV url changed -- box.com DAV url changed
fixup = replace "https://www.box.com/dav/" boxComUrl fixup = replace "https://www.box.com/dav/" boxComUrl
@ -407,14 +418,27 @@ choke f = do
data DavHandle = DavHandle DAVContext DavUser DavPass URLString data DavHandle = DavHandle DAVContext DavUser DavPass URLString
withDAVHandle :: Remote -> (Maybe DavHandle -> Annex a) -> Annex a type DavHandleVar = TVar (Either (Annex (Maybe DavHandle)) (Maybe DavHandle))
withDAVHandle r a = do
mcreds <- getCreds (config r) (gitconfig r) (uuid r) {- Prepares a DavHandle for later use. Does not connect to the server or do
case (mcreds, configUrl r) of - anything else expensive. -}
(Just (user, pass), Just baseurl) -> mkDavHandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex DavHandleVar
withDAVContext baseurl $ \ctx -> mkDavHandleVar c gc u = liftIO $ newTVarIO $ Left $ do
a (Just (DavHandle ctx (toDavUser user) (toDavPass pass) baseurl)) mcreds <- getCreds c gc u
_ -> a Nothing case (mcreds, configUrl c) of
(Just (user, pass), Just baseurl) -> do
ctx <- mkDAVContext baseurl
let h = DavHandle ctx (toDavUser user) (toDavPass pass) baseurl
return (Just h)
_ -> return Nothing
withDavHandle :: DavHandleVar -> (Maybe DavHandle -> Annex a) -> Annex a
withDavHandle hv a = liftIO (readTVarIO hv) >>= \case
Right hdl -> a hdl
Left mkhdl -> do
hdl <- mkhdl
liftIO $ atomically $ writeTVar hv (Right hdl)
a hdl
goDAV :: DavHandle -> DAVT IO a -> IO a goDAV :: DavHandle -> DAVT IO a -> IO a
goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do
@ -464,8 +488,8 @@ storeLegacyChunked chunksize k dav b =
tmp = addTrailingPathSeparator $ keyTmpLocation k tmp = addTrailingPathSeparator $ keyTmpLocation k
dest = keyLocation k dest = keyLocation k
retrieveLegacyChunked :: DavHandle -> Retriever retrieveLegacyChunked :: FilePath -> Key -> MeterUpdate -> DavHandle -> Annex ()
retrieveLegacyChunked dav = fileRetriever $ \d k p -> liftIO $ retrieveLegacyChunked d k p dav = liftIO $
withStoredFilesLegacyChunked k dav onerr $ \locs -> withStoredFilesLegacyChunked k dav onerr $ \locs ->
Legacy.meteredWriteFileChunks p d locs $ \l -> Legacy.meteredWriteFileChunks p d locs $ \l ->
goDAV dav $ do goDAV dav $ do

2
doc/bugs/webdav_export_slow__44___does_not_reuse_connections.mdwn
View file

@ -11,3 +11,5 @@ Could multiple files be uploaded in parallel?
Apparently files are also upload to a temporary location and renamed after successful upload. This adds additional latency and thus parallel uploads could provide a speed up? Apparently files are also upload to a temporary location and renamed after successful upload. This adds additional latency and thus parallel uploads could provide a speed up?
[[!tag confirmed]] [[!tag confirmed]]
> [[fixed|done]] --[[Joey]]