export to webdav

This basically works, but there's a bug when renaming a file that leaves
a .git-annex-temp-content-key file in the webdav store, that never gets
cleaned up.

Also, exporting files with spaces to box.com seems to fail; perhaps it
does not support it?

This commit was supported by the NSF-funded DataLad project.

CHANGELOG

@@ -4,7 +4,7 @@ git-annex (6.20170819) UNRELEASED; urgency=medium
     exports of trees to special remotes.
   * Use git-annex initremote with exporttree=yes to set up a special remote
     for use by git-annex export.
-  * Implemented export to directory and S3 special remotes.
+  * Implemented export to directory, S3, and webdav special remotes.
   * External special remote protocol extended to support export.
   * Support building with feed-1.0, while still supporting older versions.
   * init: Display an additional message when it detects a filesystem that

Command/Export.hs

@@ -304,7 +304,9 @@ performRename r db ek src dest = do
 		( next $ cleanupRename db ek src dest
 		-- In case the special remote does not support renaming,
 		-- unexport the src instead.
-		, performUnexport r db [ek] src
+		, do
+			warning "rename failed; deleting instead"
+			performUnexport r db [ek] src
 		)
 
 cleanupRename :: ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandCleanup

Remote/WebDAV.hs

@@ -1,6 +1,6 @@
 {- WebDAV remotes.
  -
- - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2017 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -15,7 +15,7 @@ import qualified Data.Map as M
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.UTF8 as B8
 import qualified Data.ByteString.Lazy.UTF8 as L8
-import Network.HTTP.Client (HttpException(..))
+import Network.HTTP.Client (HttpException(..), RequestBody)
 import Network.HTTP.Types
 import System.IO.Error
 import Control.Monad.Catch
@@ -46,7 +46,7 @@ remote = RemoteType
 	, enumerate = const (findSpecialRemotes "webdav")
 	, generate = gen
 	, setup = webdavSetup
-	, exportSupported = exportUnsupported
+	, exportSupported = exportIsSupported
 	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
@@ -70,7 +70,13 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, exportActions = exportUnsupported
+			, exportActions = ExportActions
+				{ storeExport = storeExportDav this
+				, retrieveExport = retrieveExportDav this
+				, removeExport = removeExportDav this
+				, checkPresentExport = checkPresentExportDav this
+				, renameExport = renameExportDav this
+				}
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
 			, repairRepo = Nothing
@@ -114,17 +120,21 @@ store (LegacyChunks chunksize) (Just dav) = fileStorer $ \k f p -> liftIO $
 store _  (Just dav) = httpStorer $ \k reqbody -> liftIO $ goDAV dav $ do
 	let tmp = keyTmpLocation k
 	let dest = keyLocation k
+	storeHelper dav tmp dest reqbody
+	return True
+
+storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO ()
+storeHelper dav tmp dest reqbody = do
 	void $ mkColRecursive tmpDir
 	inLocation tmp $
 		putContentM' (contentType, reqbody)
-	finalizeStore (baseURL dav) tmp dest
+	finalizeStore dav tmp dest
-	return True
 
-finalizeStore :: URLString -> DavLocation -> DavLocation -> DAVT IO ()
+finalizeStore :: DavHandle -> DavLocation -> DavLocation -> DAVT IO ()
-finalizeStore baseurl tmp dest = do
+finalizeStore dav tmp dest = do
 	inLocation dest $ void $ safely $ delContentM
 	maybe noop (void . mkColRecursive) (locationParent dest)
-	moveDAV baseurl tmp dest
+	moveDAV (baseURL dav) tmp dest
 
 retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
 retrieveCheap _ _ _ = return False
@@ -133,26 +143,29 @@ retrieve :: ChunkConfig -> Maybe DavHandle -> Retriever
 retrieve _ Nothing = giveup "unable to connect"
 retrieve (LegacyChunks _) (Just dav) = retrieveLegacyChunked dav
 retrieve _ (Just dav) = fileRetriever $ \d k p -> liftIO $
-	goDAV dav $
+	goDAV dav $ retrieveHelper (keyLocation k) d p
-		inLocation (keyLocation k) $
+
-			withContentM $
+retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO ()
-				httpBodyRetriever d p
+retrieveHelper loc d p = inLocation loc $
+	withContentM $ httpBodyRetriever d p
 
 remove :: Maybe DavHandle -> Remover
 remove Nothing _ = return False
-remove (Just dav) k = liftIO $ do
+remove (Just dav) k = liftIO $ goDAV dav $
 	-- Delete the key's whole directory, including any
 	-- legacy chunked files, etc, in a single action.
-	let d = keyDir k
+	removeHelper (keyDir k)
-	goDAV dav $ do
+
-		v <- safely $ inLocation d delContentM
+removeHelper :: DavLocation -> DAVT IO Bool
-		case v of
+removeHelper d = do
-			Just _ -> return True
+	v <- safely $ inLocation d delContentM
-			Nothing -> do
+	case v of
-				v' <- existsDAV d
+		Just _ -> return True
-				case v' of
+		Nothing -> do
-					Right False -> return True
+			v' <- existsDAV d
-					_ -> return False
+			case v' of
+				Right False -> return True
+				_ -> return False
 
 checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent
 checkKey r _ Nothing _ = giveup $ name r ++ " not configured"
@@ -165,6 +178,38 @@ checkKey r chunkconfig (Just dav) k = do
 				existsDAV (keyLocation k)
 			either giveup return v
 
+storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
+storeExportDav r f _k loc p = runExport r $ \dav -> do
+	reqbody <- liftIO $ httpBodyStorer f p
+	storeHelper dav (exportTmpLocation loc) (exportLocation loc) reqbody
+	return True
+
+retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
+retrieveExportDav r _k loc d p = runExport r $ \_dav -> do
+	retrieveHelper (exportLocation loc) d p
+	return True
+
+removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
+removeExportDav r _k loc = runExport r $ \_dav ->
+	removeHelper (exportLocation loc)
+
+checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
+checkPresentExportDav r _k loc = withDAVHandle r $ \mh -> case mh of
+	Nothing -> giveup $ name r ++ " not configured"
+	Just h -> liftIO $ do
+		v <- goDAV h $ existsDAV (exportLocation loc)
+		either giveup return v
+
+renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool
+renameExportDav r _k src dest = runExport r $ \dav -> do
+	moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)
+	return True
+
+runExport :: Remote -> (DavHandle -> DAVT IO Bool) -> Annex Bool
+runExport r a = withDAVHandle r $ \mh -> case mh of
+	Nothing -> return False
+	Just h -> fromMaybe False <$> liftIO (goDAV h $ safely (a h))
+
 configUrl :: Remote -> Maybe URLString
 configUrl r = fixup <$> M.lookup "url" (config r)
   where
