External special remote protocol extended to support export.

Also updated example.sh to support export.

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

4 files changed, 172 insertions, 14 deletions

diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 22413b7e9..c17ed80a5 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -240,8 +240,8 @@ storeExportDirectory d src _k loc p = liftIO $ catchBoolIO $ do
   where
 	dest = exportPath d loc
 
-retrieveExportDirectory :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
-retrieveExportDirectory d _k loc dest p = unVerified $ liftIO $ catchBoolIO $ do
+retrieveExportDirectory :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
+retrieveExportDirectory d _k loc dest p = liftIO $ catchBoolIO $ do
 	withMeteredFile src p (L.writeFile dest)
 	return True
   where
diff --git a/Remote/External.hs b/Remote/External.hs
index 71a07d3ea..ed00cc93f 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -45,7 +45,7 @@ remote = RemoteType
 	, enumerate = const (findSpecialRemotes "externaltype")
 	, generate = gen
 	, setup = externalSetup
-	, exportSupported = exportUnsupported
+	, exportSupported = checkExportSupported
 	}
 
 gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
@@ -61,11 +61,28 @@ gen r u c gc
 			Nothing
 			Nothing
 			Nothing
+			exportUnsupported
+			exportUnsupported
 	| otherwise = do
 		external <- newExternal externaltype u c gc
 		Annex.addCleanup (RemoteCleanup u) $ stopExternal external
 		cst <- getCost external r gc
 		avail <- getAvailability external r gc
+		exportsupported <- checkExportSupported' external
+		let exportactions = if exportsupported
+			then ExportActions
+				{ storeExport = storeExportExternal external
+				, retrieveExport = retrieveExportExternal external
+				, removeExport = removeExportExternal external
+				, checkPresentExport = checkPresentExportExternal external
+				, renameExport = renameExportExternal external
+				}
+			else exportUnsupported
+		-- Cheap exportSupported that replaces the expensive
+		-- checkExportSupported now that we've already checked it.
+		let cheapexportsupported = if exportsupported
+			then exportIsSupported
+			else exportUnsupported
 		mk cst avail
 			(store external)
 			(retrieve external)
@@ -74,8 +91,10 @@ gen r u c gc
 			(Just (whereis external))
 			(Just (claimurl external))
 			(Just (checkurl external))
+			exportactions
+			cheapexportsupported
   where
