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

ported almost all remotes, until my brain melted

Browse source 
external is not started yet, and S3 is part way through and not
compiling yet
This commit is contained in:
Joey Hess 2020-01-14 15:41:34 -04:00
parent c498269a88
commit c4ea3ca40a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
13 changed files with 265 additions and 150 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
Annex/SpecialRemote/Config.hs
View file

@ -166,23 +166,35 @@ getRemoteConfigValue f m = case M.lookup f m of
] ]
Nothing -> Nothing 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 :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig
parseRemoteConfig c rpc = parseRemoteConfig c rpc =
go [] (M.filterWithKey notaccepted c) (remoteConfigFieldParsers rpc ++ commonFieldParsers) go [] (M.filterWithKey notaccepted c) (remoteConfigFieldParsers rpc ++ commonFieldParsers)
where where
go l c' [] go l c' [] =
| remoteConfigRestPassthrough rpc = Right $ M.fromList $ let (passover, leftovers) = partition
l ++ map (uncurry passthrough) (M.toList c') (remoteConfigRestPassthrough rpc . fst)
| M.null c' = Right (M.fromList l) (M.toList c')
| otherwise = Left $ "Unexpected fields: " ++ in if not (null leftovers)
unwords (map fromProposedAccepted (M.keys c')) 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 go l c' ((f, p):rest) = do
v <- p (M.lookup f c) c v <- p (M.lookup f c) c
case v of case v of
Just v' -> go ((f,v'):l) (M.delete f c') rest Just v' -> go ((f,v'):l) (M.delete f c') rest
Nothing -> go 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 (Proposed _) _ = True
notaccepted (Accepted _) _ = False notaccepted (Accepted _) _ = False

23
Remote/Adb.hs
View file

@ -1,6 +1,6 @@
{- Remote on Android device accessed using adb. {- 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -20,6 +20,7 @@ import Remote.Helper.ExportImport
import Annex.UUID import Annex.UUID
import Utility.Metered import Utility.Metered
import Types.ProposedAccepted import Types.ProposedAccepted
import Annex.SpecialRemote.Config
import qualified Data.Map as M import qualified Data.Map as M
import qualified System.FilePath.Posix as Posix import qualified System.FilePath.Posix as Posix
@ -32,16 +33,26 @@ newtype AndroidSerial = AndroidSerial { fromAndroidSerial :: String }
newtype AndroidPath = AndroidPath { fromAndroidPath :: FilePath } newtype AndroidPath = AndroidPath { fromAndroidPath :: FilePath }
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "adb" { typename = "adb"
, enumerate = const (findSpecialRemotes "adb") , enumerate = const (findSpecialRemotes "adb")
, generate = gen , generate = gen
, configParser = mkRemoteConfigParser
[ optionalStringParser androiddirectoryField
, optionalStringParser androidserialField
]
, setup = adbSetup , setup = adbSetup
, exportSupported = exportIsSupported , exportSupported = exportIsSupported
, importSupported = importIsSupported , 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 gen r u c gc rs = do
let this = Remote let this = Remote
{ uuid = u { uuid = u
@ -113,9 +124,9 @@ adbSetup _ mu _ c gc = do
adir <- maybe adir <- maybe
(giveup "Specify androiddirectory=") (giveup "Specify androiddirectory=")
(pure . AndroidPath . fromProposedAccepted) (pure . AndroidPath . fromProposedAccepted)
(M.lookup (Accepted "androiddirectory") c) (M.lookup androiddirectoryField c)
serial <- getserial =<< liftIO enumerateAdbConnected 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 (c'', _encsetup) <- encryptionSetup c' gc
@ -133,7 +144,7 @@ adbSetup _ mu _ c gc = do
return (c'', u) return (c'', u)
where where
getserial [] = giveup "adb does not list any connected android devices. Plug in an Android device, or configure adb, and try again.." 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 Nothing -> case l of
(s:[]) -> return s (s:[]) -> return s
_ -> giveup $ unlines $ _ -> giveup $ unlines $

3
Remote/BitTorrent.hs
View file

@ -41,6 +41,7 @@ remote = RemoteType
{ typename = "bittorrent" { typename = "bittorrent"
, enumerate = list , enumerate = list
, generate = gen , generate = gen
, configParser = mkRemoteConfigParser []
, setup = error "not supported" , setup = error "not supported"
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , importSupported = importUnsupported
@ -52,7 +53,7 @@ list _autoinit = do
r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown) r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown)
return [r] 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 gen r _ c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
return $ Just Remote return $ Just Remote

14
Remote/Bup.hs
View file

@ -1,6 +1,6 @@
{- Using bup as a 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -25,6 +25,7 @@ import qualified Git.Ref
import Config import Config
import Config.Cost import Config.Cost
import qualified Remote.Helper.Ssh as Ssh import qualified Remote.Helper.Ssh as Ssh
import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
@ -38,16 +39,21 @@ import Types.ProposedAccepted
type BupRepo = String type BupRepo = String
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "bup" { typename = "bup"
, enumerate = const (findSpecialRemotes "buprepo") , enumerate = const (findSpecialRemotes "buprepo")
, generate = gen , generate = gen
, configParser = mkRemoteConfigParser
[optionalStringParser buprepoField]
, setup = bupSetup , setup = bupSetup
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , 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 gen r u c gc rs = do
bupr <- liftIO $ bup2GitRemote buprepo bupr <- liftIO $ bup2GitRemote buprepo
cst <- remoteCost gc $ cst <- remoteCost gc $
@ -110,7 +116,7 @@ bupSetup _ mu _ c gc = do
-- verify configuration is sane -- verify configuration is sane
let buprepo = maybe (giveup "Specify buprepo=") fromProposedAccepted $ let buprepo = maybe (giveup "Specify buprepo=") fromProposedAccepted $
M.lookup (Accepted "buprepo") c M.lookup buprepoField c
(c', _encsetup) <- encryptionSetup c gc (c', _encsetup) <- encryptionSetup c gc
-- bup init will create the repository. -- bup init will create the repository.

12
Remote/Ddar.hs
View file

@ -18,6 +18,7 @@ import Types.Creds
import qualified Git import qualified Git
import Config import Config
import Config.Cost import Config.Cost
import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Annex.Ssh import Annex.Ssh
@ -31,16 +32,21 @@ data DdarRepo = DdarRepo
} }
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "ddar" { typename = "ddar"
, enumerate = const (findSpecialRemotes "ddarrepo") , enumerate = const (findSpecialRemotes "ddarrepo")
, generate = gen , generate = gen
, configParser = mkRemoteConfigParser
[optionalStringParser ddarrepoField]
, setup = ddarSetup , setup = ddarSetup
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , 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 gen r u c gc rs = do
cst <- remoteCost gc $ cst <- remoteCost gc $
if ddarLocal ddarrepo if ddarLocal ddarrepo
@ -100,7 +106,7 @@ ddarSetup _ mu _ c gc = do
-- verify configuration is sane -- verify configuration is sane
let ddarrepo = maybe (giveup "Specify ddarrepo=") fromProposedAccepted $ let ddarrepo = maybe (giveup "Specify ddarrepo=") fromProposedAccepted $
M.lookup (Accepted "ddarrepo") c M.lookup ddarrepoField c
(c', _encsetup) <- encryptionSetup c gc (c', _encsetup) <- encryptionSetup c gc
-- The ddarrepo is stored in git config, as well as this repo's -- The ddarrepo is stored in git config, as well as this repo's

46
Remote/Glacier.hs
View file

@ -1,6 +1,6 @@
{- Amazon Glacier remotes. {- 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -16,6 +16,7 @@ import Types.Remote
import qualified Git import qualified Git
import Config import Config
import Config.Cost import Config.Cost
import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
@ -31,16 +32,30 @@ type Vault = String
type Archive = FilePath type Archive = FilePath
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "glacier" { typename = "glacier"
, enumerate = const (findSpecialRemotes "glacier") , enumerate = const (findSpecialRemotes "glacier")
, generate = gen , generate = gen
, configParser = mkRemoteConfigParser
[ optionalStringParser datacenterField
, optionalStringParser vaultField
, optionalStringParser fileprefixField
]
, setup = glacierSetup , setup = glacierSetup
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , 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 gen r u c gc rs = new <$> remoteCost gc veryExpensiveRemoteCost
where where
new cst = Just $ specialRemote' specialcfg c new cst = Just $ specialRemote' specialcfg c
@ -100,8 +115,9 @@ glacierSetup' ss u mcreds c gc = do
(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
pc <- either giveup return . parseRemoteConfig fullconfig =<< configParser remote
case ss of case ss of
Init -> genVault fullconfig gc u Init -> genVault pc gc u
_ -> return () _ -> return ()
gitConfigSpecialRemote u fullconfig [("glacier", "true")] gitConfigSpecialRemote u fullconfig [("glacier", "true")]
return (fullconfig, u) return (fullconfig, u)
@ -225,21 +241,21 @@ checkKey r k = do
glacierAction :: Remote -> [CommandParam] -> Annex Bool glacierAction :: Remote -> [CommandParam] -> Annex Bool
glacierAction r = runGlacier (config r) (gitconfig r) (uuid r) 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 runGlacier c gc u params = go =<< glacierEnv c gc u
where where
go Nothing = return False go Nothing = return False
go (Just e) = liftIO $ go (Just e) = liftIO $
boolSystemEnv "glacier" (glacierParams c params) (Just e) boolSystemEnv "glacier" (glacierParams c params) (Just e)
glacierParams :: RemoteConfig -> [CommandParam] -> [CommandParam] glacierParams :: ParsedRemoteConfig -> [CommandParam] -> [CommandParam]
glacierParams c params = datacenter:params glacierParams c params = datacenter:params
where where
datacenter = Param $ "--region=" ++ datacenter = Param $ "--region=" ++
maybe (giveup "Missing datacenter configuration") fromProposedAccepted fromMaybe (giveup "Missing datacenter configuration")
(M.lookup (Accepted "datacenter") c) (getRemoteConfigValue datacenterField c)
glacierEnv :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)]) glacierEnv :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)])
glacierEnv c gc u = do glacierEnv c gc u = do
liftIO checkSaneGlacierCommand liftIO checkSaneGlacierCommand
go =<< getRemoteCredPairFor "glacier" c gc creds go =<< getRemoteCredPairFor "glacier" c gc creds
@ -252,17 +268,17 @@ glacierEnv c gc u = do
creds = AWS.creds u creds = AWS.creds u
(uk, pk) = credPairEnvironment creds (uk, pk) = credPairEnvironment creds
getVault :: RemoteConfig -> Vault getVault :: ParsedRemoteConfig -> Vault
getVault = maybe (giveup "Missing vault configuration") fromProposedAccepted getVault = fromMaybe (giveup "Missing vault configuration")
. M.lookup (Accepted "vault") . getRemoteConfigValue vaultField
archive :: Remote -> Key -> Archive archive :: Remote -> Key -> Archive
archive r k = fileprefix ++ serializeKey k archive r k = fileprefix ++ serializeKey k
where where
fileprefix = maybe "" fromProposedAccepted $ fileprefix = fromMaybe "" $
M.lookup (Accepted "fileprefix") $ config r getRemoteConfigValue fileprefixField $ config r
genVault :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex () genVault :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
genVault c gc u = unlessM (runGlacier c gc u params) $ genVault c gc u = unlessM (runGlacier c gc u params) $
giveup "Failed creating glacier vault." giveup "Failed creating glacier vault."
where where

2
Remote/Helper/Encryptable.hs
View file

@ -72,7 +72,7 @@ encryptionConfigs = S.fromList (map fst encryptionConfigParsers)
parseEncryptionConfig :: RemoteConfig -> Either String ParsedRemoteConfig parseEncryptionConfig :: RemoteConfig -> Either String ParsedRemoteConfig
parseEncryptionConfig c = parseRemoteConfig parseEncryptionConfig c = parseRemoteConfig
(M.restrictKeys c encryptionConfigs) (M.restrictKeys c encryptionConfigs)
(RemoteConfigParser encryptionConfigParsers False) (RemoteConfigParser encryptionConfigParsers (const False))
parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod parseEncryptionMethod :: Maybe String -> RemoteConfig -> Either String EncryptionMethod
parseEncryptionMethod (Just "none") _ = Right NoneEncryption parseEncryptionMethod (Just "none") _ = Right NoneEncryption

14
Remote/Hook.hs
View file

@ -1,6 +1,6 @@
{- A remote that provides hooks to run shell commands. {- 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -15,6 +15,7 @@ import Git.Types (fromConfigKey, fromConfigValue)
import Config import Config
import Config.Cost import Config.Cost
import Annex.UUID import Annex.UUID
import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages import Remote.Helper.Messages
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
@ -28,16 +29,21 @@ type Action = String
type HookName = String type HookName = String
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "hook" { typename = "hook"
, enumerate = const (findSpecialRemotes "hooktype") , enumerate = const (findSpecialRemotes "hooktype")
, generate = gen , generate = gen
, configParser = mkRemoteConfigParser
[optionalStringParser hooktypeField]
, setup = hookSetup , setup = hookSetup
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , 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 gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
return $ Just $ specialRemote c return $ Just $ specialRemote c
@ -87,7 +93,7 @@ hookSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> Remot
hookSetup _ mu _ c gc = do hookSetup _ mu _ c gc = do
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
let hooktype = maybe (giveup "Specify hooktype=") fromProposedAccepted $ let hooktype = maybe (giveup "Specify hooktype=") fromProposedAccepted $
M.lookup (Accepted "hooktype") c M.lookup hooktypeField c
(c', _encsetup) <- encryptionSetup c gc (c', _encsetup) <- encryptionSetup c gc
gitConfigSpecialRemote u c' [("hooktype", hooktype)] gitConfigSpecialRemote u c' [("hooktype", hooktype)]
return (c', u) return (c', u)

12
Remote/List.hs
View file

@ -27,14 +27,11 @@ import qualified Git.Config
import qualified Remote.Git import qualified Remote.Git
import qualified Remote.GCrypt import qualified Remote.GCrypt
import qualified Remote.P2P import qualified Remote.P2P
{-
#ifdef WITH_S3 #ifdef WITH_S3
import qualified Remote.S3 import qualified Remote.S3
#endif #endif
import qualified Remote.Bup import qualified Remote.Bup
-}
import qualified Remote.Directory import qualified Remote.Directory
{-
import qualified Remote.Rsync import qualified Remote.Rsync
import qualified Remote.Web import qualified Remote.Web
import qualified Remote.BitTorrent import qualified Remote.BitTorrent
@ -45,10 +42,9 @@ import qualified Remote.Adb
import qualified Remote.Tahoe import qualified Remote.Tahoe
import qualified Remote.Glacier import qualified Remote.Glacier
import qualified Remote.Ddar import qualified Remote.Ddar
-}
import qualified Remote.GitLFS import qualified Remote.GitLFS
{-
import qualified Remote.Hook import qualified Remote.Hook
{-
import qualified Remote.External import qualified Remote.External
-} -}
@ -57,14 +53,11 @@ remoteTypes = map adjustExportImportRemoteType
[ Remote.Git.remote [ Remote.Git.remote
, Remote.GCrypt.remote , Remote.GCrypt.remote
, Remote.P2P.remote , Remote.P2P.remote
{-
#ifdef WITH_S3 #ifdef WITH_S3
, Remote.S3.remote , Remote.S3.remote
#endif #endif
, Remote.Bup.remote , Remote.Bup.remote
-}
, Remote.Directory.remote , Remote.Directory.remote
{-
, Remote.Rsync.remote , Remote.Rsync.remote
, Remote.Web.remote , Remote.Web.remote
, Remote.BitTorrent.remote , Remote.BitTorrent.remote
@ -75,10 +68,9 @@ remoteTypes = map adjustExportImportRemoteType
, Remote.Tahoe.remote , Remote.Tahoe.remote
, Remote.Glacier.remote , Remote.Glacier.remote
, Remote.Ddar.remote , Remote.Ddar.remote
-}
, Remote.GitLFS.remote , Remote.GitLFS.remote
{-
, Remote.Hook.remote , Remote.Hook.remote
{-
, Remote.External.remote , Remote.External.remote
-} -}
] ]

193
Remote/S3.hs
View file

@ -1,6 +1,6 @@
{- S3 remotes {- 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -69,16 +69,72 @@ type BucketName = String
type BucketObject = String type BucketObject = String
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "S3" { typename = "S3"
, enumerate = const (findSpecialRemotes "s3") , enumerate = const (findSpecialRemotes "s3")
, generate = gen , 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 , setup = s3Setup
, exportSupported = exportIsSupported , exportSupported = exportIsSupported
, importSupported = importIsSupported , 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 gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
info <- extractS3Info c info <- extractS3Info c
@ -135,7 +191,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 (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) , getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info)
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
@ -155,27 +211,19 @@ s3Setup' ss u mcreds c gc
remotename = fromJust (lookupName c) remotename = fromJust (lookupName c)
defbucket = remotename ++ "-" ++ fromUUID u defbucket = remotename ++ "-" ++ fromUUID u
defaults = M.fromList 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 "storageclass", Proposed "STANDARD")
, (Proposed "host", Proposed AWS.s3DefaultHost) , (hostField, Proposed AWS.s3DefaultHost)
, (Proposed "port", Proposed "80") , (Proposed "port", Proposed "80")
, (Proposed "bucket", Proposed defbucket) , (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 use fullconfig info = do
enableBucketVersioning ss info fullconfig gc u enableBucketVersioning ss info fullconfig gc u
gitConfigSpecialRemote u fullconfig [("s3", "true")] gitConfigSpecialRemote u fullconfig [("s3", "true")]
return (fullconfig, u) return (fullconfig, u)
defaulthost = do defaulthost = do
checkconfigsane
(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
@ -188,7 +236,6 @@ s3Setup' ss u mcreds c gc
archiveorg = do archiveorg = do
showNote "Internet Archive mode" showNote "Internet Archive mode"
checkconfigsane
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.
@ -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 {- Implemented as a fileRetriever, that uses conduit to stream the chunks
- out to the file. Would be better to implement a byteRetriever, but - out to the file. Would be better to implement a byteRetriever, but
- that is difficult. -} - 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 retrieve hv r rs c info = fileRetriever $ \f k p -> withS3Handle hv $ \case
(Just h) -> (Just h) ->
eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case 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) S3.DeleteObject (T.pack $ bucketObject info k) (bucket info)
return $ either (const False) (const True) res 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 checkKey hv r rs c info k = withS3Handle hv $ \case
Just h -> do Just h -> do
showChecking r 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 - so first check if the UUID file already exists and we can skip creating
- it. - it.
-} -}
genBucket :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex () genBucket :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
genBucket c gc u = do genBucket c gc u = do
showAction "checking bucket" showAction "checking bucket"
info <- extractS3Info c info <- extractS3Info c
@ -662,8 +709,7 @@ genBucket c gc u = do
writeUUIDFile c u info h writeUUIDFile c u info h
locconstraint = mkLocationConstraint $ T.pack datacenter locconstraint = mkLocationConstraint $ T.pack datacenter
datacenter = fromProposedAccepted $ fromJust $ datacenter = fromJust $ getRemoteConfigValue datacenterField c
M.lookup (Accepted "datacenter") c
-- "NEARLINE" as a storage class when creating a bucket is a -- "NEARLINE" as a storage class when creating a bucket is a
-- nonstandard extension of Google Cloud Storage. -- nonstandard extension of Google Cloud Storage.
storageclass = case getStorageClass c of 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 - Note that IA buckets can only created by having a file
- stored in them. So this also takes care of that. - 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 writeUUIDFile c u info h = do
v <- checkUUIDFile c u info h v <- checkUUIDFile c u info h
case v of case v of
@ -695,7 +741,7 @@ writeUUIDFile c u info h = do
{- Checks if the UUID file exists in the bucket {- Checks if the UUID file exists in the bucket
- and has the specified UUID already. -} - 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 checkUUIDFile c u info h = tryNonAsync $ liftIO $ runResourceT $ do
resp <- tryS3 $ sendS3Handle h (S3.getObject (bucket info) file) resp <- tryS3 $ sendS3Handle h (S3.getObject (bucket info) file)
case resp of case resp of
@ -711,7 +757,7 @@ checkUUIDFile c u info h = tryNonAsync $ liftIO $ runResourceT $ do
file = T.pack $ uuidFile c file = T.pack $ uuidFile c
uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u] uuidb = L.fromChunks [T.encodeUtf8 $ T.pack $ fromUUID u]
uuidFile :: RemoteConfig -> FilePath uuidFile :: ParsedRemoteConfig -> FilePath
uuidFile c = getFilePrefix c ++ "annex-uuid" uuidFile c = getFilePrefix c ++ "annex-uuid"
tryS3 :: ResourceT IO a -> ResourceT IO (Either S3.S3Error a) 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 {- Prepares a S3Handle for later use. Does not connect to S3 or do anything
- else expensive. -} - else expensive. -}
mkS3HandleVar :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar mkS3HandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar
mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ do mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ do
mcreds <- getRemoteCredPair c gc (AWS.creds u) mcreds <- getRemoteCredPair c gc (AWS.creds u)
case mcreds of case mcreds of
@ -766,26 +812,24 @@ withS3HandleOrFail u hv a = withS3Handle hv $ \case
needS3Creds :: UUID -> String needS3Creds :: UUID -> String
needS3Creds u = missingCredPairFor "S3" (AWS.creds u) needS3Creds u = missingCredPairFor "S3" (AWS.creds u)
s3Configuration :: RemoteConfig -> S3.S3Configuration AWS.NormalQuery s3Configuration :: ParsedRemoteConfig -> S3.S3Configuration AWS.NormalQuery
s3Configuration c = cfg s3Configuration c = cfg
{ S3.s3Port = port { 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 "path" -> S3.PathStyle
Just s -> giveup $ "bad S3 requeststyle value: " ++ s Just s -> giveup $ "bad S3 requeststyle value: " ++ s
Nothing -> S3.s3RequestStyle cfg Nothing -> S3.s3RequestStyle cfg
} }
where where
h = fromProposedAccepted $ fromJust $ h = fromJust $ getRemoteConfigValue hostField c
M.lookup (Accepted "host") c datacenter = fromJust $ getRemoteConfigValue datacenterField c
datacenter = fromProposedAccepted $ fromJust $
M.lookup (Accepted "datacenter") c
-- When the default S3 host is configured, connect directly to -- When the default S3 host is configured, connect directly to
-- the S3 endpoint for the configured datacenter. -- the S3 endpoint for the configured datacenter.
-- When another host is configured, it's used as-is. -- When another host is configured, it's used as-is.
endpoint endpoint
| h == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter | h == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter
| otherwise = T.encodeUtf8 $ T.pack h | otherwise = T.encodeUtf8 $ T.pack h
port = case fromProposedAccepted <$> M.lookup (Accepted "port") c of port = case getRemoteConfigValue portField c of
Just s -> Just s ->
case reads s of case reads s of
[(p, _)] [(p, _)]
@ -800,7 +844,7 @@ s3Configuration c = cfg
Just AWS.HTTPS -> 443 Just AWS.HTTPS -> 443
Just AWS.HTTP -> 80 Just AWS.HTTP -> 80
Nothing -> 80 Nothing -> 80
cfgproto = case fromProposedAccepted <$> M.lookup (Accepted "protocol") c of cfgproto = case getRemoteConfigValue protocolField c of
Just "https" -> Just AWS.HTTPS Just "https" -> Just AWS.HTTPS
Just "http" -> Just AWS.HTTP Just "http" -> Just AWS.HTTP
Just s -> giveup $ "bad S3 protocol value: " ++ s Just s -> giveup $ "bad S3 protocol value: " ++ s
@ -827,7 +871,7 @@ data S3Info = S3Info
, host :: Maybe String , host :: Maybe String
} }
extractS3Info :: RemoteConfig -> Annex S3Info extractS3Info :: ParsedRemoteConfig -> Annex S3Info
extractS3Info c = do extractS3Info c = do
b <- maybe b <- maybe
(giveup "S3 bucket not configured") (giveup "S3 bucket not configured")
@ -842,14 +886,13 @@ extractS3Info c = do
, metaHeaders = getMetaHeaders c , metaHeaders = getMetaHeaders c
, partSize = getPartSize c , partSize = getPartSize c
, isIA = configIA c , isIA = configIA c
, versioning = boolcfg "versioning" , versioning = fromMaybe False $
, public = boolcfg "public" getRemoteConfigValue versioningField c
, publicurl = fromProposedAccepted <$> M.lookup (Accepted "publicurl") c , public = fromMaybe False $
, host = fromProposedAccepted <$> M.lookup (Accepted "host") c 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 :: S3Info -> T.Text -> RequestBody -> S3.PutObject
putObject info file rbody = (S3.putObject (bucket info) file rbody) putObject info file rbody = (S3.putObject (bucket info) file rbody)
@ -864,45 +907,51 @@ acl info
| public info = Just S3.AclPublicRead | public info = Just S3.AclPublicRead
| otherwise = Nothing | otherwise = Nothing
getBucketName :: RemoteConfig -> Maybe BucketName getBucketName :: ParsedRemoteConfig -> Maybe BucketName
getBucketName = map toLower . fromProposedAccepted getBucketName = map toLower <$$> getRemoteConfigValue bucketField
<$$> M.lookup (Accepted "bucket")
getStorageClass :: RemoteConfig -> S3.StorageClass getStorageClass :: ParsedRemoteConfig -> S3.StorageClass
getStorageClass c = case fromProposedAccepted <$> M.lookup (Accepted "storageclass") c of getStorageClass c = case getRemoteConfigValue storageclassField c of
Just "REDUCED_REDUNDANCY" -> S3.ReducedRedundancy Just "REDUCED_REDUNDANCY" -> S3.ReducedRedundancy
Just s -> S3.OtherStorageClass (T.pack s) Just s -> S3.OtherStorageClass (T.pack s)
_ -> S3.Standard _ -> S3.Standard
getPartSize :: RemoteConfig -> Maybe Integer getPartSize :: ParsedRemoteConfig -> Maybe Integer
getPartSize c = readSize dataUnits . fromProposedAccepted getPartSize c = readSize dataUnits =<< getRemoteConfigValue partsizeField c
=<< M.lookup (Accepted "partsize") c
getMetaHeaders :: RemoteConfig -> [(T.Text, T.Text)] getMetaHeaders :: ParsedRemoteConfig -> [(T.Text, T.Text)]
getMetaHeaders = map munge . filter ismetaheader . map unwrap . M.assocs getMetaHeaders = map munge
. filter (isMetaHeader . fst)
. M.assocs
. getRemoteConfigPassedThrough
where where
unwrap (k, v) = (fromProposedAccepted k, fromProposedAccepted v) metaprefixlen = length metaPrefix
ismetaheader (h, _) = metaprefix `isPrefixOf` h munge (k, v) = (T.pack $ drop metaprefixlen (fromProposedAccepted k), T.pack v)
metaprefix = "x-amz-meta-"
metaprefixlen = length metaprefix
munge (k, v) = (T.pack $ drop metaprefixlen k, T.pack v)
getFilePrefix :: RemoteConfig -> String isMetaHeader :: RemoteConfigField -> Bool
getFilePrefix = maybe "" fromProposedAccepted isMetaHeader h = metaPrefix `isPrefixOf` fromProposedAccepted h
<$> M.lookup (Accepted "fileprefix")
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 getBucketObject c = munge . serializeKey
where where
munge s = case fromProposedAccepted <$> M.lookup (Accepted "mungekeys") c of munge s = case getRemoteConfigValue mungekeysField c of
Just "ia" -> iaMunge $ getFilePrefix c ++ s Just "ia" -> iaMunge $ getFilePrefix c ++ s
_ -> getFilePrefix c ++ s _ -> getFilePrefix c ++ s
getBucketExportLocation :: RemoteConfig -> ExportLocation -> BucketObject getBucketExportLocation :: ParsedRemoteConfig -> ExportLocation -> BucketObject
getBucketExportLocation c loc = getBucketExportLocation c loc =
getFilePrefix c ++ fromRawFilePath (fromExportLocation loc) getFilePrefix c ++ fromRawFilePath (fromExportLocation loc)
getBucketImportLocation :: RemoteConfig -> BucketObject -> Maybe ImportLocation getBucketImportLocation :: ParsedRemoteConfig -> BucketObject -> Maybe ImportLocation
getBucketImportLocation c obj getBucketImportLocation c obj
-- The uuidFile should not be imported. -- The uuidFile should not be imported.
| obj == uuidfile = Nothing | obj == uuidfile = Nothing
@ -928,9 +977,8 @@ iaMunge = (>>= munge)
| isSpace c = [] | isSpace c = []
| otherwise = "&" ++ show (ord c) ++ ";" | otherwise = "&" ++ show (ord c) ++ ";"
configIA :: RemoteConfig -> Bool configIA :: ParsedRemoteConfig -> Bool
configIA = maybe False (isIAHost . fromProposedAccepted) configIA = maybe False isIAHost . getRemoteConfigValue hostField
. M.lookup (Accepted "host")
{- Hostname to use for archive.org S3. -} {- Hostname to use for archive.org S3. -}
iaHost :: HostName iaHost :: HostName
@ -982,7 +1030,7 @@ debugMapper level t = forward "S3" (T.unpack t)
AWS.Warning -> warningM AWS.Warning -> warningM
AWS.Error -> errorM AWS.Error -> errorM
s3Info :: RemoteConfig -> S3Info -> [(String, String)] s3Info :: ParsedRemoteConfig -> S3Info -> [(String, String)]
s3Info c info = catMaybes s3Info c info = catMaybes
[ Just ("bucket", fromMaybe "unknown" (getBucketName c)) [ Just ("bucket", fromMaybe "unknown" (getBucketName c))
, Just ("endpoint", w82s (BS.unpack (S3.s3Endpoint s3c))) , Just ("endpoint", w82s (BS.unpack (S3.s3Endpoint s3c)))
@ -1001,10 +1049,10 @@ s3Info c info = catMaybes
showstorageclass (S3.OtherStorageClass t) = T.unpack t showstorageclass (S3.OtherStorageClass t) = T.unpack t
showstorageclass sc = show sc 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 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 getPublicWebUrls' u rs info c k
| not (public info) = return $ Left $ | not (public info) = return $ Left $
"S3 bucket does not allow public access; " ++ needS3Creds u "S3 bucket does not allow public access; " ++ needS3Creds u
@ -1144,7 +1192,7 @@ getS3VersionID rs k = do
s3VersionField :: MetaField s3VersionField :: MetaField
s3VersionField = mkMetaFieldUnchecked "V" 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 eitherS3VersionID info rs c k fallback
| versioning info = getS3VersionID rs k >>= return . \case | versioning info = getS3VersionID rs k >>= return . \case
[] -> if exportTree c [] -> if exportTree c
@ -1169,7 +1217,7 @@ getS3VersionIDPublicUrls mk info rs k =
-- Enable versioning on the bucket can only be done at init time; -- Enable versioning on the bucket can only be done at init time;
-- setting versioning in a bucket that git-annex has already exported -- setting versioning in a bucket that git-annex has already exported
-- files to risks losing the content of those un-versioned files. -- 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) #if MIN_VERSION_aws(0,21,1)
enableBucketVersioning ss info c gc u = do enableBucketVersioning ss info c gc u = do
#else #else
@ -1179,7 +1227,10 @@ enableBucketVersioning ss info _ _ _ = do
Init -> when (versioning info) $ Init -> when (versioning info) $
enableversioning (bucket info) enableversioning (bucket info)
Enable oldc -> do Enable oldc -> do
oldinfo <- extractS3Info oldc oldpc <- either (const mempty) id
. parseRemoteConfig oldc
<$> configParser remote
oldinfo <- extractS3Info oldpc
when (versioning info /= versioning oldinfo) $ when (versioning info /= versioning oldinfo) $
giveup "Cannot change versioning= of existing S3 remote." giveup "Cannot change versioning= of existing S3 remote."
where where

35
Remote/Tahoe.hs
View file

@ -13,7 +13,7 @@
- -
- Tahoe has its own encryption, so git-annex's encryption is not used. - 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -54,16 +54,26 @@ type IntroducerFurl = String
type Capability = String type Capability = String
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "tahoe" { typename = "tahoe"
, enumerate = const (findSpecialRemotes "tahoe") , enumerate = const (findSpecialRemotes "tahoe")
, generate = gen , generate = gen
, configParser = mkRemoteConfigParser
[ optionalStringParser scsField
, optionalStringParser furlField
]
, setup = tahoeSetup , setup = tahoeSetup
, exportSupported = exportUnsupported , exportSupported = exportUnsupported
, importSupported = importUnsupported , 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 gen r u c gc rs = do
cst <- remoteCost gc expensiveRemoteCost cst <- remoteCost gc expensiveRemoteCost
hdl <- liftIO $ TahoeHandle 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 :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
tahoeSetup _ mu _ c _ = do 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") <$> liftIO (getEnv "TAHOE_FURL")
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
configdir <- liftIO $ defaultTahoeConfigDir u configdir <- liftIO $ defaultTahoeConfigDir u
scs <- liftIO $ tahoeConfigure configdir scs <- liftIO $ tahoeConfigure configdir
(fromProposedAccepted furl) (fromProposedAccepted furl)
(fromProposedAccepted <$> (M.lookup scsk c)) (fromProposedAccepted <$> (M.lookup scsField c))
let c' = case parseProposedAccepted embedCredsField c yesNo False "yes or no" of pc <- either giveup return . parseRemoteConfig c =<< configParser remote
Right (Just True) -> let c' = if embedCreds pc
flip M.union c $ M.fromList then flip M.union c $ M.fromList
[ (furlk, furl) [ (furlField, furl)
, (scsk, Proposed scs) , (scsField, Proposed scs)
] ]
Right _ -> c else c
Left err -> giveup err
gitConfigSpecialRemote u c' [("tahoe", configdir)] gitConfigSpecialRemote u c' [("tahoe", configdir)]
return (c', u) return (c', u)
where where
scsk = Accepted "shared-convergence-secret"
furlk = Accepted "introducer-furl"
missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use."
store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool

27
Remote/WebDAV.hs
View file

@ -1,6 +1,6 @@
{- WebDAV remotes. {- 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. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -29,6 +29,7 @@ import Types.Export
import qualified Git import qualified Git
import Config import Config
import Config.Cost import Config.Cost
import Annex.SpecialRemote.Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Messages import Remote.Helper.Messages
import Remote.Helper.Http import Remote.Helper.Http
@ -42,16 +43,22 @@ import Remote.WebDAV.DavLocation
import Types.ProposedAccepted import Types.ProposedAccepted
remote :: RemoteType remote :: RemoteType
remote = RemoteType remote = specialRemoteType $ RemoteType
{ typename = "webdav" { typename = "webdav"
, enumerate = const (findSpecialRemotes "webdav") , enumerate = const (findSpecialRemotes "webdav")
, generate = gen , generate = gen
, configParser = mkRemoteConfigParser
[ optionalStringParser urlField
]
, setup = webdavSetup , setup = webdavSetup
, exportSupported = exportIsSupported , exportSupported = exportIsSupported
, importSupported = importUnsupported , 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 gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost
where where
new cst = Just $ specialRemote c new cst = Just $ specialRemote c
@ -96,9 +103,9 @@ gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost
, appendonly = False , appendonly = False
, availability = GloballyAvailable , availability = GloballyAvailable
, remotetype = remote , 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) $ , getInfo = includeCredsInfo c (davCreds u) $
[("url", maybe "unknown" fromProposedAccepted (M.lookup (Accepted "url") c))] [("url", fromMaybe "unknown" $ getRemoteConfigValue urlField c)]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs , remoteStateHandle = rs
@ -110,9 +117,10 @@ webdavSetup _ mu mcreds c gc = do
u <- maybe (liftIO genUUID) return mu u <- maybe (liftIO genUUID) return mu
url <- maybe (giveup "Specify url=") url <- maybe (giveup "Specify url=")
(return . fromProposedAccepted) (return . fromProposedAccepted)
(M.lookup (Accepted "url") c) (M.lookup urlField c)
(c', encsetup) <- encryptionSetup c gc (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 testDav url creds
gitConfigSpecialRemote u c' [("webdav", "true")] gitConfigSpecialRemote u c' [("webdav", "true")]
c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds 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)) runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))
configUrl :: Remote -> Maybe URLString configUrl :: Remote -> Maybe URLString
configUrl r = fixup . fromProposedAccepted configUrl r = fixup <$> getRemoteConfigValue urlField (config r)
<$> M.lookup (Accepted "url") (config r)
where where
-- box.com DAV url changed -- box.com DAV url changed
fixup = replace "https://www.box.com/dav/" boxComUrl fixup = replace "https://www.box.com/dav/" boxComUrl
@ -337,7 +344,7 @@ mkColRecursive d = go =<< existsDAV d
inLocation d mkCol 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) getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u)
davCreds :: UUID -> CredPairStorage davCreds :: UUID -> CredPairStorage

4
Types/RemoteConfig.hs
View file

@ -41,11 +41,11 @@ type RemoteConfigFieldParser = (RemoteConfigField, Maybe (ProposedAccepted Strin
data RemoteConfigParser = RemoteConfigParser data RemoteConfigParser = RemoteConfigParser
{ remoteConfigFieldParsers :: [RemoteConfigFieldParser] { remoteConfigFieldParsers :: [RemoteConfigFieldParser]
, remoteConfigRestPassthrough :: Bool , remoteConfigRestPassthrough :: RemoteConfigField -> Bool
} }
mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> m RemoteConfigParser mkRemoteConfigParser :: Monad m => [RemoteConfigFieldParser] -> m RemoteConfigParser
mkRemoteConfigParser l = pure (RemoteConfigParser l False) mkRemoteConfigParser l = pure (RemoteConfigParser l (const False))
addRemoteConfigParser :: [RemoteConfigFieldParser] -> RemoteConfigParser -> RemoteConfigParser addRemoteConfigParser :: [RemoteConfigFieldParser] -> RemoteConfigParser -> RemoteConfigParser
addRemoteConfigParser l rpc = rpc { remoteConfigFieldParsers = remoteConfigFieldParsers rpc ++ l } addRemoteConfigParser l rpc = rpc { remoteConfigFieldParsers = remoteConfigFieldParsers rpc ++ l }