@@ -278,7 +323,6 @@ existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e))
 			(const $ ispresent False)
 	ispresent = return . Right
 
--- Ignores any exceptions when performing a DAV action.
 safely :: DAVT IO a -> DAVT IO (Maybe a)
 safely = eitherToMaybe <$$> tryNonAsync
 
@@ -351,7 +395,7 @@ storeLegacyChunked chunksize k dav b =
 	storer locs = Legacy.storeChunked chunksize locs storehttp b
 	recorder l s = storehttp l (L8.fromString s)
 	finalizer tmp' dest' = goDAV dav $ 
-		finalizeStore (baseURL dav) tmp' (fromJust $ locationParent dest')
+		finalizeStore dav tmp' (fromJust $ locationParent dest')
 
 	tmp = addTrailingPathSeparator $ keyTmpLocation k
 	dest = keyLocation k

Remote/WebDAV/DavLocation.hs

@@ -11,6 +11,7 @@
 module Remote.WebDAV.DavLocation where
 
 import Types
+import Types.Remote (ExportLocation(..))
 import Annex.Locations
 import Utility.Url (URLString)
 #ifdef mingw32_HOST_OS
@@ -46,6 +47,12 @@ keyLocation k = keyDir k ++ keyFile k
 keyTmpLocation :: Key -> DavLocation
 keyTmpLocation = tmpLocation . keyFile
 