-	mk cst avail tostore toretrieve toremove tocheckkey towhereis toclaimurl tocheckurl = do
+	mk cst avail tostore toretrieve toremove tocheckkey towhereis toclaimurl tocheckurl exportactions cheapexportsupported = do
 		let rmt = Remote
 			{ uuid = u
 			, cost = cst
@@ -87,7 +106,7 @@ gen r u c gc
 			, lockContent = Nothing
 			, checkPresent = checkPresentDummy
 			, checkPresentCheap = False
-			, exportActions = exportUnsupported
+			, exportActions = exportactions
 			, whereisKey = towhereis
 			, remoteFsck = Nothing
 			, repairRepo = Nothing
@@ -97,7 +116,8 @@ gen r u c gc
 			, gitconfig = gc
 			, readonly = False
 			, availability = avail
-			, remotetype = remote
+			, remotetype = remote 
+				{ exportSupported = cheapexportsupported }
 			, mkUnavailable = gen r u c $
 				gc { remoteAnnexExternalType = Just "!dne!" }
 			, getInfo = return [("externaltype", externaltype)]
@@ -135,6 +155,21 @@ externalSetup _ mu _ c gc = do
 	gitConfigSpecialRemote u c'' "externaltype" externaltype
 	return (c'', u)
 
+checkExportSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
+checkExportSupported c gc = do
+	let externaltype = fromMaybe (giveup "Specify externaltype=") $
+		remoteAnnexExternalType gc <|> M.lookup "externaltype" c
+	checkExportSupported' 
+		=<< newExternal externaltype NoUUID c gc
+
+checkExportSupported' :: External -> Annex Bool
+checkExportSupported' external = safely $
+	handleRequest external EXPORTSUPPORTED Nothing $ \resp -> case resp of
+		EXPORTSUPPORTED_SUCCESS -> Just $ return True
+		EXPORTSUPPORTED_FAILURE -> Just $ return False
+		UNSUPPORTED_REQUEST -> Just $ return False
+		_ -> Nothing
+
 store :: External -> Storer
 store external = fileStorer $ \k f p ->
 	handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp ->
@@ -189,6 +224,78 @@ whereis external k = handleRequestKey external WHEREIS k Nothing $ \resp -> case
 	UNSUPPORTED_REQUEST -> Just $ return []
 	_ -> Nothing
 
+storeExportExternal :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
+storeExportExternal external f k loc p = safely $
+	handleRequestExport external loc req k (Just p) $ \resp -> case resp of
+		TRANSFER_SUCCESS Upload k' | k == k' ->
+			Just $ return True
+		TRANSFER_FAILURE Upload k' errmsg | k == k' ->
+			Just $ do
+				warning errmsg
+				return False
+		UNSUPPORTED_REQUEST -> Just $ do
+			warning "TRANSFEREXPORT not implemented by external special remote"
+			return False
+		_ -> Nothing
+  where
+	req sk = TRANSFEREXPORT Upload sk f
+
+retrieveExportExternal :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
+retrieveExportExternal external k loc d p = safely $
+	handleRequestExport external loc req k (Just p) $ \resp -> case resp of
+		TRANSFER_SUCCESS Download k'
+			| k == k' -> Just $ return True
+		TRANSFER_FAILURE Download k' errmsg
+			| k == k' -> Just $ do
+				warning errmsg
+				return False
+		UNSUPPORTED_REQUEST -> Just $ do
+			warning "TRANSFEREXPORT not implemented by external special remote"
+			return False
+		_ -> Nothing
+  where
+	req sk = TRANSFEREXPORT Download sk d
+
+removeExportExternal :: External -> Key -> ExportLocation -> Annex Bool
+removeExportExternal external k loc = safely $
+	handleRequestExport external loc REMOVEEXPORT k Nothing $ \resp -> case resp of
+		REMOVE_SUCCESS k'
+			| k == k' -> Just $ return True
+		REMOVE_FAILURE k' errmsg
+			| k == k' -> Just $ do
+				warning errmsg
+				return False
+		UNSUPPORTED_REQUEST -> Just $ do
+			warning "REMOVEEXPORT not implemented by external special remote"
+			return False
+		_ -> Nothing
+
+checkPresentExportExternal :: External -> Key -> ExportLocation -> Annex Bool
+checkPresentExportExternal external k loc = either giveup id <$> go
+  where
+	go = handleRequestExport external loc CHECKPRESENTEXPORT k Nothing $ \resp -> case resp of
+		CHECKPRESENT_SUCCESS k'
+			| k' == k -> Just $ return $ Right True
+		CHECKPRESENT_FAILURE k'
+			| k' == k -> Just $ return $ Right False
+		CHECKPRESENT_UNKNOWN k' errmsg
+			| k' == k -> Just $ return $ Left errmsg
+		UNSUPPORTED_REQUEST -> Just $ return $
+			Left "CHECKPRESENTEXPORT not implemented by external special remote"
+		_ -> Nothing
+
+renameExportExternal :: External -> Key -> ExportLocation -> ExportLocation -> Annex Bool
+renameExportExternal external k src dest = safely $
+	handleRequestExport external src req k Nothing $ \resp -> case resp of
+		RENAMEEXPORT_SUCCESS k'
+			| k' == k -> Just $ return True
+		RENAMEEXPORT_FAILURE k' 
+			| k' == k -> Just $ return False
+		UNSUPPORTED_REQUEST -> Just $ return False
+		_ -> Nothing
+  where
+	req sk = RENAMEEXPORT sk dest
+
 safely :: Annex Bool -> Annex Bool
 safely a = go =<< tryNonAsync a
   where
@@ -220,6 +327,16 @@ handleRequestKey external mkreq k mp responsehandler = case mkSafeKey k of
 	Right sk -> handleRequest external (mkreq sk) mp responsehandler
 	Left e -> giveup e
 
+{- Export location is first sent in an EXPORT message before
+ - the main request. This is done because the ExportLocation can
+ - contain spaces etc. -}
+handleRequestExport :: External -> ExportLocation -> (SafeKey -> Request) -> Key -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
+handleRequestExport external loc mkreq k mp responsehandler = do
+	withExternalState external $ \st -> do
+		checkPrepared st external
+		sendMessage st external (EXPORT loc)
+	handleRequestKey external mkreq k mp responsehandler
+
 handleRequest' :: ExternalState -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
 handleRequest' st external req mp responsehandler
 	| needsPREPARE req = do
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index cda934220..343004a85 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -36,7 +36,7 @@ import Types.StandardGroups (PreferredContentExpression)
 import Utility.Metered (BytesProcessed(..))
 import Types.Transfer (Direction(..))
 import Config.Cost (Cost)
-import Types.Remote (RemoteConfig)
+import Types.Remote (RemoteConfig, ExportLocation(..))
 import Types.Availability (Availability(..))
 import Types.Key
 import Utility.Url (URLString)
@@ -116,12 +116,19 @@ data Request
 	| CHECKPRESENT SafeKey
 	| REMOVE SafeKey
 	| WHEREIS SafeKey
+	| EXPORTSUPPORTED
+	| EXPORT ExportLocation
+	| TRANSFEREXPORT Direction SafeKey FilePath
+	| CHECKPRESENTEXPORT SafeKey
+	| REMOVEEXPORT SafeKey
+	| RENAMEEXPORT SafeKey ExportLocation
 	deriving (Show)
 
 -- Does PREPARE need to have been sent before this request?
 needsPREPARE :: Request -> Bool
 needsPREPARE PREPARE = False
 needsPREPARE INITREMOTE = False
+needsPREPARE EXPORTSUPPORTED = False
 needsPREPARE _ = True
 
 instance Proto.Sendable Request where
@@ -137,9 +144,27 @@ instance Proto.Sendable Request where
 		, Proto.serialize key
 		, Proto.serialize file
 		]
