From d9b80aca317a2484df5922d589b7b5e3bc30aa4a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 12 Sep 2017 14:08:00 -0400 Subject: export to webdav This basically works, but there's a bug when renaming a file that leaves a .git-annex-temp-content-key file in the webdav store, that never gets cleaned up. Also, exporting files with spaces to box.com seems to fail; perhaps it does not support it? This commit was supported by the NSF-funded DataLad project. --- Remote/WebDAV.hs | 96 ++++++++++++++++++++++++++++++++------------ Remote/WebDAV/DavLocation.hs | 7 ++++ 2 files changed, 77 insertions(+), 26 deletions(-) (limited to 'Remote') diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 4cc3c92e0..04eb35cef 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -1,6 +1,6 @@ {- WebDAV remotes. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -15,7 +15,7 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.UTF8 as B8 import qualified Data.ByteString.Lazy.UTF8 as L8 -import Network.HTTP.Client (HttpException(..)) +import Network.HTTP.Client (HttpException(..), RequestBody) import Network.HTTP.Types import System.IO.Error import Control.Monad.Catch @@ -46,7 +46,7 @@ remote = RemoteType , enumerate = const (findSpecialRemotes "webdav") , generate = gen , setup = webdavSetup - , exportSupported = exportUnsupported + , exportSupported = exportIsSupported } gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) @@ -70,7 +70,13 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost , lockContent = Nothing , checkPresent = checkPresentDummy , checkPresentCheap = False - , exportActions = exportUnsupported + , exportActions = ExportActions + { storeExport = storeExportDav this + , retrieveExport = retrieveExportDav this + , removeExport = removeExportDav this + , checkPresentExport = checkPresentExportDav this + , renameExport = renameExportDav this + } , whereisKey = Nothing , remoteFsck = Nothing , repairRepo = Nothing @@ -114,17 +120,21 @@ store (LegacyChunks chunksize) (Just dav) = fileStorer $ \k f p -> liftIO $ 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 + +storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO () +storeHelper dav tmp dest reqbody = do void $ mkColRecursive tmpDir inLocation tmp $ putContentM' (contentType, reqbody) - finalizeStore (baseURL dav) tmp dest - return True + finalizeStore dav tmp dest -finalizeStore :: URLString -> DavLocation -> DavLocation -> DAVT IO () -finalizeStore baseurl tmp dest = do +finalizeStore :: DavHandle -> DavLocation -> DavLocation -> DAVT IO () +finalizeStore dav tmp dest = do inLocation dest $ void $ safely $ delContentM maybe noop (void . mkColRecursive) (locationParent dest) - moveDAV baseurl tmp dest + moveDAV (baseURL dav) tmp dest retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False @@ -133,26 +143,29 @@ 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 $ - inLocation (keyLocation k) $ - withContentM $ - httpBodyRetriever d p + goDAV dav $ retrieveHelper (keyLocation k) d p + +retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO () +retrieveHelper loc d p = inLocation loc $ + withContentM $ httpBodyRetriever d p remove :: Maybe DavHandle -> Remover remove Nothing _ = return False -remove (Just dav) k = liftIO $ do +remove (Just dav) k = liftIO $ goDAV dav $ -- Delete the key's whole directory, including any -- legacy chunked files, etc, in a single action. - let d = keyDir k - goDAV dav $ do - v <- safely $ inLocation d delContentM - case v of - Just _ -> return True - Nothing -> do - v' <- existsDAV d - case v' of - Right False -> return True - _ -> return False + removeHelper (keyDir k) + +removeHelper :: DavLocation -> DAVT IO Bool +removeHelper d = do + v <- safely $ inLocation d delContentM + case v of + Just _ -> return True + Nothing -> do + v' <- existsDAV d + case v' of + Right False -> return True + _ -> return False checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent checkKey r _ Nothing _ = giveup $ name r ++ " not configured" @@ -165,6 +178,38 @@ checkKey r chunkconfig (Just dav) k = do existsDAV (keyLocation k) either giveup return v +storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool +storeExportDav r f _k loc p = runExport r $ \dav -> do + reqbody <- liftIO $ httpBodyStorer f p + storeHelper dav (exportTmpLocation loc) (exportLocation loc) reqbody + return True + +retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool +retrieveExportDav r _k loc d p = runExport r $ \_dav -> do + retrieveHelper (exportLocation loc) d p + return True + +removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool +removeExportDav r _k loc = runExport r $ \_dav -> + removeHelper (exportLocation loc) + +checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool +checkPresentExportDav r _k loc = withDAVHandle r $ \mh -> case mh of + Nothing -> giveup $ name r ++ " not configured" + Just h -> liftIO $ do + v <- goDAV h $ existsDAV (exportLocation loc) + either giveup return v + +renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool +renameExportDav r _k src dest = runExport r $ \dav -> do + moveDAV (baseURL dav) (exportLocation src) (exportLocation dest) + return True + +runExport :: Remote -> (DavHandle -> DAVT IO Bool) -> Annex Bool +runExport r a = withDAVHandle r $ \mh -> case mh of + Nothing -> return False + Just h -> fromMaybe False <$> liftIO (goDAV h $ safely (a h)) + configUrl :: Remote -> Maybe URLString configUrl r = fixup <$> M.lookup "url" (config r) where @@ -278,7 +323,6 @@ existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e)) (const $ ispresent False) ispresent = return . Right --- Ignores any exceptions when performing a DAV action. safely :: DAVT IO a -> DAVT IO (Maybe a) safely = eitherToMaybe <$$> tryNonAsync @@ -351,7 +395,7 @@ storeLegacyChunked chunksize k dav b = storer locs = Legacy.storeChunked chunksize locs storehttp b recorder l s = storehttp l (L8.fromString s) finalizer tmp' dest' = goDAV dav $ - finalizeStore (baseURL dav) tmp' (fromJust $ locationParent dest') + finalizeStore dav tmp' (fromJust $ locationParent dest') tmp = addTrailingPathSeparator $ keyTmpLocation k dest = keyLocation k diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs index daa669de1..82a3739d0 100644 --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -11,6 +11,7 @@ module Remote.WebDAV.DavLocation where import Types +import Types.Remote (ExportLocation(..)) import Annex.Locations import Utility.Url (URLString) #ifdef mingw32_HOST_OS @@ -46,6 +47,12 @@ keyLocation k = keyDir k ++ keyFile k keyTmpLocation :: Key -> DavLocation keyTmpLocation = tmpLocation . keyFile +exportLocation :: ExportLocation -> DavLocation +exportLocation (ExportLocation f) = f + +exportTmpLocation :: ExportLocation -> DavLocation +exportTmpLocation (ExportLocation f) = tmpLocation f + tmpLocation :: FilePath -> DavLocation tmpLocation f = tmpDir f -- cgit v1.2.3