summaryrefslogtreecommitdiff
path: root/Remote/WebDAV.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-16 00:09:22 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-16 00:09:22 -0400
commit9873d38731cb2bebfc2a397f304d89e51c306aa0 (patch)
treeec43bc946b87caf28c0653d5e45206d9cdb6d4a2 /Remote/WebDAV.hs
parent2cef42e87c5fbaf318a1381888d504c54844de39 (diff)
webdav is fully working in non-enctypted mode
Diffstat (limited to 'Remote/WebDAV.hs')
-rw-r--r--Remote/WebDAV.hs121
1 files changed, 100 insertions, 21 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. -}