]
Nothing -> Nothing
+{- Gets all fields that remoteConfigRestPassthrough matched. -}
+getRemoteConfigPassedThrough :: ParsedRemoteConfig -> M.Map RemoteConfigField String
+getRemoteConfigPassedThrough = M.mapMaybe $ \v ->
+ case cast v of
+ Just (PassedThrough s) -> Just s
+ Nothing -> Nothing
+
+newtype PassedThrough = PassedThrough String
+
parseRemoteConfig :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig
parseRemoteConfig c rpc =
go [] (M.filterWithKey notaccepted c) (remoteConfigFieldParsers rpc ++ commonFieldParsers)
where
- go l c' []
- | remoteConfigRestPassthrough rpc = Right $ M.fromList $
- l ++ map (uncurry passthrough) (M.toList c')
- | M.null c' = Right (M.fromList l)
- | otherwise = Left $ "Unexpected fields: " ++
- unwords (map fromProposedAccepted (M.keys c'))
+ go l c' [] =
+ let (passover, leftovers) = partition
+ (remoteConfigRestPassthrough rpc . fst)
+ (M.toList c')
+ in if not (null leftovers)
+ then Left $ "Unexpected fields: " ++
+ unwords (map (fromProposedAccepted . fst) leftovers)
+ else Right $ M.fromList $
+ l ++ map (uncurry passthrough) passover
go l c' ((f, p):rest) = do
v <- p (M.lookup f c) c
case v of
Just v' -> go ((f,v'):l) (M.delete f c') rest
Nothing -> go l (M.delete f c') rest
- passthrough f v = (f, RemoteConfigValue (fromProposedAccepted v))
+ passthrough f v = (f, RemoteConfigValue (PassedThrough (fromProposedAccepted v)))
notaccepted (Proposed _) _ = True
notaccepted (Accepted _) _ = False
{- Remote on Android device accessed using adb.
-
- - Copyright 2018-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2018-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
import Annex.UUID
import Utility.Metered
import Types.ProposedAccepted
+import Annex.SpecialRemote.Config
import qualified Data.Map as M
import qualified System.FilePath.Posix as Posix
newtype AndroidPath = AndroidPath { fromAndroidPath :: FilePath }
remote :: RemoteType
-remote = RemoteType
+remote = specialRemoteType $ RemoteType
{ typename = "adb"
, enumerate = const (findSpecialRemotes "adb")
, generate = gen
+ , configParser = mkRemoteConfigParser
+ [ optionalStringParser androiddirectoryField
+ , optionalStringParser androidserialField
+ ]
, setup = adbSetup
, exportSupported = exportIsSupported
, importSupported = importIsSupported
}
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+androiddirectoryField :: RemoteConfigField
+androiddirectoryField = Accepted "androiddirectory"
+
+androidserialField :: RemoteConfigField
+androidserialField = Accepted "androidserial"
+
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = do
let this = Remote
{ uuid = u
adir <- maybe
(giveup "Specify androiddirectory=")
(pure . AndroidPath . fromProposedAccepted)
- (M.lookup (Accepted "androiddirectory") c)
+ (M.lookup androiddirectoryField c)
serial <- getserial =<< liftIO enumerateAdbConnected
- let c' = M.insert (Proposed "androidserial") (Proposed (fromAndroidSerial serial)) c
+ let c' = M.insert androidserialField (Proposed (fromAndroidSerial serial)) c
(c'', _encsetup) <- encryptionSetup c' gc
return (c'', u)
where
getserial [] = giveup "adb does not list any connected android devices. Plug in an Android device, or configure adb, and try again.."
- getserial l = case fromProposedAccepted <$> M.lookup (Accepted "androidserial") c of
+ getserial l = case fromProposedAccepted <$> M.lookup androidserialField c of
Nothing -> case l of
(s:[]) -> return s
_ -> giveup $ unlines $
{ typename = "bittorrent"
, enumerate = list
, generate = gen
+ , configParser = mkRemoteConfigParser []
, setup = error "not supported"
, exportSupported = exportUnsupported
, importSupported = importUnsupported
r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown)
return [r]
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r _ c gc rs = do
cst <- remoteCost gc expensiveRemoteCost
return $ Just Remote
{- Using bup as a remote.
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
import Config
import Config.Cost
import qualified Remote.Helper.Ssh as Ssh
+import Annex.SpecialRemote.Config
import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.ExportImport
type BupRepo = String
remote :: RemoteType
-remote = RemoteType
+remote = specialRemoteType $ RemoteType
{ typename = "bup"
, enumerate = const (findSpecialRemotes "buprepo")
, generate = gen
+ , configParser = mkRemoteConfigParser
+ [optionalStringParser buprepoField]
, setup = bupSetup
, exportSupported = exportUnsupported
, importSupported = importUnsupported
}
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+buprepoField :: RemoteConfigField
+buprepoField = Accepted "buprepo"
+
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = do
bupr <- liftIO $ bup2GitRemote buprepo
cst <- remoteCost gc $
-- verify configuration is sane
let buprepo = maybe (giveup "Specify buprepo=") fromProposedAccepted $
- M.lookup (Accepted "buprepo") c
+ M.lookup buprepoField c
(c', _encsetup) <- encryptionSetup c gc
-- bup init will create the repository.
import qualified Git
import Config
import Config.Cost
+import Annex.SpecialRemote.Config
import Remote.Helper.Special
import Remote.Helper.ExportImport
import Annex.Ssh
}
remote :: RemoteType
-remote = RemoteType
+remote = specialRemoteType $ RemoteType
{ typename = "ddar"
, enumerate = const (findSpecialRemotes "ddarrepo")
, generate = gen
+ , configParser = mkRemoteConfigParser
+ [optionalStringParser ddarrepoField]
, setup = ddarSetup
, exportSupported = exportUnsupported
, importSupported = importUnsupported
}
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+ddarrepoField :: RemoteConfigField
+ddarrepoField = Accepted "ddarrepo"
+
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = do
cst <- remoteCost gc $
if ddarLocal ddarrepo
-- verify configuration is sane
let ddarrepo = maybe (giveup "Specify ddarrepo=") fromProposedAccepted $
- M.lookup (Accepted "ddarrepo") c
+ M.lookup ddarrepoField c
(c', _encsetup) <- encryptionSetup c gc
-- The ddarrepo is stored in git config, as well as this repo's
{- Amazon Glacier remotes.
-
- - Copyright 2012 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
import qualified Git
import Config
import Config.Cost
+import Annex.SpecialRemote.Config
import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.ExportImport
type Archive = FilePath
remote :: RemoteType
-remote = RemoteType
+remote = specialRemoteType $ RemoteType
{ typename = "glacier"
, enumerate = const (findSpecialRemotes "glacier")
, generate = gen
+ , configParser = mkRemoteConfigParser
+ [ optionalStringParser datacenterField
+ , optionalStringParser vaultField
+ , optionalStringParser fileprefixField
+ ]
, setup = glacierSetup
, exportSupported = exportUnsupported
, importSupported = importUnsupported
}
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+datacenterField :: RemoteConfigField
+datacenterField = Accepted "datacenter"
+
+vaultField :: RemoteConfigField
+vaultField = Accepted "vault"
+
+fileprefixField :: RemoteConfigField
+fileprefixField = Accepted "fileprefix"
+
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = new <$> remoteCost gc veryExpensiveRemoteCost
where
new cst = Just $ specialRemote' specialcfg c
(c', encsetup) <- encryptionSetup c gc
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
let fullconfig = c'' `M.union` defaults
+ pc <- either giveup return . parseRemoteConfig fullconfig =<< configParser remote
case ss of
- Init -> genVault fullconfig gc u
+ Init -> genVault pc gc u
_ -> return ()
gitConfigSpecialRemote u fullconfig [("glacier", "true")]
return (fullconfig, u)
glacierAction :: Remote -> [CommandParam] -> Annex Bool
glacierAction r = runGlacier (config r) (gitconfig r) (uuid r)
-runGlacier :: RemoteConfig -> RemoteGitConfig -> UUID -> [CommandParam] -> Annex Bool
+runGlacier :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> [CommandParam] -> Annex Bool
runGlacier c gc u params = go =<< glacierEnv c gc u
where
go Nothing = return False
go (Just e) = liftIO $
boolSystemEnv "glacier" (glacierParams c params) (Just e)
-glacierParams :: RemoteConfig -> [CommandParam] -> [CommandParam]
+glacierParams :: ParsedRemoteConfig -> [CommandParam] -> [CommandParam]
glacierParams c params = datacenter:params
where
datacenter = Param $ "--region=" ++
- maybe (giveup "Missing datacenter configuration") fromProposedAccepted
- (M.lookup (Accepted "datacenter") c)
+ fromMaybe (giveup "Missing datacenter configuration")
+ (getRemoteConfigValue datacenterField c)
-glacierEnv :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)])
+glacierEnv :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)])
glacierEnv c gc u = do
liftIO checkSaneGlacierCommand
go =<< getRemoteCredPairFor "glacier" c gc creds
creds = AWS.creds u
(uk, pk) = credPairEnvironment creds
-getVault :: RemoteConfig -> Vault
-getVault = maybe (giveup "Missing vault configuration") fromProposedAccepted
- . M.lookup (Accepted "vault")
+getVault :: ParsedRemoteConfig -> Vault
+getVault = fromMaybe (giveup "Missing vault configuration")
+ . getRemoteConfigValue vaultField
archive :: Remote -> Key -> Archive
archive r k = fileprefix ++ serializeKey k
where
- fileprefix = maybe "" fromProposedAccepted $
- M.lookup (Accepted "fileprefix") $ config r
+ fileprefix = fromMaybe "" $
+ getRemoteConfigValue fileprefixField $ config r
-genVault :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
+genVault :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
genVault c gc u = unlessM (runGlacier c gc u params) $
giveup "Failed creating glacier vault."
where
parseEncryptionConfig :: RemoteConfig -> Either String ParsedRemoteConfig
parseEncryptionConfig c = parseRemoteConfig
(M.restrictKeys c encryptionConfigs)
- (RemoteConfigParser encryptionConfigParsers False)
+ (RemoteConfigParser encryptionConfigParsers (const False))
parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod
parseEncryptionMethod (Just "none") _ = Right NoneEncryption
{- A remote that provides hooks to run shell commands.
-
- - Copyright 2011 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
import Config
import Config.Cost
import Annex.UUID
+import Annex.SpecialRemote.Config
import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.ExportImport
type HookName = String
remote :: RemoteType
-remote = RemoteType
+remote = specialRemoteType $ RemoteType
{ typename = "hook"
, enumerate = const (findSpecialRemotes "hooktype")
, generate = gen
+ , configParser = mkRemoteConfigParser
+ [optionalStringParser hooktypeField]
, setup = hookSetup
, exportSupported = exportUnsupported
, importSupported = importUnsupported
}
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+hooktypeField :: RemoteConfigField
+hooktypeField = Accepted "hooktype"
+
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost
return $ Just $ specialRemote c
hookSetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu
let hooktype = maybe (giveup "Specify hooktype=") fromProposedAccepted $
- M.lookup (Accepted "hooktype") c
+ M.lookup hooktypeField c
(c', _encsetup) <- encryptionSetup c gc
gitConfigSpecialRemote u c' [("hooktype", hooktype)]
return (c', u)
import qualified Remote.Git
import qualified Remote.GCrypt
import qualified Remote.P2P
-{-
#ifdef WITH_S3
import qualified Remote.S3
#endif
import qualified Remote.Bup
--}
import qualified Remote.Directory
-{-
import qualified Remote.Rsync
import qualified Remote.Web
import qualified Remote.BitTorrent
import qualified Remote.Tahoe
import qualified Remote.Glacier
import qualified Remote.Ddar
--}
import qualified Remote.GitLFS
-{-
import qualified Remote.Hook
+{-
import qualified Remote.External
-}
[ Remote.Git.remote
, Remote.GCrypt.remote
, Remote.P2P.remote
-{-
#ifdef WITH_S3
, Remote.S3.remote
#endif
, Remote.Bup.remote
--}
, Remote.Directory.remote
-{-
, Remote.Rsync.remote
, Remote.Web.remote
, Remote.BitTorrent.remote
, Remote.Tahoe.remote
, Remote.Glacier.remote
, Remote.Ddar.remote
--}
, Remote.GitLFS.remote
-{-
, Remote.Hook.remote
+{-
, Remote.External.remote
-}
]
{- S3 remotes
-
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
type BucketObject = String
remote :: RemoteType
-remote = RemoteType
+remote = specialRemoteType $ RemoteType
{ typename = "S3"
, enumerate = const (findSpecialRemotes "s3")
, generate = gen
+ , configParser = mkRemoteConfigParser
+ [ optionalStringParser bucketField
+ , optionalStringParser hostField
+ , optionalStringParser datacenterField
+ , optionalStringParser partsizeField
+ , optionalStringParser storageclassField
+ , optionalStringParser fileprefixField
+ , yesNoParser versioningField False
+ , yesNoParser publicField False
+ , optionalStringParser publicurlField
+ , optionalStringParser protocolField
+ , optionalStringParser portField
+ , optionalStringParser requeststyleField
+ , optionalStringParser mungekeysField
+ ]
+ { remoteConfigRestPassthrough = \f -> isMetaHeader f || isArchiveMetaHeader f
+ }
, setup = s3Setup
, exportSupported = exportIsSupported
, importSupported = importIsSupported
}
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+bucketField :: RemoteConfigField
+bucketField = Accepted "bucket"
+
+hostField :: RemoteConfigField
+hostField = Accepted "host"
+
+datacenterField :: RemoteConfigField
+datacenterField = Accepted "datacenter"
+
+partsizeField :: RemoteConfigField
+partsizeField = Accepted "partsize"
+
+storageclassField :: RemoteConfigField
+storageclassField = Accepted "storageclass"
+
+fileprefixField :: RemoteConfigField
+fileprefixField = Accepted "fileprefix"
+
+versioningField :: RemoteConfigField
+versioningField = Accepted "versioning"
+
+publicField :: RemoteConfigField
+publicField = Accepted "public"
+
+publicurlField :: RemoteConfigField
+publicurlField = Accepted "publicurl"
+
+protocolField :: RemoteConfigField
+protocolField = Accepted "protocol"
+
+requeststyleField :: RemoteConfigField
+requeststyleField = Accepted "requeststyle"
+
+portField :: RemoteConfigField
+portField = Accepted "port"
+
+mungekeysField :: RemoteConfigField
+mungekeysField = Accepted "mungekeys"
+
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost
info <- extractS3Info c
, appendonly = versioning info
, availability = GloballyAvailable
, remotetype = remote
- , mkUnavailable = gen r u (M.insert (Accepted "host") (Accepted "!dne!") c) gc rs
+ , mkUnavailable = gen r u (M.insert hostField (RemoteConfigValue "!dne!") c) gc rs
, getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info)
, claimUrl = Nothing
, checkUrl = Nothing
remotename = fromJust (lookupName c)
defbucket = remotename ++ "-" ++ fromUUID u
defaults = M.fromList
- [ (Proposed "datacenter", Proposed $ T.unpack $ AWS.defaultRegion AWS.S3)
+ [ (datacenterField, Proposed $ T.unpack $ AWS.defaultRegion AWS.S3)
, (Proposed "storageclass", Proposed "STANDARD")
- , (Proposed "host", Proposed AWS.s3DefaultHost)
+ , (hostField, Proposed AWS.s3DefaultHost)
, (Proposed "port", Proposed "80")
, (Proposed "bucket", Proposed defbucket)
]
- checkconfigsane = do
- checkyesno "versioning"
- checkyesno "public"
- checkyesno k = case parseProposedAccepted (Accepted k) c yesNo False "yes or no" of
- Left err -> giveup err
- Right _ -> noop
-
use fullconfig info = do
enableBucketVersioning ss info fullconfig gc u
gitConfigSpecialRemote u fullconfig [("s3", "true")]
return (fullconfig, u)
defaulthost = do
- checkconfigsane
(c', encsetup) <- encryptionSetup c gc
c'' <- setRemoteCredPair encsetup c' gc (AWS.creds u) mcreds
let fullconfig = c'' `M.union` defaults
archiveorg = do
showNote "Internet Archive mode"
- checkconfigsane
c' <- setRemoteCredPair noEncryptionUsed c gc (AWS.creds u) mcreds
-- Ensure user enters a valid bucket name, since
-- this determines the name of the archive.org item.
(getBucketName c')
let archiveconfig =
-- 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) $
-- encryption does not make sense here
M.insert encryptionField (Proposed "none") $
M.insert (Accepted "bucket") (Proposed validbucket) $
{- Implemented as a fileRetriever, that uses conduit to stream the chunks
- out to the file. Would be better to implement a byteRetriever, but
- that is difficult. -}
-retrieve :: S3HandleVar -> Remote -> RemoteStateHandle -> RemoteConfig -> S3Info -> Retriever
+retrieve :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Retriever
retrieve hv r rs c info = fileRetriever $ \f k p -> withS3Handle hv $ \case
(Just h) ->
eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case
S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
return $ either (const False) (const True) res
-checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> RemoteConfig -> S3Info -> CheckPresent
+checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent
checkKey hv r rs c info k = withS3Handle hv $ \case
Just h -> do
showChecking r
- so first check if the UUID file already exists and we can skip creating
- it.
-}
-genBucket :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
+genBucket :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
genBucket c gc u = do
showAction "checking bucket"
info <- extractS3Info c
writeUUIDFile c u info h
locconstraint = mkLocationConstraint $ T.pack datacenter
- datacenter = fromProposedAccepted $ fromJust $
- M.lookup (Accepted "datacenter") c
+ datacenter = fromJust $ getRemoteConfigValue datacenterField c
-- "NEARLINE" as a storage class when creating a bucket is a
-- nonstandard extension of Google Cloud Storage.
storageclass = case getStorageClass c of
- Note that IA buckets can only created by having a file
- stored in them. So this also takes care of that.
-}
-writeUUIDFile :: RemoteConfig -> UUID -> S3Info -> S3Handle -> Annex ()
+writeUUIDFile :: ParsedRemoteConfig -> UUID -> S3Info -> S3Handle -> Annex ()
writeUUIDFile c u info h = do
v <- checkUUIDFile c u info h
case v of
{- Checks if the UUID file exists in the bucket
- and has the specified UUID already. -}
-checkUUIDFile :: RemoteConfig -> UUID -> S3Info -> S3Handle -> Annex (Either SomeException Bool)
+checkUUIDFile :: ParsedRemoteConfig -> UUID -> S3Info -> S3Handle -> Annex (Either SomeException Bool)
checkUUIDFile c u info h = tryNonAsync $ liftIO $ runResourceT $ do
resp <- tryS3 $ sendS3Handle h (S3.getObject (bucket info) file)
case resp of
file = T.pack $ uuidFile c
uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u]
-uuidFile :: RemoteConfig -> FilePath
+uuidFile :: ParsedRemoteConfig -> FilePath
uuidFile c = getFilePrefix c ++ "annex-uuid"
tryS3 :: ResourceT IO a -> ResourceT IO (Either S3.S3Error a)
{- Prepares a S3Handle for later use. Does not connect to S3 or do anything
- else expensive. -}
-mkS3HandleVar :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar
+mkS3HandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar
mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ do
mcreds <- getRemoteCredPair c gc (AWS.creds u)
case mcreds of
needS3Creds :: UUID -> String
needS3Creds u = missingCredPairFor "S3" (AWS.creds u)
-s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery
+s3Configuration :: ParsedRemoteConfig -> S3.S3Configuration AWS.NormalQuery
s3Configuration c = cfg
{ S3.s3Port = port
- , S3.s3RequestStyle = case fromProposedAccepted <$> M.lookup (Accepted "requeststyle") c of
+ , S3.s3RequestStyle = case getRemoteConfigValue requeststyleField c of
Just "path" -> S3.PathStyle
Just s -> giveup $ "bad S3 requeststyle value: " ++ s
Nothing -> S3.s3RequestStyle cfg
}
where
- h = fromProposedAccepted $ fromJust $
- M.lookup (Accepted "host") c
- datacenter = fromProposedAccepted $ fromJust $
- M.lookup (Accepted "datacenter") c
+ h = fromJust $ getRemoteConfigValue hostField c
+ datacenter = fromJust $ getRemoteConfigValue datacenterField c
-- When the default S3 host is configured, connect directly to
-- the S3 endpoint for the configured datacenter.
-- When another host is configured, it's used as-is.
endpoint
| h == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter
| otherwise = T.encodeUtf8 $ T.pack h
- port = case fromProposedAccepted <$> M.lookup (Accepted "port") c of
+ port = case getRemoteConfigValue portField c of
Just s ->
case reads s of
[(p, _)]
Just AWS.HTTPS -> 443
Just AWS.HTTP -> 80
Nothing -> 80
- cfgproto = case fromProposedAccepted <$> M.lookup (Accepted "protocol") c of
+ cfgproto = case getRemoteConfigValue protocolField c of
Just "https" -> Just AWS.HTTPS
Just "http" -> Just AWS.HTTP
Just s -> giveup $ "bad S3 protocol value: " ++ s
, host :: Maybe String
}
-extractS3Info :: RemoteConfig -> Annex S3Info
+extractS3Info :: ParsedRemoteConfig -> Annex S3Info
extractS3Info c = do
b <- maybe
(giveup "S3 bucket not configured")
, metaHeaders = getMetaHeaders c
, partSize = getPartSize c
, isIA = configIA c
- , versioning = boolcfg "versioning"
- , public = boolcfg "public"
- , publicurl = fromProposedAccepted <$> M.lookup (Accepted "publicurl") c
- , host = fromProposedAccepted <$> M.lookup (Accepted "host") c
+ , versioning = fromMaybe False $
+ getRemoteConfigValue versioningField c
+ , public = fromMaybe False $
+ getRemoteConfigValue publicField c
+ , publicurl = getRemoteConfigValue publicurlField c
+ , host = getRemoteConfigValue hostField c
}
- where
- boolcfg k = fromMaybe False $
- yesNo . fromProposedAccepted =<< M.lookup (Accepted k) c
putObject :: S3Info -> T.Text -> RequestBody -> S3.PutObject
putObject info file rbody = (S3.putObject (bucket info) file rbody)
| public info = Just S3.AclPublicRead
| otherwise = Nothing
-getBucketName :: RemoteConfig -> Maybe BucketName
-getBucketName = map toLower . fromProposedAccepted
- <$$> M.lookup (Accepted "bucket")
+getBucketName :: ParsedRemoteConfig -> Maybe BucketName
+getBucketName = map toLower <$$> getRemoteConfigValue bucketField
-getStorageClass :: RemoteConfig -> S3.StorageClass
-getStorageClass c = case fromProposedAccepted <$> M.lookup (Accepted "storageclass") c of
+getStorageClass :: ParsedRemoteConfig -> S3.StorageClass
+getStorageClass c = case getRemoteConfigValue storageclassField c of
Just "REDUCED_REDUNDANCY" -> S3.ReducedRedundancy
Just s -> S3.OtherStorageClass (T.pack s)
_ -> S3.Standard
-getPartSize :: RemoteConfig -> Maybe Integer
-getPartSize c = readSize dataUnits . fromProposedAccepted
- =<< M.lookup (Accepted "partsize") c
+getPartSize :: ParsedRemoteConfig -> Maybe Integer
+getPartSize c = readSize dataUnits =<< getRemoteConfigValue partsizeField c
-getMetaHeaders :: RemoteConfig -> [(T.Text, T.Text)]
-getMetaHeaders = map munge . filter ismetaheader . map unwrap . M.assocs
+getMetaHeaders :: ParsedRemoteConfig -> [(T.Text, T.Text)]
+getMetaHeaders = map munge
+ . filter (isMetaHeader . fst)
+ . M.assocs
+ . getRemoteConfigPassedThrough
where
- unwrap (k, v) = (fromProposedAccepted k, fromProposedAccepted v)
- ismetaheader (h, _) = metaprefix `isPrefixOf` h
- metaprefix = "x-amz-meta-"
- metaprefixlen = length metaprefix
- munge (k, v) = (T.pack $ drop metaprefixlen k, T.pack v)
+ metaprefixlen = length metaPrefix
+ munge (k, v) = (T.pack $ drop metaprefixlen (fromProposedAccepted k), T.pack v)
+
+isMetaHeader :: RemoteConfigField -> Bool
+isMetaHeader h = metaPrefix `isPrefixOf` fromProposedAccepted h
+
+isArchiveMetaheader :: RemoteConfigField -> Bool
+isArchiveMetaheader h = "x-archive-" `isPrefixOf` fromProposedAccepted h
+
+metaPrefix :: String
+metaPrefix = "x-amz-meta-"
-getFilePrefix :: RemoteConfig -> String
-getFilePrefix = maybe "" fromProposedAccepted
- <$> M.lookup (Accepted "fileprefix")
+getFilePrefix :: ParsedRemoteConfig -> String
+getFilePrefix = fromMaybe "" . getRemoteConfigValue fileprefixField
-getBucketObject :: RemoteConfig -> Key -> BucketObject
+getBucketObject :: ParsedRemoteConfig -> Key -> BucketObject
getBucketObject c = munge . serializeKey
where
- munge s = case fromProposedAccepted <$> M.lookup (Accepted "mungekeys") c of
+ munge s = case getRemoteConfigValue mungekeysField c of
Just "ia" -> iaMunge $ getFilePrefix c ++ s
_ -> getFilePrefix c ++ s
-getBucketExportLocation :: RemoteConfig -> ExportLocation -> BucketObject
+getBucketExportLocation :: ParsedRemoteConfig -> ExportLocation -> BucketObject
getBucketExportLocation c loc =
getFilePrefix c ++ fromRawFilePath (fromExportLocation loc)
-getBucketImportLocation :: RemoteConfig -> BucketObject -> Maybe ImportLocation
+getBucketImportLocation :: ParsedRemoteConfig -> BucketObject -> Maybe ImportLocation
getBucketImportLocation c obj
-- The uuidFile should not be imported.
| obj == uuidfile = Nothing
| isSpace c = []
| otherwise = "&" ++ show (ord c) ++ ";"
-configIA :: RemoteConfig -> Bool
-configIA = maybe False (isIAHost . fromProposedAccepted)
- . M.lookup (Accepted "host")
+configIA :: ParsedRemoteConfig -> Bool
+configIA = maybe False isIAHost . getRemoteConfigValue hostField
{- Hostname to use for archive.org S3. -}
iaHost :: HostName
AWS.Warning -> warningM
AWS.Error -> errorM
-s3Info :: RemoteConfig -> S3Info -> [(String, String)]
+s3Info :: ParsedRemoteConfig -> S3Info -> [(String, String)]
s3Info c info = catMaybes
[ Just ("bucket", fromMaybe "unknown" (getBucketName c))
, Just ("endpoint", w82s (BS.unpack (S3.s3Endpoint s3c)))
showstorageclass (S3.OtherStorageClass t) = T.unpack t
showstorageclass sc = show sc
-getPublicWebUrls :: UUID -> RemoteStateHandle -> S3Info -> RemoteConfig -> Key -> Annex [URLString]
+getPublicWebUrls :: UUID -> RemoteStateHandle -> S3Info -> ParsedRemoteConfig -> Key -> Annex [URLString]
getPublicWebUrls u rs info c k = either (const []) id <$> getPublicWebUrls' u rs info c k
-getPublicWebUrls' :: UUID -> RemoteStateHandle -> S3Info -> RemoteConfig -> Key -> Annex (Either String [URLString])
+getPublicWebUrls' :: UUID -> RemoteStateHandle -> S3Info -> ParsedRemoteConfig -> Key -> Annex (Either String [URLString])
getPublicWebUrls' u rs info c k
| not (public info) = return $ Left $
"S3 bucket does not allow public access; " ++ needS3Creds u
s3VersionField :: MetaField
s3VersionField = mkMetaFieldUnchecked "V"
-eitherS3VersionID :: S3Info -> RemoteStateHandle -> RemoteConfig -> Key -> S3.Object -> Annex (Either String (Either S3.Object S3VersionID))
+eitherS3VersionID :: S3Info -> RemoteStateHandle -> ParsedRemoteConfig -> Key -> S3.Object -> Annex (Either String (Either S3.Object S3VersionID))
eitherS3VersionID info rs c k fallback
| versioning info = getS3VersionID rs k >>= return . \case
[] -> if exportTree c
-- Enable versioning on the bucket can only be done at init time;
-- setting versioning in a bucket that git-annex has already exported
-- files to risks losing the content of those un-versioned files.
-enableBucketVersioning :: SetupStage -> S3Info -> RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
+enableBucketVersioning :: SetupStage -> S3Info -> ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
#if MIN_VERSION_aws(0,21,1)
enableBucketVersioning ss info c gc u = do
#else
Init -> when (versioning info) $
enableversioning (bucket info)
Enable oldc -> do
- oldinfo <- extractS3Info oldc
+ oldpc <- either (const mempty) id
+ . parseRemoteConfig oldc
+ <$> configParser remote
+ oldinfo <- extractS3Info oldpc
when (versioning info /= versioning oldinfo) $
giveup "Cannot change versioning= of existing S3 remote."
where
-
- Tahoe has its own encryption, so git-annex's encryption is not used.
-
- - Copyright 2014 Joey Hess <id@joeyh.name>
+ - Copyright 2014-2019 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
type Capability = String
remote :: RemoteType
-remote = RemoteType
+remote = specialRemoteType $ RemoteType
{ typename = "tahoe"
, enumerate = const (findSpecialRemotes "tahoe")
, generate = gen
+ , configParser = mkRemoteConfigParser
+ [ optionalStringParser scsField
+ , optionalStringParser furlField
+ ]
, setup = tahoeSetup
, exportSupported = exportUnsupported
, importSupported = importUnsupported
}
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+scsField :: RemoteConfigField
+scsField = Accepted "shared-convergence-secret"
+
+furlField :: RemoteConfigField
+furlField = Accepted "introducer-furl"
+
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost
hdl <- liftIO $ TahoeHandle
tahoeSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
tahoeSetup _ mu _ c _ = do
- furl <- maybe (fromMaybe missingfurl $ M.lookup furlk c) Proposed
+ furl <- maybe (fromMaybe missingfurl $ M.lookup furlField c) Proposed
<$> liftIO (getEnv "TAHOE_FURL")
u <- maybe (liftIO genUUID) return mu
configdir <- liftIO $ defaultTahoeConfigDir u
scs <- liftIO $ tahoeConfigure configdir
(fromProposedAccepted furl)
- (fromProposedAccepted <$> (M.lookup scsk c))
- let c' = case parseProposedAccepted embedCredsField c yesNo False "yes or no" of
- Right (Just True) ->
- flip M.union c $ M.fromList
- [ (furlk, furl)
- , (scsk, Proposed scs)
- ]
- Right _ -> c
- Left err -> giveup err
+ (fromProposedAccepted <$> (M.lookup scsField c))
+ pc <- either giveup return . parseRemoteConfig c =<< configParser remote
+ let c' = if embedCreds pc
+ then flip M.union c $ M.fromList
+ [ (furlField, furl)
+ , (scsField, Proposed scs)
+ ]
+ else c
gitConfigSpecialRemote u c' [("tahoe", configdir)]
return (c', u)
where
- scsk = Accepted "shared-convergence-secret"
- furlk = Accepted "introducer-furl"
missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use."
store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
{- WebDAV remotes.
-
- - Copyright 2012-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
import qualified Git
import Config
import Config.Cost
+import Annex.SpecialRemote.Config
import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.Http
import Types.ProposedAccepted
remote :: RemoteType
-remote = RemoteType
+remote = specialRemoteType $ RemoteType
{ typename = "webdav"
, enumerate = const (findSpecialRemotes "webdav")
, generate = gen
+ , configParser = mkRemoteConfigParser
+ [ optionalStringParser urlField
+ ]
, setup = webdavSetup
, exportSupported = exportIsSupported
, importSupported = importUnsupported
}
-gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
+urlField :: RemoteConfigField
+urlField = Accepted "url"
+
+gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost
where
new cst = Just $ specialRemote c
, appendonly = False
, availability = GloballyAvailable
, remotetype = remote
- , mkUnavailable = gen r u (M.insert (Accepted "url") (Accepted "http://!dne!/") c) gc rs
+ , mkUnavailable = gen r u (M.insert urlField (RemoteConfigValue "http://!dne!/") c) gc rs
, getInfo = includeCredsInfo c (davCreds u) $
- [("url", maybe "unknown" fromProposedAccepted (M.lookup (Accepted "url") c))]
+ [("url", fromMaybe "unknown" $ getRemoteConfigValue urlField c)]
, claimUrl = Nothing
, checkUrl = Nothing
, remoteStateHandle = rs
u <- maybe (liftIO genUUID) return mu
url <- maybe (giveup "Specify url=")
(return . fromProposedAccepted)
- (M.lookup (Accepted "url") c)
+ (M.lookup urlField c)
(c', encsetup) <- encryptionSetup c gc
- creds <- maybe (getCreds c' gc u) (return . Just) mcreds
+ pc <- either giveup return . parseRemoteConfig c' =<< configParser remote
+ creds <- maybe (getCreds pc gc u) (return . Just) mcreds
testDav url creds
gitConfigSpecialRemote u c' [("webdav", "true")]
c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds
runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))
configUrl :: Remote -> Maybe URLString
-configUrl r = fixup . fromProposedAccepted
- <$> M.lookup (Accepted "url") (config r)
+configUrl r = fixup <$> getRemoteConfigValue urlField (config r)
where
-- box.com DAV url changed
fixup = replace "https://www.box.com/dav/" boxComUrl
inLocation d mkCol
)
-getCreds :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair)
+getCreds :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair)
getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u)
davCreds :: UUID -> CredPairStorage
data RemoteConfigParser = RemoteConfigParser
{ remoteConfigFieldParsers :: [RemoteConfigFieldParser]
- , remoteConfigRestPassthrough :: Bool
+ , remoteConfigRestPassthrough :: RemoteConfigField -> Bool
}
mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> m RemoteConfigParser
-mkRemoteConfigParser l = pure (RemoteConfigParser l False)
+mkRemoteConfigParser l = pure (RemoteConfigParser l (const False))
addRemoteConfigParser :: [RemoteConfigFieldParser] -> RemoteConfigParser -> RemoteConfigParser
addRemoteConfigParser l rpc = rpc { remoteConfigFieldParsers = remoteConfigFieldParsers rpc ++ l }
projects / git-annex.git / commitdiff