+exportLocation :: ExportLocation -> DavLocation
+exportLocation (ExportLocation f) = f
+
+exportTmpLocation :: ExportLocation -> DavLocation
+exportTmpLocation (ExportLocation f) = tmpLocation f
+
 tmpLocation :: FilePath -> DavLocation
 tmpLocation f = tmpDir </> f
 

doc/special_remotes/webdav.mdwn

@@ -29,6 +29,10 @@ the webdav remote.
   be created as needed. Use of a https URL is strongly
   encouraged, since HTTP basic authentication is used.
 
+* `exporttree` - Set to "yes" to make this special remote usable
+  by [[git-annex-export]]. It will not be usable as a general-purpose
+  special remote.
+
 * `chunk` - Enables [[chunking]] when storing large files.
 
 * `chunksize` - Deprecated version of chunk parameter above.  

doc/tips/using_box.com_as_a_special_remote.mdwn

@@ -1,14 +1,42 @@
-[Box.com](http://box.com/) is a file storage service, currently notable 
+[Box.com](http://box.com/) is a file storage service.
-for providing 50 gb of free storage if you sign up with its Android client.
-(Or a few gb free otherwise.)
 
 git-annex can use Box as a [[special remote|special_remotes]].
-Recent versions of git-annex make this very easy to set up:
+Recent versions of git-annex make this very easy to set up
+and use.
 
-	WEBDAV_USERNAME=you@example.com WEBDAV_PASSWORD=xxxxxxx git annex initremote box.com type=webdav url=https://dav.box.com/dav/git-annex chunk=50mb encryption=shared
+## git-annex setup
 
-Note the use of [[chunking]]; Box has a 100 mb maximum file size, and this
+Create the special remote, in your git-annex repository.
-breaks up large files into chunks before that limit is reached.
+** This example is non-encrypted; fill in your gpg key ID for a securely
+encrypted special remote! **
+
+	WEBDAV_USERNAME=you@example.com WEBDAV_PASSWORD=xxxxxxx git annex initremote box.com type=webdav url=https://dav.box.com/dav/git-annex chunk=50mb encryption=none
+
+Note the use of [[chunking]]. Box has a limit on the maximum size of file
+that can be stored there (currently 256 MB). git-annex can break up large
+files into chunks to avoid the size limit. This needs git-annex version
+3.20120303 or newer, which adds support for chunking.
+
+Now git-annex can copy files to box.com, get files from it, etc, just like
+with any other special remote.
+
+	% git annex copy bigfile --to box.com
+	bigfile (to box.com...) ok
+	% git annex drop bigfile
+	bigfile (checking box.com...) ok
+	% git annex get bigfile
+	bigfile (from box.com...) ok
+
+## exporting trees
+
+By default, files stored in Box will show up there named
+by their git-annex key, not the original filename. If the filenames
+are important, you can run `git annex initremote` with an additional
+parameter "exporttree=yes", and then use [[git-annex-export]] to publish
+a tree of files to Box.
+
+Note that chunking can't be used when exporting a tree of files,
+so Box's 250 mb limit will prevent exporting larger files.
 
 # old davfs2 method
 
@@ -48,24 +76,3 @@ using the webdav special remote.
 * Now you should be able to mount Box, as a non-root user:
 
         mount /media/box.com
-
-## git-annex setup
-
-You need git-annex version 3.20120303 or newer, which adds support for chunking
-files larger than Box's 100 mb limit.
-
-Create the special remote, in your git-annex repository.
-** This example is non-encrypted; fill in your gpg key ID for a securely
-encrypted special remote! **
-
-	git annex initremote box.com type=directory directory=/media/box.com chunk=2mb encryption=none
-
-Now git-annex can copy files to box.com, get files from it, etc, just like
-with any other special remote.
-
-	% git annex copy bigfile --to box.com
-	bigfile (to box.com...) ok
-	% git annex drop bigfile
-	bigfile (checking box.com...) ok
-	% git annex get bigfile
-	bigfile (from box.com...) ok