From c4ea3ca40ae6ba973287ca94e892e93973a8376e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 14 Jan 2020 15:41:34 -0400 Subject: [PATCH] ported almost all remotes, until my brain melted external is not started yet, and S3 is part way through and not compiling yet --- Annex/SpecialRemote/Config.hs | 26 +++-- Remote/Adb.hs | 23 ++-- Remote/BitTorrent.hs | 3 +- Remote/Bup.hs | 14 ++- Remote/Ddar.hs | 12 ++- Remote/Glacier.hs | 46 +++++--- Remote/Helper/Encryptable.hs | 2 +- Remote/Hook.hs | 14 ++- Remote/List.hs | 12 +-- Remote/S3.hs | 195 +++++++++++++++++++++------------- Remote/Tahoe.hs | 37 ++++--- Remote/WebDAV.hs | 27 +++-- Types/RemoteConfig.hs | 4 +- 13 files changed, 265 insertions(+), 150 deletions(-) diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs index 0a30d46330..e0f2d4c39f 100644 --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -166,23 +166,35 @@ getRemoteConfigValue f m = case M.lookup f m of ] 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 diff --git a/Remote/Adb.hs b/Remote/Adb.hs index 4080ed61ad..4f8e1750d5 100644 --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -1,6 +1,6 @@ {- Remote on Android device accessed using adb. - - - Copyright 2018-2019 Joey Hess + - Copyright 2018-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,6 +20,7 @@ import Remote.Helper.ExportImport 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 @@ -32,16 +33,26 @@ newtype AndroidSerial = AndroidSerial { fromAndroidSerial :: String } 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 @@ -113,9 +124,9 @@ adbSetup _ mu _ c gc = do 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 @@ -133,7 +144,7 @@ adbSetup _ mu _ c gc = do 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 $ diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 0bbf4b24a7..9c1b96a05d 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -41,6 +41,7 @@ remote = RemoteType { typename = "bittorrent" , enumerate = list , generate = gen + , configParser = mkRemoteConfigParser [] , setup = error "not supported" , exportSupported = exportUnsupported , importSupported = importUnsupported @@ -52,7 +53,7 @@ list _autoinit = do 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 diff --git a/Remote/Bup.hs b/Remote/Bup.hs index a283fe07f1..73328f972f 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -1,6 +1,6 @@ {- Using bup as a remote. - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -25,6 +25,7 @@ import qualified Git.Ref 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 @@ -38,16 +39,21 @@ import Types.ProposedAccepted 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 $ @@ -110,7 +116,7 @@ bupSetup _ mu _ c gc = do -- 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. diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index 96e9364524..a344c0166a 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -18,6 +18,7 @@ import Types.Creds import qualified Git import Config import Config.Cost +import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.ExportImport import Annex.Ssh @@ -31,16 +32,21 @@ data DdarRepo = DdarRepo } 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 @@ -100,7 +106,7 @@ ddarSetup _ mu _ c gc = do -- 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 diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 6f5af226e5..02a7b5c264 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -1,6 +1,6 @@ {- Amazon Glacier remotes. - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -16,6 +16,7 @@ import Types.Remote import qualified Git import Config import Config.Cost +import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.ExportImport @@ -31,16 +32,30 @@ type Vault = String 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 @@ -100,8 +115,9 @@ glacierSetup' ss u mcreds c gc = do (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) @@ -225,21 +241,21 @@ checkKey r k = do 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 @@ -252,17 +268,17 @@ glacierEnv c gc u = do 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 diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index cb8cee8074..714a12f279 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -72,7 +72,7 @@ encryptionConfigs = S.fromList (map fst encryptionConfigParsers) 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 diff --git a/Remote/Hook.hs b/Remote/Hook.hs index f3ef2a8cfe..b3f8e02618 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -1,6 +1,6 @@ {- A remote that provides hooks to run shell commands. - - - Copyright 2011 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -15,6 +15,7 @@ import Git.Types (fromConfigKey, fromConfigValue) import Config import Config.Cost import Annex.UUID +import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.ExportImport @@ -28,16 +29,21 @@ type Action = String 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 @@ -87,7 +93,7 @@ hookSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> Remot 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) diff --git a/Remote/List.hs b/Remote/List.hs index e65e9d1c7e..921431b201 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -27,14 +27,11 @@ import qualified Git.Config 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 @@ -45,10 +42,9 @@ import qualified Remote.Adb import qualified Remote.Tahoe import qualified Remote.Glacier import qualified Remote.Ddar --} import qualified Remote.GitLFS -{- import qualified Remote.Hook +{- import qualified Remote.External -} @@ -57,14 +53,11 @@ remoteTypes = map adjustExportImportRemoteType [ 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 @@ -75,10 +68,9 @@ remoteTypes = map adjustExportImportRemoteType , Remote.Tahoe.remote , Remote.Glacier.remote , Remote.Ddar.remote --} , Remote.GitLFS.remote -{- , Remote.Hook.remote +{- , Remote.External.remote -} ] diff --git a/Remote/S3.hs b/Remote/S3.hs index 0b118f61ba..18d1daa0fb 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -1,6 +1,6 @@ {- S3 remotes - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -69,16 +69,72 @@ type BucketName = String 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 @@ -135,7 +191,7 @@ gen r u c gc rs = do , 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 @@ -155,27 +211,19 @@ s3Setup' ss u mcreds c gc 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 @@ -188,7 +236,6 @@ s3Setup' ss u mcreds c gc 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. @@ -197,7 +244,7 @@ s3Setup' ss u mcreds c gc (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) $ @@ -303,7 +350,7 @@ storeHelper info h magic f object p = liftIO $ case partSize info of {- 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 @@ -340,7 +387,7 @@ remove hv r info k = withS3HandleOrFail (uuid r) hv $ \h -> liftIO $ runResource 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 @@ -637,7 +684,7 @@ checkPresentExportWithContentIdentifierS3 hv r info _k loc knowncids = - 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 @@ -662,8 +709,7 @@ genBucket c gc u = do 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 @@ -678,7 +724,7 @@ genBucket c gc u = do - 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 @@ -695,7 +741,7 @@ writeUUIDFile c u info h = do {- 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 @@ -711,7 +757,7 @@ checkUUIDFile c u info h = tryNonAsync $ liftIO $ runResourceT $ do 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) @@ -735,7 +781,7 @@ type S3HandleVar = TVar (Either (Annex (Maybe S3Handle)) (Maybe S3Handle)) {- 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 @@ -766,26 +812,24 @@ withS3HandleOrFail u hv a = withS3Handle hv $ \case 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, _)] @@ -800,7 +844,7 @@ s3Configuration c = cfg 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 @@ -827,7 +871,7 @@ data S3Info = S3Info , host :: Maybe String } -extractS3Info :: RemoteConfig -> Annex S3Info +extractS3Info :: ParsedRemoteConfig -> Annex S3Info extractS3Info c = do b <- maybe (giveup "S3 bucket not configured") @@ -842,14 +886,13 @@ extractS3Info c = do , 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) @@ -864,45 +907,51 @@ acl info | 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) -getFilePrefix :: RemoteConfig -> String -getFilePrefix = maybe "" fromProposedAccepted - <$> M.lookup (Accepted "fileprefix") +isMetaHeader :: RemoteConfigField -> Bool +isMetaHeader h = metaPrefix `isPrefixOf` fromProposedAccepted h -getBucketObject :: RemoteConfig -> Key -> BucketObject +isArchiveMetaheader :: RemoteConfigField -> Bool +isArchiveMetaheader h = "x-archive-" `isPrefixOf` fromProposedAccepted h + +metaPrefix :: String +metaPrefix = "x-amz-meta-" + +getFilePrefix :: ParsedRemoteConfig -> String +getFilePrefix = fromMaybe "" . getRemoteConfigValue fileprefixField + +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 @@ -928,9 +977,8 @@ iaMunge = (>>= munge) | 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 @@ -982,7 +1030,7 @@ debugMapper level t = forward "S3" (T.unpack t) 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))) @@ -1001,10 +1049,10 @@ s3Info c info = catMaybes 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 @@ -1144,7 +1192,7 @@ getS3VersionID rs k = do 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 @@ -1169,7 +1217,7 @@ getS3VersionIDPublicUrls mk info rs k = -- 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 @@ -1179,7 +1227,10 @@ enableBucketVersioning ss info _ _ _ = do 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 diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index bbb40e80d7..b5ebd5ec55 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -13,7 +13,7 @@ - - Tahoe has its own encryption, so git-annex's encryption is not used. - - - Copyright 2014 Joey Hess + - Copyright 2014-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -54,16 +54,26 @@ type IntroducerFurl = String 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 @@ -104,26 +114,23 @@ gen r u c gc rs = do 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 diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index c5ef04e8cb..1abd176adb 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -1,6 +1,6 @@ {- WebDAV remotes. - - - Copyright 2012-2017 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -29,6 +29,7 @@ import Types.Export import qualified Git import Config import Config.Cost +import Annex.SpecialRemote.Config import Remote.Helper.Special import Remote.Helper.Messages import Remote.Helper.Http @@ -42,16 +43,22 @@ import Remote.WebDAV.DavLocation 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 @@ -96,9 +103,9 @@ gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost , 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 @@ -110,9 +117,10 @@ webdavSetup _ mu mcreds c gc = do 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 @@ -256,8 +264,7 @@ runExport Nothing _ = return False 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 @@ -337,7 +344,7 @@ mkColRecursive d = go =<< existsDAV d 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 diff --git a/Types/RemoteConfig.hs b/Types/RemoteConfig.hs index 4f6bb9b8fd..7b0b51ee5b 100644 --- a/Types/RemoteConfig.hs +++ b/Types/RemoteConfig.hs @@ -41,11 +41,11 @@ type RemoteConfigFieldParser = (RemoteConfigField, Maybe (ProposedAccepted Strin 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 }