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.

2 files changed, 59 insertions, 44 deletions

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