webdav now checks presence of and receives chunked content

Note that receiving encrypted chunked content currently involves buffering.
(So does doing so with the directory special remote.)

1 files changed, 88 insertions, 25 deletions

diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index c1e221295..b69d51f23 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -20,6 +20,7 @@ import Network.URI (normalizePathSegments)
 import qualified Control.Exception as E
 import Network.HTTP.Conduit (HttpException(..))
 import Network.HTTP.Types
+import System.IO.Error
 
 import Common.Annex
 import Types.Remote
@@ -108,25 +109,45 @@ storeHelper r urlbase user pass b = catchBoolIO $ do
 	storehttp url v = putContentAndProps url user pass
 		(noProps, (contentType, v))
 
-retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
-retrieve r k _f d = retrieveHelper r k (L.writeFile d)
-
 retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
 retrieveCheap _ _ _ = return False
 
-retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
-retrieveEncrypted r (cipher, enck) _ d = retrieveHelper r enck $ \b -> do
-	withDecryptedContent cipher (return b) (L.writeFile d)
+retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieve r k _f d = metered Nothing k $ \meterupdate ->
+	davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $
+		withStoredFiles r k baseurl user pass onerr $ \urls -> do
+			meteredWriteFileChunks meterupdate d urls $
+				feeder user pass
+			return True
+  where
+	onerr _ = return False
 
-retrieveHelper :: Remote -> Key -> (L.ByteString -> IO ()) -> Annex Bool
-retrieveHelper r k saver = davAction r False $ \(baseurl, user, pass) -> liftIO $ do
-	let url = davLocation baseurl k
-	maybe (return False) save
-		=<< catchMaybeHttp (getPropsAndContent url user pass)
+	feeder _ _ [] = return ([], [])
+	feeder user pass (url:urls) = do
+		mb <- davGetUrlContent url user pass
+		case mb of
+			Nothing -> throwDownloadFailed
+			Just b -> return (urls, L.toChunks b)
+
+throwDownloadFailed :: IO a
+throwDownloadFailed = ioError $ mkIOError userErrorType "download failed" Nothing Nothing
+
+retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
+retrieveEncrypted r (cipher, enck) k d = metered Nothing k $ \meterupdate ->
+	davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $
+		withStoredFiles r enck baseurl user pass onerr $ \urls -> do
+			withDecryptedContent cipher (L.concat <$> feeder user pass urls []) $
+				meteredWriteFile meterupdate d
+			return True
   where
-	save (_, (_, b)) = do
-		saver b
-		return True
+	onerr _ = return False
+
+	feeder _ _ [] c = return $ reverse c
+	feeder user pass (url:urls) c = do
+		mb <- davGetUrlContent url user pass
+		case mb of
+			Nothing -> throwDownloadFailed
+			Just b -> feeder user pass urls (b:c)
 
 remove :: Remote -> Key -> Annex Bool
 remove r k = davAction r False $ \(baseurl, user, pass) -> liftIO $ do
@@ -136,20 +157,48 @@ remove r k = davAction r False $ \(baseurl, user, pass) -> liftIO $ do
 	isJust <$> catchMaybeHttp (deleteContent url user pass)
 
 checkPresent :: Remote -> Key -> Annex (Either String Bool)
-checkPresent r k = davAction r noconn $ \(baseurl, user, pass) -> do
-	showAction $ "checking " ++ name r
-	let url = davLocation baseurl k	
-	v <- liftIO $ catchHttp $ getProps url user pass
-	case v of
-		Right _ -> return $ Right True
-		Left (Left (StatusCodeException status _))
-			| statusCode status == statusCode notFound404 -> return $ Right False
-			| otherwise -> return $ Left $ show $ statusMessage status
-		Left (Left httpexception) -> return $ Left $ show httpexception
-		Left (Right ioexception) -> return $ Left $ show ioexception
+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 $ withStoredFiles r k baseurl user pass onerr check
+	  where
+		check [] = return $ Right True
+		check (url:urls) = do
+			v <- davUrlExists url user pass
+			if v == Right True
+				then check urls
+				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. -}
+		onerr url = do
+			v <- davUrlExists url user pass
+			if v == Right True
+				then return $ Left $ "failed to read " ++ url
+				else return v
+
+withStoredFiles
+	:: Remote
+	-> Key
+	-> DavUrl
+	-> DavUser
+	-> DavPass
+	-> (DavUrl -> IO a)
+	-> ([DavUrl] -> IO a)
+	-> IO a
+withStoredFiles r k baseurl user pass onerr a
+	| isJust $ chunkSize $ config r = do
+		let chunkcount = url ++ chunkCount
+		maybe (onerr chunkcount) (a . listChunks url . L8.toString)
+			=<< davGetUrlContent chunkcount user pass
+	| otherwise = a [url]
+  where
+	url = davLocation baseurl k
+
 davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
 davAction r unconfigured action = case config r of
 	Nothing -> return unconfigured
@@ -173,6 +222,20 @@ davLocation baseurl k = davUrl baseurl $ annexLocation k hashDirLower
 davUrl :: DavUrl -> FilePath -> DavUrl
 davUrl baseurl file = baseurl </> file
 
+davUrlExists :: DavUrl -> DavUser -> DavPass -> IO (Either String Bool)
+davUrlExists url user pass = decode <$> catchHttp (getProps url user pass)
+  where
+	decode (Right _) = Right True
+	decode (Left (Left (StatusCodeException status _)))
+		| statusCode status == statusCode notFound404 = Right False
+		| otherwise = Left $ show $ statusMessage status
+	decode (Left (Left httpexception)) = Left $ show httpexception
+	decode (Left (Right ioexception)) = Left $ show ioexception
+
+davGetUrlContent :: DavUrl -> DavUser -> DavPass -> IO  (Maybe L.ByteString)
+davGetUrlContent url user pass = fmap (snd . snd) <$>
+	catchMaybeHttp (getPropsAndContent url user pass)
+
 {- Creates a directory in WebDAV, if not already present; also creating
  - any missing parent directories. -}
 davMkdir :: DavUrl -> DavUser -> DavPass -> IO ()