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

finish porting S3

Browse source
This commit is contained in:
Joey Hess 2020-01-15 10:52:28 -04:00
parent c4ea3ca40a
commit 0706d9d093
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
1 changed files with 39 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

46
Remote/S3.hs
View file

@ -73,7 +73,8 @@ remote = specialRemoteType $ RemoteType
{ typename = "S3" { typename = "S3"
, enumerate = const (findSpecialRemotes "s3") , enumerate = const (findSpecialRemotes "s3")
, generate = gen , generate = gen
, configParser = mkRemoteConfigParser , configParser = pure $ RemoteConfigParser
{ remoteConfigFieldParsers =
[ optionalStringParser bucketField [ optionalStringParser bucketField
, optionalStringParser hostField , optionalStringParser hostField
, optionalStringParser datacenterField , optionalStringParser datacenterField
@ -88,7 +89,8 @@ remote = specialRemoteType $ RemoteType
, optionalStringParser requeststyleField , optionalStringParser requeststyleField
, optionalStringParser mungekeysField , optionalStringParser mungekeysField
] ]
{ remoteConfigRestPassthrough = \f -> isMetaHeader f || isArchiveMetaHeader f , remoteConfigRestPassthrough = \f ->
isMetaHeader f || isArchiveMetaHeader f
} }
, setup = s3Setup , setup = s3Setup
, exportSupported = exportIsSupported , exportSupported = exportIsSupported
@ -191,7 +193,7 @@ gen r u c gc rs = do
, appendonly = versioning info , appendonly = versioning info
, availability = GloballyAvailable , availability = GloballyAvailable
, remotetype = remote , remotetype = remote
, mkUnavailable = gen r u (M.insert hostField (RemoteConfigValue "!dne!") c) gc rs , mkUnavailable = gen r u (M.insert hostField (RemoteConfigValue ("!dne!" :: String)) c) gc rs
, getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info) , getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info)
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
@ -205,7 +207,7 @@ s3Setup ss mu mcreds c gc = do
s3Setup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) s3Setup' :: SetupStage -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
s3Setup' ss u mcreds c gc s3Setup' ss u mcreds c gc
| configIA c = archiveorg | maybe False (isIAHost . fromProposedAccepted) (M.lookup hostField c) = archiveorg
| otherwise = defaulthost | otherwise = defaulthost
where where
remotename = fromJust (lookupName c) remotename = fromJust (lookupName c)
@ -218,8 +220,8 @@ s3Setup' ss u mcreds c gc
, (Proposed "bucket", Proposed defbucket) , (Proposed "bucket", Proposed defbucket)
] ]
use fullconfig info = do use fullconfig pc info = do
enableBucketVersioning ss info fullconfig gc u enableBucketVersioning ss info pc gc u
gitConfigSpecialRemote u fullconfig [("s3", "true")] gitConfigSpecialRemote u fullconfig [("s3", "true")]
return (fullconfig, u) return (fullconfig, u)
@ -227,21 +229,22 @@ s3Setup' ss u mcreds c gc
(c', encsetup) <- encryptionSetup c gc (c', encsetup) <- encryptionSetup c gc
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
let fullconfig = c'' `M.union` defaults let fullconfig = c'' `M.union` defaults
info <- extractS3Info fullconfig pc <- either giveup return . parseRemoteConfig fullconfig =<< configParser remote
checkexportimportsafe fullconfig info info <- extractS3Info pc
checkexportimportsafe pc info
case ss of case ss of
Init -> genBucket fullconfig gc u Init -> genBucket pc gc u
_ -> return () _ -> return ()
use fullconfig info use fullconfig pc info
archiveorg = do archiveorg = do
showNote "Internet Archive mode" showNote "Internet Archive mode"
c' <- setRemoteCredPair noEncryptionUsed c gc (AWS.creds u) mcreds c' <- setRemoteCredPair noEncryptionUsed c gc (AWS.creds u) mcreds
-- Ensure user enters a valid bucket name, since -- Ensure user enters a valid bucket name, since
-- this determines the name of the archive.org item. -- this determines the name of the archive.org item.
let validbucket = replace " " "-" $ let validbucket = replace " " "-" $ map toLower $
fromMaybe (giveup "specify bucket=") maybe (giveup "specify bucket=") fromProposedAccepted
(getBucketName c') (M.lookup bucketField c')
let archiveconfig = let archiveconfig =
-- IA acdepts x-amz-* as an alias for x-archive-* -- IA acdepts x-amz-* as an alias for x-archive-*
M.mapKeys (Proposed . replace "x-archive-" "x-amz-" . fromProposedAccepted) $ M.mapKeys (Proposed . replace "x-archive-" "x-amz-" . fromProposedAccepted) $
@ -251,12 +254,13 @@ s3Setup' ss u mcreds c gc
M.union c' $ M.union c' $
-- special constraints on key names -- special constraints on key names
M.insert (Proposed "mungekeys") (Proposed "ia") defaults M.insert (Proposed "mungekeys") (Proposed "ia") defaults
info <- extractS3Info archiveconfig pc <- either giveup return . parseRemoteConfig archiveconfig =<< configParser remote
checkexportimportsafe archiveconfig info info <- extractS3Info pc
hdl <- mkS3HandleVar archiveconfig gc u checkexportimportsafe pc info
hdl <- mkS3HandleVar pc gc u
withS3HandleOrFail u hdl $ withS3HandleOrFail u hdl $
writeUUIDFile archiveconfig u info writeUUIDFile pc u info
use archiveconfig info use archiveconfig pc info
checkexportimportsafe c' info = checkexportimportsafe c' info =
unlessM (Annex.getState Annex.force) $ unlessM (Annex.getState Annex.force) $
@ -931,8 +935,8 @@ getMetaHeaders = map munge
isMetaHeader :: RemoteConfigField -> Bool isMetaHeader :: RemoteConfigField -> Bool
isMetaHeader h = metaPrefix `isPrefixOf` fromProposedAccepted h isMetaHeader h = metaPrefix `isPrefixOf` fromProposedAccepted h
isArchiveMetaheader :: RemoteConfigField -> Bool isArchiveMetaHeader :: RemoteConfigField -> Bool
isArchiveMetaheader h = "x-archive-" `isPrefixOf` fromProposedAccepted h isArchiveMetaHeader h = "x-archive-" `isPrefixOf` fromProposedAccepted h
metaPrefix :: String metaPrefix :: String
metaPrefix = "x-amz-meta-" metaPrefix = "x-amz-meta-"
@ -943,7 +947,7 @@ getFilePrefix = fromMaybe "" . getRemoteConfigValue fileprefixField
getBucketObject :: ParsedRemoteConfig -> Key -> BucketObject getBucketObject :: ParsedRemoteConfig -> Key -> BucketObject
getBucketObject c = munge . serializeKey getBucketObject c = munge . serializeKey
where where
munge s = case getRemoteConfigValue mungekeysField c of munge s = case getRemoteConfigValue mungekeysField c :: Maybe String of
Just "ia" -> iaMunge $ getFilePrefix c ++ s Just "ia" -> iaMunge $ getFilePrefix c ++ s
_ -> getFilePrefix c ++ s _ -> getFilePrefix c ++ s