summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Remote/WebDAV.hs229
-rw-r--r--Remote/WebDAV/DavLocation.hs59
-rw-r--r--Remote/WebDAV/DavUrl.hs44
-rw-r--r--debian/changelog4
-rw-r--r--debian/control2
-rw-r--r--git-annex.cabal4
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)