diff options
| -rw-r--r-- | CHANGELOG | 1 | ||||
| -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 | ||||
| -rw-r--r-- | Types/Remote.hs | 2 | ||||
| -rw-r--r-- | doc/design/external_special_remote_protocol.mdwn | 9 | ||||
| -rwxr-xr-x | doc/special_remotes/external/example.sh | 177 |
8 files changed, 306 insertions, 69 deletions
@@ -5,6 +5,7 @@ git-annex (6.20170819) UNRELEASED; urgency=medium * Use git-annex initremote with exporttree=yes to set up a special remote for use by git-annex export. * Implemented export to directory 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 allows writing to files whose write bit is not set. 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 diff --git a/Types/Remote.hs b/Types/Remote.hs index e2f36a55b..511653e98 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -175,7 +175,7 @@ data ExportActions a = ExportActions -- Retrieves exported content to a file. -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.) - , retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a (Bool, Verification) + , retrieveExport :: Key -> ExportLocation -> FilePath -> MeterUpdate -> a Bool -- Removes an exported file (succeeds if the contents are not present) , removeExport :: Key -> ExportLocation -> a Bool -- Checks if anything is exported to the remote at the specified diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn index 8a34bb2d7..95ef13041 100644 --- a/doc/design/external_special_remote_protocol.mdwn +++ b/doc/design/external_special_remote_protocol.mdwn @@ -153,7 +153,8 @@ replying with `UNSUPPORTED-REQUEST` is acceptable. Comes immediately before each of the following export-related requests, specifying the name of the exported file. It will be in the form of a relative path, and may contain path separators, whitespace, - and other special characters. + and other special characters. + No response is made to this message. * `TRANSFEREXPORT STORE|RETRIEVE Key File` Requests the transfer of a File on local disk to or from the previously provided Name on the special remote. @@ -253,12 +254,12 @@ while it's handling a request. Indicates that no location is known for a key. * `EXPORTSUPPORTED-SUCCESS` Indicates that it makes sense to use this special remote as an export. -* `EXPORTSUPPORTED` +* `EXPORTSUPPORTED-FAILURE` Indicates that it does not make sense to use this special remote as an export. -* `RENAMEEXPORT-SUCCESS` +* `RENAMEEXPORT-SUCCESS Key` Indicates that a `RENAMEEXPORT` was done successfully. -* `RENAMEEXPORT-FAILURE` +* `RENAMEEXPORT-FAILURE Key` Indicates that a `RENAMEEXPORT` failed for whatever reason. * `UNSUPPORTED-REQUEST` Indicates that the special remote does not know how to handle a request. diff --git a/doc/special_remotes/external/example.sh b/doc/special_remotes/external/example.sh index ed37ad9ec..81b4b6806 100755 --- a/doc/special_remotes/external/example.sh +++ b/doc/special_remotes/external/example.sh @@ -74,6 +74,81 @@ getcreds () { } +dostore () { + local key="$1" + local file="$2" + local loc="$3" + mkdir -p "$(dirname "$loc")" + # Store in temp file first, so that CHECKPRESENT does not see it + # until it is all stored. + mkdir -p "$mydirectory/tmp" + tmp="$mydirectory/tmp/$key" + # XXX when at all possible, send PROGRESS while transferring + # the file. + rm -f "$tmp" + if runcmd cp "$file" "$tmp" \ + && runcmd mv -f "$tmp" "$loc"; then + echo TRANSFER-SUCCESS STORE "$key" + else + echo TRANSFER-FAILURE STORE "$key" + fi + rmdir "$mydirectory/tmp" +} + +doretrieve () { + local key="$1" + local file="$2" + local loc="$3" + + # XXX when easy to do, send PROGRESS while transferring the file + if [ -e "$loc" ]; then + if runcmd cp "$loc" "$file"; then + echo TRANSFER-SUCCESS RETRIEVE "$key" + else + echo TRANSFER-FAILURE RETRIEVE "$key" + fi + else + echo TRANSFER-FAILURE RETRIEVE "$key" + fi +} + +docheckpresent () { + local key="$1" + local loc="$2" + + if [ -e "$loc" ]; then + echo CHECKPRESENT-SUCCESS "$key" + else + if [ -d "$mydirectory" ]; then + echo CHECKPRESENT-FAILURE "$key" + else + # When the directory does not exist, + # the remote is not available. + # (A network remote would similarly + # fail with CHECKPRESENT-UNKNOWN + # if it couldn't be contacted). + echo CHECKPRESENT-UNKNOWN "$key" "this remote is not currently available" + fi + fi +} + +doremove () { + local key="$1" + local loc="$2" + + # Note that it's not a failure to remove a + # fike that is not present. + if [ -e "$loc" ]; then + if runcmd rm -f "$loc"; then + echo REMOVE-SUCCESS "$key" + else + echo REMOVE-FAILURE "$key" + fi + else + echo REMOVE-SUCCESS "$key" + fi +} + # This has to come first, to get the protocol started. echo VERSION 1 @@ -130,76 +205,78 @@ while read line; do STORE) # Store the file to a location # based on the key. - # XXX when at all possible, send PROGRESS calclocation "$key" - mkdir -p "$(dirname "$LOC")" - # Store in temp file first, so that - # CHECKPRESENT does not see it - # until it is all stored. - mkdir -p "$mydirectory/tmp" - tmp="$mydirectory/tmp/$key" - if runcmd cp "$file" "$tmp" \ - && runcmd mv -f "$tmp" "$LOC"; then - echo TRANSFER-SUCCESS STORE "$key" - else - echo TRANSFER-FAILURE STORE "$key" - fi - - mkdir -p "$(dirname "$LOC")" - # The file may already exist, so - # make sure we can overwrite it. - chmod 644 "$LOC" 2>/dev/null || true + dostore "$key" "$file" "$LOC" ;; RETRIEVE) # Retrieve from a location based on # the key, outputting to the file. - # XXX when easy to do, send PROGRESS calclocation "$key" - if runcmd cp "$LOC" "$file"; then - echo TRANSFER-SUCCESS RETRIEVE "$key" - else - echo TRANSFER-FAILURE RETRIEVE "$key" - fi + doretrieve "$key" "$file" "$LOC" ;; esac ;; CHECKPRESENT) key="$2" calclocation "$key" - if [ -e "$LOC" ]; then - echo CHECKPRESENT-SUCCESS "$key" - else - if [ -d "$mydirectory" ]; then - echo CHECKPRESENT-FAILURE "$key" - else - # When the directory does not exist, - # the remote is not available. - # (A network remote would similarly - # fail with CHECKPRESENT-UNKNOWN - # if it couldn't be contacted). - echo CHECKPRESENT-UNKNOWN "$key" "this remote is not currently available" - fi - fi + docheckpresent "$key" "$LOC" ;; REMOVE) key="$2" calclocation "$key" - # Note that it's not a failure to remove a - # key that is not present. - if [ -e "$LOC" ]; then - if runcmd rm -f "$LOC"; then - echo REMOVE-SUCCESS "$key" - else - echo REMOVE-FAILURE "$key" - fi + doremove "$key" "$LOC" + ;; + # The requests listed above are all the ones + # that are required to be supported, so it's fine + # to respond to any others with UNSUPPORTED-REQUEST. + + # Let's also support exporting... + EXPORTSUPPORTED) + echo EXPORTSUPPORTED-SUCCESS + ;; + EXPORT) + shift 1 + exportlocation="$mydirectory/$@" + # No response to this one; this value is used below. + ;; + TRANSFEREXPORT) + op="$2" + key="$3" + shift 3 + file="$@" + case "$op" in + STORE) + # Store the file to the exportlocation + dostore "$key" "$file" "$exportlocation" + ;; + RETRIEVE) + # Retrieve from the exportlocation, + # outputting to the file. + doretrieve "$key" "$exportlocation" "$file" + ;; + esac + ;; + CHECKPRESENTEXPORT) + key="$2" + docheckpresent "$key" "$exportlocation" + ;; + REMOVEEXPORT) + key="$2" + doremove "$key" "$exportlocation" + ;; + RENAMEEXPORT) + key="$2" + shift 2 + newexportlocation="$mydirectory/$@" + mkdir -p "$(dirname "$newexportlocation")" + if runcmd mv -f "$exportlocation" "$newexportlocation"; then + echo RENAMEEXPORT-SUCCESS "$key" else - echo REMOVE-SUCCESS "$key" + echo RENAMEEXPORT-FAILURE "$key" fi ;; + *) - # The requests listed above are all the ones - # that are required to be supported, so it's fine - # to say that any other request is unsupported. echo UNSUPPORTED-REQUEST ;; esac |