aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Remote/WebDAV.hs121
-rw-r--r--debian/control2
-rw-r--r--doc/special_remotes/webdav.mdwn5
-rw-r--r--git-annex.cabal2
4 files changed, 105 insertions, 25 deletions
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 9d6efb51e..3747e8179 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
module Remote.WebDAV (remote) where
import Network.Protocol.HTTP.DAV
@@ -13,6 +15,10 @@ import qualified Data.ByteString.UTF8 as B8
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T
import qualified Text.XML as XML
+import Network.URI (normalizePathSegments)
+import qualified Control.Exception as E
+import Network.HTTP.Conduit (HttpException(..))
+import Network.HTTP.Types
import Common.Annex
import Types.Remote
@@ -22,7 +28,6 @@ import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
import Creds
-import Annex.Content
type DavUrl = String
type DavUser = B8.ByteString
@@ -78,20 +83,29 @@ webdavSetup u c = do
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r k _f _p = do
f <- inRepo $ gitAnnexLocation k
- davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $ do
- content <- L.readFile f
+ davAction r False $ \(baseurl, user, pass) -> liftIO $ do
let url = Prelude.head $ davLocations baseurl k
- putContentAndProps url user pass
- (noProps, (contentType, content))
- return True
+ davMkdir (urlParent url) user pass
+ b <- L.readFile f
+ v <- catchMaybeHttp $ putContentAndProps url user pass
+ (noProps, (contentType, b))
+ return $ isJust v
storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
-storeEncrypted r (cipher, enck) k _p = davAction r False $ \creds -> do
+storeEncrypted r (cipher, enck) k _p = davAction r False $ \creds -> liftIO $ do
error "TODO"
retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieve r k _f d = davAction r False $ \creds -> do
- error "TODO"
+retrieve r k _f d = davAction r False $ liftIO . go
+ where
+ go (baseurl, user, pass) = get $ davLocations baseurl k
+ where
+ get [] = return False
+ get (u:urls) = maybe (get urls) save
+ =<< catchMaybeHttp (getPropsAndContent u user pass)
+ save (_, (_, b)) = do
+ L.writeFile d b
+ return True
retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
@@ -101,16 +115,41 @@ retrieveEncrypted r (cipher, enck) _ f = davAction r False $ \creds -> do
error "TODO"
remove :: Remote -> Key -> Annex Bool
-remove r k = davAction r False $ \creds -> do
- error "TODO"
+remove r k = davAction r False $ liftIO . go
+ where
+ go (baseurl, user, pass) = delone $ davLocations baseurl k
+ where
+ delone [] = return False
+ delone (u:urls) = maybe (delone urls) (const $ return True)
+ =<< catchMaybeHttp (deletedir u)
+
+ {- Rather than deleting first the file, and then its
+ - immediate parent directory (to clean up), delete the
+ - parent directory, along with all its contents in a
+ - single recursive DAV call.
+ -
+ - The file is the only thing we keep in there, and this
+ - is faster. -}
+ deletedir u = deleteContent (urlParent u) user pass
checkPresent :: Remote -> Key -> Annex (Either String Bool)
-checkPresent r k = davAction r noconn $ \creds -> do
- showAction $ "checking " ++ name r
- return $ Right False
- --error "TODO"
+checkPresent r k = davAction r noconn go
where
noconn = Left $ error $ name r ++ " not configured"
+ go (baseurl, user, pass) = do
+ showAction $ "checking " ++ name r
+ liftIO $ check $ davLocations baseurl k
+ where
+ check [] = return $ Right False
+ check (u:urls) = do
+ v <- catchHttp $ getProps u user pass
+ case v of
+ Right _ -> return $ Right True
+ Left (Left (StatusCodeException status _))
+ | statusCode status == statusCode notFound404 -> check urls
+ | otherwise -> return $ Left $ show $ statusMessage status
+ Left (Left httpexception) -> return $ Left $ show httpexception
+ Left (Right ioexception) -> return $ Left $ show ioexception
davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
davAction r unconfigured action = case config r of
@@ -135,9 +174,48 @@ toDavPass = B8.fromString
davLocations :: DavUrl -> Key -> [DavUrl]
davLocations baseurl k = map (davUrl baseurl) (keyPaths k)
-{- FIXME: Replacing / with _ to avoid needing collections. -}
davUrl :: DavUrl -> FilePath -> DavUrl
-davUrl baseurl file = baseurl </> replace "/" "_" file
+davUrl baseurl file = baseurl </> file
+
+{- Creates a directory in WebDAV, if not already present; also creating
+ - any missing parent directories. -}
+davMkdir :: DavUrl -> DavUser -> DavPass -> IO ()
+davMkdir url user pass = go url
+ where
+ make u = makeCollection 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 ()
+
+{- Catches HTTP and IO exceptions. -}
+catchMaybeHttp :: IO a -> IO (Maybe a)
+catchMaybeHttp a = (Just <$> a) `E.catches`
+ [ E.Handler $ \(_e :: HttpException) -> return Nothing
+ , E.Handler $ \(_e :: E.IOException) -> return Nothing
+ ]
+
+{- Catches HTTP and IO exceptions -}
+catchHttp :: IO a -> IO (Either (Either HttpException E.IOException) a)
+catchHttp a = (Right <$> a) `E.catches`
+ [ E.Handler $ \(e :: HttpException) -> return $ Left $ Left e
+ , E.Handler $ \(e :: E.IOException) -> return $ Left $ Right e
+ ]
+
+urlParent :: DavUrl -> DavUrl
+urlParent url = reverse $ dropWhile (== '/') $ reverse $
+ normalizePathSegments (url ++ "/..")
{- Test if a WebDAV store is usable, by writing to a test file, and then
- deleting the file. Exits with an error if not. -}
@@ -146,12 +224,13 @@ testDav baseurl Nothing = error "Need to configure webdav username and password.
testDav baseurl (Just (u, p)) = do
showSideAction "testing WebDAV server"
liftIO $ do
- putContentAndProps testurl username password
+ davMkdir baseurl user pass
+ putContentAndProps testurl user pass
(noProps, (contentType, L.empty))
- deleteContent testurl username password
+ deleteContent testurl user pass
where
- username = toDavUser u
- password = toDavPass p
+ user = toDavUser u
+ pass = toDavPass p
testurl = davUrl baseurl "git-annex-test"
{- Content-Type to use for files uploaded to WebDAV. -}
diff --git a/debian/control b/debian/control
index 74d9c0c6a..d3840463d 100644
--- a/debian/control
+++ b/debian/control
@@ -12,7 +12,7 @@ Build-Depends:
libghc-http-dev,
libghc-utf8-string-dev,
libghc-hs3-dev (>= 0.5.6),
- libghc-dav-dev (>= 0.1),
+ libghc-dav-dev (>= 0.2),
libghc-testpack-dev,
libghc-quickcheck2-dev,
libghc-monad-control-dev (>= 0.3),
diff --git a/doc/special_remotes/webdav.mdwn b/doc/special_remotes/webdav.mdwn
index 5cc5c55d9..c5b53dc4b 100644
--- a/doc/special_remotes/webdav.mdwn
+++ b/doc/special_remotes/webdav.mdwn
@@ -20,7 +20,8 @@ the webdav remote.
the new key id. See [[encryption]].
* `url` - Required. The URL to the WebDAV directory where files will be
- stored. This directory must already exist. Use of a https URL is strongly
+ stored. This can be a subdirectory of a larger WebDAV repository, and will
+ be created as needed. Use of a https URL is strongly
encouraged, since HTTP basic authentication is used.
* `chunksize` - Avoid storing files larger than the specified size in
@@ -33,4 +34,4 @@ the webdav remote.
Setup example:
- # WEBDAV_USERNAME=joey@kitenet.net WEBDAV_PASSWORD=xxxxxxx git annex initremote box.com type=webdav url=https://www.box.com/dav/ encryption=joey@kitenet.net
+ # WEBDAV_USERNAME=joey@kitenet.net WEBDAV_PASSWORD=xxxxxxx git annex initremote box.com type=webdav url=https://www.box.com/dav/git-annex encryption=joey@kitenet.net
diff --git a/git-annex.cabal b/git-annex.cabal
index 8db659fbf..c72a6c0bd 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -73,7 +73,7 @@ Executable git-annex
CPP-Options: -DWITH_S3
if flag(WebDAV)
- Build-Depends: DAV (>= 0.1)
+ Build-Depends: DAV (>= 0.2), http-conduit
CPP-Options: -DWITH_WebDAV
if flag(Assistant) && ! os(windows) && ! os(solaris)
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-03 18:33:05 +0000