-	formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", Proto.serialize key ]
+	formatMessage (CHECKPRESENT key) =
+		[ "CHECKPRESENT", Proto.serialize key ]
 	formatMessage (REMOVE key) = [ "REMOVE", Proto.serialize key ]
 	formatMessage (WHEREIS key) = [ "WHEREIS", Proto.serialize key ]
+	formatMessage EXPORTSUPPORTED = ["EXPORTSUPPORTED"]
+	formatMessage (EXPORT loc) = [ "EXPORT", Proto.serialize loc ]
+	formatMessage (TRANSFEREXPORT direction key file) = 
+		[ "TRANSFEREXPORT"
+		, Proto.serialize direction
+		, Proto.serialize key
+		, Proto.serialize file
+		]
+	formatMessage (CHECKPRESENTEXPORT key) =
+		[ "CHECKPRESENTEXPORT", Proto.serialize key ]
+	formatMessage (REMOVEEXPORT key) =
+		[ "REMOVEEXPORT", Proto.serialize key ]
+	formatMessage (RENAMEEXPORT key newloc) =
+		[ "RENAMEEXPORT"
+		, Proto.serialize key
+		, Proto.serialize newloc
+		]
 
 -- Responses the external remote can make to requests.
 data Response
@@ -163,6 +188,10 @@ data Response
 	| CHECKURL_FAILURE ErrorMsg
 	| WHEREIS_SUCCESS String
 	| WHEREIS_FAILURE
+	| EXPORTSUPPORTED_SUCCESS
+	| EXPORTSUPPORTED_FAILURE
+	| RENAMEEXPORT_SUCCESS Key
+	| RENAMEEXPORT_FAILURE Key
 	| UNSUPPORTED_REQUEST
 	deriving (Show)
 
@@ -187,6 +216,10 @@ instance Proto.Receivable Response where
 	parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE
 	parseCommand "WHEREIS-SUCCESS" = Just . WHEREIS_SUCCESS
 	parseCommand "WHEREIS-FAILURE" = Proto.parse0 WHEREIS_FAILURE
+	parseCommand "EXPORTSUPPORTED-SUCCESS" = Proto.parse0 EXPORTSUPPORTED_SUCCESS
+	parseCommand "EXPORTSUPPORTED-FAILURE" = Proto.parse0 EXPORTSUPPORTED_FAILURE
+	parseCommand "RENAMEEXPORT-SUCCESS" = Proto.parse1 RENAMEEXPORT_SUCCESS
+	parseCommand "RENAMEEXPORT-FAILURE" = Proto.parse1 RENAMEEXPORT_FAILURE
 	parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST
 	parseCommand _ = Proto.parseFail
 
@@ -315,3 +348,7 @@ instance Proto.Serializable [(URLString, Size, FilePath)] where
 instance Proto.Serializable URI where
 	serialize = show
 	deserialize = parseURI
+
+instance Proto.Serializable ExportLocation where
+	serialize (ExportLocation loc) = loc
+	deserialize = Just . ExportLocation
diff --git a/Remote/Helper/Export.hs b/Remote/Helper/Export.hs
index 58533155b..dacf05845 100644
--- a/Remote/Helper/Export.hs
+++ b/Remote/Helper/Export.hs
@@ -28,8 +28,10 @@ instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) wh
 
 instance HasExportUnsupported (ExportActions Annex) where
 	exportUnsupported = ExportActions
-		{ storeExport = \_ _ _ _ -> return False
-		, retrieveExport = \_ _ _ _ -> return (False, UnVerified)
+		{ storeExport = \_ _ _ _ -> do
+			warning "store export is unsupported"
+			return False
+		, retrieveExport = \_ _ _ _ -> return False
 		, removeExport = \_ _ -> return False
 		, checkPresentExport = \_ _ -> return False
 		, renameExport = \_ _ _ -> return False
@@ -68,7 +70,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 		( isexport
 		, notexport
 		)
-	_ -> notexport
+	Nothing -> notexport
+	Just "no" -> notexport
+	Just _ -> error "bad exporttree value"
   where
 	notexport = return $ r { exportActions = exportUnsupported }
 	isexport = do
@@ -86,18 +90,18 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
 			-- Keys can be retrieved, but since an export
 			-- is not a true key/value store, the content of
 			-- the key has to be able to be strongly verified.
-			, retrieveKeyFile = \k _af dest p ->
+			, retrieveKeyFile = \k _af dest p -> unVerified $
 				if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))
 					then do
 						locs <- liftIO $ getExportLocation db k
 						case locs of
 							[] -> do
 								warning "unknown export location"
-								return (False, UnVerified)
+								return False
 							(l:_) -> retrieveExport (exportActions r) k l dest p
 					else do
 						warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"
-						return (False, UnVerified)
+						return False
 			, retrieveKeyFileCheap = \_ _ _ -> return False
 			-- Remove all files a key was exported to.
 			, removeKey = \k -> do