webdav is fully working in non-enctypted mode

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. -}