mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

External special remote protocol extended to support export.

Browse source 
Also updated example.sh to support export.

This commit was supported by the NSF-funded DataLad project.
This commit is contained in:
Joey Hess 2017-09-08 14:24:05 -04:00
parent 3b885d7914
commit a1b195d84c
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
8 changed files with 306 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
CHANGELOG
View file

@ -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.

4
Remote/Directory.hs
View file

@ -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

125
Remote/External.hs
View file

@ -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

41
Remote/External/Types.hs vendored
View file

@ -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

16
Remote/Helper/Export.hs
View file

@ -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

2
Types/Remote.hs
View file

@ -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

9
doc/design/external_special_remote_protocol.mdwn
View file

@ -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.

177
doc/special_remotes/external/example.sh vendored
View file

@ -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