diff options
| -rw-r--r-- | Remote/WebDAV.hs | 229 | ||||
| -rw-r--r-- | Remote/WebDAV/DavLocation.hs | 59 | ||||
| -rw-r--r-- | Remote/WebDAV/DavUrl.hs | 44 | ||||
| -rw-r--r-- | debian/changelog | 4 | ||||
| -rw-r--r-- | debian/control | 2 | ||||
| -rw-r--r-- | git-annex.cabal | 4 |
6 files changed, 180 insertions, 162 deletions
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 6679242e5..a77deffc5 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -11,14 +11,12 @@ module Remote.WebDAV (remote, davCreds, configUrl) where import Network.Protocol.HTTP.DAV 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 qualified Data.ByteString.Lazy as L -import qualified Control.Exception as E import qualified Control.Exception.Lifted as EL import Network.HTTP.Client (HttpException(..)) import Network.HTTP.Types -import System.Log.Logger (debugM) import System.IO.Error import Common.Annex @@ -30,8 +28,9 @@ import Remote.Helper.Special import qualified Remote.Helper.Chunked.Legacy as Legacy import Creds import Utility.Metered +import Utility.Url (URLString) import Annex.UUID -import Remote.WebDAV.DavUrl +import Remote.WebDAV.DavLocation type DavUser = B8.ByteString type DavPass = B8.ByteString @@ -95,26 +94,34 @@ prepareStore r chunkconfig = simplyPrepare $ fileStorer $ \k f p -> withMeteredFile f p $ storeHelper chunkconfig k baseurl user pass -storeHelper :: ChunkConfig -> Key -> DavUrl -> DavUser -> DavPass -> L.ByteString -> IO Bool +storeHelper :: ChunkConfig -> Key -> URLString -> DavUser -> DavPass -> L.ByteString -> IO Bool storeHelper chunkconfig k baseurl user pass b = do - mkdirRecursiveDAV tmpurl user pass case chunkconfig of LegacyChunks chunksize -> do - let storer urls = Legacy.storeChunked chunksize urls storehttp b - let recorder url s = storehttp url (L8.fromString s) - Legacy.storeChunks k tmpurl keyurl storer recorder finalizer - _ -> do - storehttp tmpurl b - finalizer tmpurl keyurl + let storehttp l b' = do + void $ goDAV baseurl user pass $ do + maybe noop (void . mkColRecursive) (locationParent l) + inLocation l $ putContentM (contentType, b') + let storer locs = Legacy.storeChunked chunksize locs storehttp b + let recorder l s = storehttp l (L8.fromString s) + let finalizer tmp' dest' = goDAV baseurl user pass $ + finalizeStore baseurl tmp' (fromJust $ locationParent dest') + Legacy.storeChunks k tmp dest storer recorder finalizer + _ -> goDAV baseurl user pass $ do + void $ mkColRecursive tmpDir + inLocation tmp $ + putContentM (contentType, b) + finalizeStore baseurl tmp dest return True where - tmpurl = tmpLocation baseurl k - keyurl = davLocation baseurl k - finalizer srcurl desturl = do - void $ tryNonAsync (deleteDAV desturl user pass) - mkdirRecursiveDAV (urlParent desturl) user pass - moveDAV srcurl desturl user pass - storehttp url = putDAV url user pass + tmp = keyTmpLocation k + dest = keyLocation k ++ keyFile k + +finalizeStore :: URLString -> DavLocation -> DavLocation -> DAVT IO () +finalizeStore baseurl tmp dest = do + inLocation dest $ void $ safely $ delContentM + maybe noop (void . mkColRecursive) (locationParent dest) + moveDAV baseurl tmp dest retrieveCheap :: Key -> FilePath -> Annex Bool retrieveCheap _ _ = return False @@ -122,9 +129,11 @@ retrieveCheap _ _ = return False prepareRetrieve :: Remote -> ChunkConfig -> Preparer Retriever prepareRetrieve r chunkconfig = simplyPrepare $ fileRetriever $ \d k p -> davAction r onerr $ \(baseurl, user, pass) -> liftIO $ - withStoredFiles chunkconfig k baseurl user pass onerr $ \urls -> do - Legacy.meteredWriteFileChunks p d urls $ \url -> do - mb <- getDAV url user pass + withStoredFiles chunkconfig k baseurl user pass onerr $ \locs -> do + Legacy.meteredWriteFileChunks p d locs $ \l -> do + mb <- goDAV baseurl user pass $ safely $ + inLocation l $ + snd <$> getContentM case mb of Nothing -> onerr Just b -> return b @@ -136,8 +145,9 @@ prepareRemove r = simplyPrepare $ \k -> davAction r False $ \(baseurl, user, pass) -> liftIO $ do -- Delete the key's whole directory, including any -- legacy chunked files, etc, in a single action. - let url = davLocation baseurl k - isJust . eitherToMaybe <$> tryNonAsync (deleteDAV url user pass) + ret <- goDAV baseurl user pass $ safely $ + inLocation (keyLocation k) delContentM + return (isJust ret) prepareCheckPresent :: Remote -> ChunkConfig -> Preparer CheckPresent prepareCheckPresent r chunkconfig = simplyPrepare $ checkKey r chunkconfig @@ -152,46 +162,49 @@ checkKey r chunkconfig k = davAction r noconn (either error id <$$> go) liftIO $ withStoredFiles chunkconfig k baseurl user pass onerr check where check [] = return $ Right True - check (url:urls) = do - v <- existsDAV url user pass + check (l:ls) = do + v <- goDAV baseurl user pass $ existsDAV l if v == Right True - then check urls + then check ls else return v {- Failed to read the chunkcount file; see if it's missing, - or if there's a problem accessing it, - - or perhaps this was an intermittent error. -} - onerr url = do - v <- existsDAV url user pass + - or perhaps this was an intermittent error. -} + onerr f = do + v <- goDAV baseurl user pass $ existsDAV f return $ if v == Right True - then Left $ "failed to read " ++ url + then Left $ "failed to read " ++ f else v withStoredFiles :: ChunkConfig -> Key - -> DavUrl + -> URLString -> DavUser -> DavPass - -> (DavUrl -> IO a) - -> ([DavUrl] -> IO a) + -> (DavLocation -> IO a) + -> ([DavLocation] -> IO a) -> IO a withStoredFiles chunkconfig k baseurl user pass onerr a = case chunkconfig of LegacyChunks _ -> do - let chunkcount = keyurl ++ Legacy.chunkCount - v <- getDAV chunkcount user pass + let chunkcount = keyloc ++ Legacy.chunkCount + v <- goDAV baseurl user pass $ safely $ + inLocation chunkcount $ + snd <$> getContentM case v of - Just s -> a $ Legacy.listChunks keyurl $ L8.toString s + Just s -> a $ Legacy.listChunks keyloc $ L8.toString s Nothing -> do - chunks <- Legacy.probeChunks keyurl $ \u -> (== Right True) <$> existsDAV u user pass + chunks <- Legacy.probeChunks keyloc $ \f -> + (== Right True) <$> goDAV baseurl user pass (existsDAV f) if null chunks then onerr chunkcount else a chunks - _ -> a [keyurl] + _ -> a [keyloc] where - keyurl = davLocation baseurl k ++ keyFile k + keyloc = keyLocation k ++ keyFile k -davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a +davAction :: Remote -> a -> ((DavLocation, DavUser, DavPass) -> Annex a) -> Annex a davAction r unconfigured action = do mcreds <- getCreds (config r) (uuid r) case (mcreds, configUrl r) of @@ -199,7 +212,7 @@ davAction r unconfigured action = do action (url, toDavUser user, toDavPass pass) _ -> return unconfigured -configUrl :: Remote -> Maybe DavUrl +configUrl :: Remote -> Maybe URLString configUrl r = fixup <$> M.lookup "url" (config r) where -- box.com DAV url changed @@ -211,47 +224,63 @@ toDavUser = B8.fromString toDavPass :: String -> DavPass toDavPass = B8.fromString -{- Creates a directory in WebDAV, if not already present; also creating - - any missing parent directories. -} -mkdirRecursiveDAV :: DavUrl -> DavUser -> DavPass -> IO () -mkdirRecursiveDAV url user pass = go url - where - make u = mkdirDAV u user pass - - go u = do - r <- E.try (make u) :: IO (Either E.SomeException Bool) - case r of - {- Parent directory is missing. Recurse to create - - it, and try once more to create the directory. -} - Right False -> do - go (urlParent u) - void $ make u - {- Directory created successfully -} - Right True -> return () - {- Directory already exists, or some other error - - occurred. In the latter case, whatever wanted - - to use this directory will fail. -} - Left _ -> return () - {- Test if a WebDAV store is usable, by writing to a test file, and then - - deleting the file. Exits with an IO error if not. -} -testDav :: String -> Maybe CredPair -> Annex () -testDav baseurl (Just (u, p)) = do + - deleting the file. + - + - Also ensures that the path of the url exists, trying to create it if not. + - + - Throws an error if store is not usable. + -} +testDav :: URLString -> Maybe CredPair -> Annex () +testDav url (Just (u, p)) = do showSideAction "testing WebDAV server" - test "make directory" $ mkdirRecursiveDAV baseurl user pass - test "write file" $ putDAV testurl user pass L.empty - test "delete file" $ deleteDAV testurl user pass + test $ liftIO $ goDAV url user pass $ do + makeParentDirs + inLocation tmpDir $ void mkCol + inLocation (tmpLocation "git-annex-test") $ do + putContentM (Nothing, L.empty) + delContentM where - test desc a = liftIO $ - either (\e -> throwIO $ "WebDAV failed to " ++ desc ++ ": " ++ show e) + test a = liftIO $ + either (\e -> throwIO $ "WebDAV test failed: " ++ show e) (const noop) =<< tryNonAsync a user = toDavUser u pass = toDavPass p - testurl = davUrl baseurl "git-annex-test" testDav _ Nothing = error "Need to configure webdav username and password." +{- Tries to make all the parent directories in the WebDAV urls's path, + - right down to the root. + - + - Ignores any failures, which can occur for reasons including the WebDAV + - server only serving up WebDAV in a subdirectory. -} +makeParentDirs :: DAVT IO () +makeParentDirs = go + where + go = do + l <- getDAVLocation + case locationParent l of + Nothing -> noop + Just p -> void $ safely $ inDAVLocation (const p) go + void $ safely mkCol + +{- Checks if the directory exists. If not, tries to create its + - parent directories, all the way down to the root, and finally creates + - it. -} +mkColRecursive :: DavLocation -> DAVT IO Bool +mkColRecursive d = go =<< existsDAV d + where + go (Right True) = return True + go _ = ifM (inLocation d mkCol) + ( return True + , do + case locationParent d of + Nothing -> makeParentDirs + Just parent -> void (mkColRecursive parent) + inLocation d mkCol + ) + getCreds :: RemoteConfig -> UUID -> Annex (Maybe CredPair) getCreds c u = getRemoteCredPairFor "webdav" c (davCreds u) @@ -269,54 +298,21 @@ contentType = Just $ B8.fromString "application/octet-stream" throwIO :: String -> IO a throwIO msg = ioError $ mkIOError userErrorType msg Nothing Nothing -debugDAV :: DavUrl -> String -> IO () -debugDAV msg url = debugM "DAV" $ msg ++ " " ++ url - -{--------------------------------------------------------------------- - - Low-level DAV operations. - ---------------------------------------------------------------------} - -putDAV :: DavUrl -> DavUser -> DavPass -> L.ByteString -> IO () -putDAV url user pass b = do - debugDAV "PUT" url - goDAV url user pass $ putContentM (contentType, b) - -getDAV :: DavUrl -> DavUser -> DavPass -> IO (Maybe L.ByteString) -getDAV url user pass = do - debugDAV "GET" url - eitherToMaybe <$> tryNonAsync go +moveDAV :: URLString -> DavLocation -> DavLocation -> DAVT IO () +moveDAV baseurl src dest = inLocation src $ moveContentM newurl where - go = goDAV url user pass $ snd <$> getContentM - -deleteDAV :: DavUrl -> DavUser -> DavPass -> IO () -deleteDAV url user pass = do - debugDAV "DELETE" url - goDAV url user pass delContentM + newurl = B8.fromString (locationUrl baseurl dest) -moveDAV :: DavUrl -> DavUrl -> DavUser -> DavPass -> IO () -moveDAV url newurl user pass = do - debugDAV ("MOVE to " ++ newurl ++ " from ") url - goDAV url user pass $ moveContentM newurl' +existsDAV :: DavLocation -> DAVT IO (Either String Bool) +existsDAV l = inLocation l check `EL.catch` (\(e :: EL.SomeException) -> return (Left $ show e)) where - newurl' = B8.fromString newurl - -mkdirDAV :: DavUrl -> DavUser -> DavPass -> IO Bool -mkdirDAV url user pass = do - debugDAV "MKDIR" url - goDAV url user pass mkCol - -existsDAV :: DavUrl -> DavUser -> DavPass -> IO (Either String Bool) -existsDAV url user pass = do - debugDAV "EXISTS" url - either (Left . show) id <$> tryNonAsync check - where - ispresent = return . Right - check = goDAV url user pass $ do + check = do setDepth Nothing EL.catchJust (matchStatusCodeException notFound404) (getPropsM >> ispresent True) (const $ ispresent False) + ispresent = return . Right matchStatusCodeException :: Status -> HttpException -> Maybe () matchStatusCodeException want (StatusCodeException s _ _) @@ -324,7 +320,12 @@ matchStatusCodeException want (StatusCodeException s _ _) | otherwise = Nothing matchStatusCodeException _ _ = Nothing -goDAV :: DavUrl -> DavUser -> DavPass -> DAVT IO a -> IO a +-- Ignores any exceptions when performing a DAV action. +safely :: DAVT IO a -> DAVT IO (Maybe a) +safely a = (Just <$> a) + `EL.catch` (\(_ :: EL.SomeException) -> return Nothing) + +goDAV :: URLString -> DavUser -> DavPass -> DAVT IO a -> IO a goDAV url user pass a = choke $ evalDAVT url $ do setResponseTimeout Nothing -- disable default (5 second!) timeout setCreds user pass diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs new file mode 100644 index 000000000..3b52f3a64 --- /dev/null +++ b/Remote/WebDAV/DavLocation.hs @@ -0,0 +1,59 @@ +{- WebDAV locations. + - + - Copyright 2014 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +module Remote.WebDAV.DavLocation where + +import Types +import Locations +import Utility.Url (URLString) + +import System.FilePath.Posix -- for manipulating url paths +import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT) +import Control.Monad.IO.Class (MonadIO) +#ifdef mingw32_HOST_OS +import Data.String.Utils +#endif + +-- Relative to the top of the DAV url. +type DavLocation = String + +{- Runs action in subdirectory, relative to the current location. -} +inLocation :: (MonadIO m) => DavLocation -> DAVT m a -> DAVT m a +inLocation d = inDAVLocation (</> d) + +{- The directory where files(s) for a key are stored. -} +keyLocation :: Key -> DavLocation +keyLocation k = addTrailingPathSeparator $ hashdir </> keyFile k + where +#ifndef mingw32_HOST_OS + hashdir = hashDirLower k +#else + hashdir = replace "\\" "/" (hashDirLower k) +#endif + +{- Where we store temporary data for a key as it's being uploaded. -} +keyTmpLocation :: Key -> DavLocation +keyTmpLocation = addTrailingPathSeparator . tmpLocation . keyFile + +tmpLocation :: FilePath -> DavLocation +tmpLocation f = tmpDir </> f + +tmpDir :: DavLocation +tmpDir = "tmp" + +locationParent :: String -> Maybe String +locationParent loc + | loc `elem` tops = Nothing + | otherwise = Just (takeDirectory loc) + where + tops = ["/", "", "."] + +locationUrl :: URLString -> DavLocation -> URLString +locationUrl baseurl loc = baseurl </> loc diff --git a/Remote/WebDAV/DavUrl.hs b/Remote/WebDAV/DavUrl.hs deleted file mode 100644 index 4862c4f37..000000000 --- a/Remote/WebDAV/DavUrl.hs +++ /dev/null @@ -1,44 +0,0 @@ -{- WebDAV urls. - - - - Copyright 2014 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP #-} - -module Remote.WebDAV.DavUrl where - -import Types -import Locations - -import Network.URI (normalizePathSegments) -import System.FilePath.Posix -#ifdef mingw32_HOST_OS -import Data.String.Utils -#endif - -type DavUrl = String - -{- The directory where files(s) for a key are stored. -} -davLocation :: DavUrl -> Key -> DavUrl -davLocation baseurl k = addTrailingPathSeparator $ - davUrl baseurl $ hashdir </> keyFile k - where -#ifndef mingw32_HOST_OS - hashdir = hashDirLower k -#else - hashdir = replace "\\" "/" (hashDirLower k) -#endif - -{- Where we store temporary data for a key as it's being uploaded. -} -tmpLocation :: DavUrl -> Key -> DavUrl -tmpLocation baseurl k = addTrailingPathSeparator $ - davUrl baseurl $ "tmp" </> keyFile k - -davUrl :: DavUrl -> FilePath -> DavUrl -davUrl baseurl file = baseurl </> file - -urlParent :: DavUrl -> DavUrl -urlParent url = dropTrailingPathSeparator $ - normalizePathSegments (dropTrailingPathSeparator url ++ "/..") diff --git a/debian/changelog b/debian/changelog index 6d13c9637..3b54458c3 100644 --- a/debian/changelog +++ b/debian/changelog @@ -16,7 +16,9 @@ git-annex (5.20140718) UNRELEASED; urgency=medium were incompletely repaired before. * Fix cost calculation for non-encrypted remotes. * Display exception message when a transfer fails due to an exception. - * WebDAV: Dropped support for DAV before 0.6.1. + * WebDAV: Sped up by avoiding making multiple http connections + when storing a file. + * WebDAV: Dropped support for DAV before 0.8. * testremote: New command to test uploads/downloads to a remote. * Dropping an object from a bup special remote now deletes the git branch for the object, although of course the object's content cannot be deleted diff --git a/debian/control b/debian/control index e37f7d05e..66d340e3c 100644 --- a/debian/control +++ b/debian/control @@ -14,7 +14,7 @@ Build-Depends: libghc-dataenc-dev, libghc-utf8-string-dev, libghc-hs3-dev (>= 0.5.6), - libghc-dav-dev (>= 0.6.1) [amd64 i386 kfreebsd-amd64 kfreebsd-i386 powerpc], + libghc-dav-dev (>= 0.8) [amd64 i386 kfreebsd-amd64 kfreebsd-i386 powerpc], libghc-quickcheck2-dev, libghc-monad-control-dev (>= 0.3), libghc-exceptions-dev, diff --git a/git-annex.cabal b/git-annex.cabal index 2a39489d4..c3a1c161d 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -142,8 +142,8 @@ Executable git-annex CPP-Options: -DWITH_S3 if flag(WebDAV) - Build-Depends: DAV (> 0.6), - http-client, http-conduit, http-types, lifted-base + Build-Depends: DAV (> 0.8), + http-client, http-conduit, http-types, lifted-base, transformers CPP-Options: -DWITH_WEBDAV if flag(Assistant) && ! os(solaris) |