diff options
author | Joey Hess <joeyh@joeyh.name> | 2017-09-08 14:24:05 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2017-09-08 14:24:05 -0400 |
commit | 23f55c0efdd58f8024d9b0c9e4b02db7b8d27b61 (patch) | |
tree | c6e008833ac2526f9681de86e244e23584639613 /Remote | |
parent | 1afbbef018b6a8e5d382c44c5e5366cf6ec65950 (diff) |
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.
Diffstat (limited to 'Remote')
-rw-r--r-- | Remote/Directory.hs | 4 | ||||
-rw-r--r-- | Remote/External.hs | 125 | ||||
-rw-r--r-- | Remote/External/Types.hs | 41 | ||||
-rw-r--r-- | Remote/Helper/Export.hs | 16 |
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 |