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

Followed example of Remote.S3.

diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs
index 0dc778b867719b87ee77eec1cd7fc81069df1be3..d89ad8c020fa9873a8ba30960532b26c1ab9ac88 100644 (file)
--- a/Assistant/WebApp/Configurators/WebDAV.hs
+++ b/Assistant/WebApp/Configurators/WebDAV.hs
@@ -15,7 +15,7 @@ import Creds
 import qualified Remote.WebDAV as WebDAV
 import Assistant.WebApp.MakeRemote
 import qualified Remote
-import Types.Remote (RemoteConfig)
+import Types.Remote (RemoteConfig, config)
 import Types.StandardGroups
 import Logs.Remote
 import Git.Types (RemoteName)
@@ -89,16 +89,16 @@ postEnableWebDAVR _ = giveup "WebDAV not supported by this build"
 
 #ifdef WITH_WEBDAV
 makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()
-makeWebDavRemote maker name creds config = 
+makeWebDavRemote maker name creds c = 
        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. -}
 previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)
 previouslyUsedWebDAVCreds hostname =
        previouslyUsedCredPair WebDAV.davCreds WebDAV.remote samehost
   where
-       samehost url = case urlHost =<< WebDAV.configUrl url of
+       samehost r = case urlHost =<< WebDAV.configUrl (config r) of
                Nothing -> False
                Just h -> h == hostname
 #endif

diff --git a/CHANGELOG b/CHANGELOG
index de59f8972766cd156c35919374af242f5aad335a..e08a365d0f6c9efd622d1df22e6754c173ee1fb4 100644 (file)
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,5 +1,7 @@
 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
     multiple times to git.
 

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

diff --git a/doc/bugs/webdav_export_slow__44___does_not_reuse_connections.mdwn b/doc/bugs/webdav_export_slow__44___does_not_reuse_connections.mdwn
index fd2f152f72d98c02b284a371f6e3f93b206a8359..0330909193ff6f037e6bc23294aef59daa48096f 100644 (file)
--- a/doc/bugs/webdav_export_slow__44___does_not_reuse_connections.mdwn
+++ b/doc/bugs/webdav_export_slow__44___does_not_reuse_connections.mdwn
@@ -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?
 
 [[!tag confirmed]]
+
+> [[fixed|done]] --[[Joey]]