use DAV monad

This speeds up the webdav special remote somewhat, since it often now
groups actions together in a single http connection when eg, storing a
file.

Legacy chunks are still supported, but have not been sped up.

This depends on a as-yet unreleased version of DAV.

This commit was sponsored by Thomas Hochstein.

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 storehttp l b' = do
-			let recorder url s = storehttp url (L8.fromString s)
+				void $ goDAV baseurl user pass $ do
-			Legacy.storeChunks k tmpurl keyurl storer recorder finalizer
+					maybe noop (void . mkColRecursive) (locationParent l)
-		_ -> do
+					inLocation l $ putContentM (contentType, b')
-			storehttp tmpurl b
+			let storer locs = Legacy.storeChunked chunksize locs storehttp b
-			finalizer tmpurl keyurl
+			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
+	tmp = keyTmpLocation k
-	keyurl = davLocation baseurl k
+	dest = keyLocation k ++ keyFile k
-	finalizer srcurl desturl = do
+
-		void $ tryNonAsync (deleteDAV desturl user pass)
+finalizeStore :: URLString -> DavLocation -> DavLocation -> DAVT IO ()
-		mkdirRecursiveDAV (urlParent desturl) user pass
+finalizeStore baseurl tmp dest = do
-		moveDAV srcurl desturl user pass
+	inLocation dest $ void $ safely $ delContentM
-	storehttp url = putDAV url user pass
+	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
+		withStoredFiles chunkconfig k baseurl user pass onerr $ \locs -> do
-			Legacy.meteredWriteFileChunks p d urls $ \url -> do
+			Legacy.meteredWriteFileChunks p d locs $ \l -> do
-				mb <- getDAV url user pass
+				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
+		ret <- goDAV baseurl user pass $ safely $
-		isJust . eitherToMaybe <$> tryNonAsync (deleteDAV url user pass)
+			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
+		check (l:ls) = do
-			v <- existsDAV url user pass
+			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. -}
+		- or perhaps this was an intermittent error. -}
-		onerr url = do
+		onerr f = do
-			v <- existsDAV url user pass
+			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)
+	-> (DavLocation -> IO a)
-	-> ([DavUrl] -> 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
+		let chunkcount = keyloc ++ Legacy.chunkCount
-		v <- getDAV chunkcount user pass
+		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. -}
+ - deleting the file.
-testDav :: String -> Maybe CredPair -> Annex ()
+ -
-testDav baseurl (Just (u, p)) = do
+ - 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 $ liftIO $ goDAV url user pass $ do
-	test "write file" $ putDAV testurl user pass L.empty
+		makeParentDirs
-	test "delete file" $ deleteDAV testurl user pass
+		inLocation tmpDir $ void mkCol
+		inLocation (tmpLocation "git-annex-test") $ do
+			putContentM (Nothing, L.empty)
+			delContentM
   where
-	test desc a = liftIO $
+	test a = liftIO $
-		either (\e -> throwIO $ "WebDAV failed to " ++ desc ++ ": " ++ show e)
+		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 ()
+moveDAV :: URLString -> DavLocation -> DavLocation -> DAVT IO ()
-debugDAV msg url = debugM "DAV" $ msg ++ " " ++ url
+moveDAV baseurl src dest = inLocation src $ moveContentM newurl
-
-{---------------------------------------------------------------------
- - 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
   where
-	go = goDAV url user pass $ snd <$> getContentM
+	newurl = B8.fromString (locationUrl baseurl dest)
 
-deleteDAV :: DavUrl -> DavUser -> DavPass -> IO ()
+existsDAV :: DavLocation -> DAVT IO (Either String Bool)
-deleteDAV url user pass = do
+existsDAV l = inLocation l check `EL.catch` (\(e :: EL.SomeException) -> return (Left $ show e))
-	debugDAV "DELETE" url
-	goDAV url user pass delContentM
-
-moveDAV :: DavUrl -> DavUrl -> DavUser -> DavPass -> IO ()
-moveDAV url newurl user pass = do
-	debugDAV ("MOVE to " ++ newurl ++ " from ") url
-	goDAV url user pass $ moveContentM newurl'
   where
-	newurl' = B8.fromString newurl
+	check = do
-
-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
 		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

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

Remote/WebDAV/DavUrl.hs

@@ -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 ++ "/..")

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

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,

git-annex.cabal

@@ -142,8 +142,8 @@ Executable git-annex
     CPP-Options: -DWITH_S3
 
   if flag(WebDAV)
-    Build-Depends: DAV (> 0.6),
+    Build-Depends: DAV (> 0.8),
-     http-client, http-conduit, http-types, lifted-base
+     http-client, http-conduit, http-types, lifted-base, transformers
     CPP-Options: -DWITH_WEBDAV
 
   if flag(Assistant) && ! os(solaris)