Merge branch 'v7'
This commit is contained in:
commit
81e3faf810
30 changed files with 207 additions and 158 deletions
|
@ -11,7 +11,8 @@
|
|||
module Annex.SpecialRemote.Config where
|
||||
|
||||
import Common
|
||||
import Types.Remote (RemoteConfigField, RemoteConfig)
|
||||
import Types.Remote (RemoteConfigField, RemoteConfig, configParser)
|
||||
import Types
|
||||
import Types.UUID
|
||||
import Types.ProposedAccepted
|
||||
import Types.RemoteConfig
|
||||
|
@ -106,6 +107,10 @@ commonFieldParsers =
|
|||
(FieldDesc "type of special remote")
|
||||
, trueFalseParser autoEnableField False
|
||||
(FieldDesc "automatically enable special remote")
|
||||
, yesNoParser exportTreeField False
|
||||
(FieldDesc "export trees of files to this remote")
|
||||
, yesNoParser importTreeField False
|
||||
(FieldDesc "import trees of files from this remote")
|
||||
, optionalStringParser preferreddirField
|
||||
(FieldDesc "directory whose content is preferred")
|
||||
]
|
||||
|
@ -162,7 +167,7 @@ findByRemoteConfig matching = map sameasuuid . filter (matching . snd) . M.toLis
|
|||
|
||||
{- Extracts a value from ParsedRemoteConfig. -}
|
||||
getRemoteConfigValue :: HasCallStack => Typeable v => RemoteConfigField -> ParsedRemoteConfig -> Maybe v
|
||||
getRemoteConfigValue f m = case M.lookup f m of
|
||||
getRemoteConfigValue f (ParsedRemoteConfig m _) = case M.lookup f m of
|
||||
Just (RemoteConfigValue v) -> case cast v of
|
||||
Just v' -> Just v'
|
||||
Nothing -> error $ unwords
|
||||
|
@ -176,13 +181,20 @@ getRemoteConfigValue f m = case M.lookup f m of
|
|||
|
||||
{- Gets all fields that remoteConfigRestPassthrough matched. -}
|
||||
getRemoteConfigPassedThrough :: ParsedRemoteConfig -> M.Map RemoteConfigField String
|
||||
getRemoteConfigPassedThrough = M.mapMaybe $ \(RemoteConfigValue v) ->
|
||||
case cast v of
|
||||
Just (PassedThrough s) -> Just s
|
||||
Nothing -> Nothing
|
||||
getRemoteConfigPassedThrough (ParsedRemoteConfig m _) =
|
||||
flip M.mapMaybe m $ \(RemoteConfigValue v) ->
|
||||
case cast v of
|
||||
Just (PassedThrough s) -> Just s
|
||||
Nothing -> Nothing
|
||||
|
||||
newtype PassedThrough = PassedThrough String
|
||||
|
||||
parsedRemoteConfig :: RemoteType -> RemoteConfig -> Annex ParsedRemoteConfig
|
||||
parsedRemoteConfig t c = either (const emptycfg) id . parseRemoteConfig c
|
||||
<$> configParser t c
|
||||
where
|
||||
emptycfg = ParsedRemoteConfig mempty c
|
||||
|
||||
parseRemoteConfig :: RemoteConfig -> RemoteConfigParser -> Either String ParsedRemoteConfig
|
||||
parseRemoteConfig c rpc =
|
||||
go [] c (remoteConfigFieldParsers rpc ++ commonFieldParsers)
|
||||
|
@ -195,8 +207,10 @@ parseRemoteConfig c rpc =
|
|||
in if not (null leftovers')
|
||||
then Left $ "Unexpected parameters: " ++
|
||||
unwords (map (fromProposedAccepted . fst) leftovers')
|
||||
else Right $ M.fromList $
|
||||
l ++ map (uncurry passthrough) passover
|
||||
else
|
||||
let m = M.fromList $
|
||||
l ++ map (uncurry passthrough) passover
|
||||
in Right (ParsedRemoteConfig m c)
|
||||
go l c' (p:rest) = do
|
||||
let f = parserForField p
|
||||
(valueParser p) (M.lookup f c) c >>= \case
|
||||
|
|
|
@ -170,8 +170,7 @@ getEnableS3R uuid = do
|
|||
m <- liftAnnex readRemoteLog
|
||||
isia <- case M.lookup uuid m of
|
||||
Just c -> liftAnnex $ do
|
||||
pc <- either mempty id . parseRemoteConfig c
|
||||
<$> Remote.configParser S3.remote c
|
||||
pc <- parsedRemoteConfig S3.remote c
|
||||
return $ S3.configIA pc
|
||||
Nothing -> return False
|
||||
if isia
|
||||
|
|
|
@ -256,8 +256,7 @@ getRepoInfo :: Maybe Remote.Remote -> Remote.RemoteConfig -> Widget
|
|||
getRepoInfo (Just r) c = case fromProposedAccepted <$> M.lookup typeField c of
|
||||
Just "S3" -> do
|
||||
#ifdef WITH_S3
|
||||
pc <- liftAnnex $ either mempty id . parseRemoteConfig c
|
||||
<$> Remote.configParser S3.remote c
|
||||
pc <- liftAnnex $ parsedRemoteConfig S3.remote c
|
||||
if S3.configIA pc
|
||||
then IA.getRepoInfo c
|
||||
else AWS.getRepoInfo c
|
||||
|
@ -283,7 +282,8 @@ getRepoEncryption (Just _) (Just c) = case extractCipher pc of
|
|||
(Just (EncryptedCipher _ _ ks)) -> desckeys ks
|
||||
(Just (SharedPubKeyCipher _ ks)) -> desckeys ks
|
||||
where
|
||||
pc = either mempty id $ parseEncryptionConfig c
|
||||
pc = either (const (Remote.ParsedRemoteConfig mempty mempty)) id $
|
||||
parseEncryptionConfig c
|
||||
desckeys (KeyIds { keyIds = ks }) = do
|
||||
cmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
|
||||
knownkeys <- liftIO (secretKeys cmd)
|
||||
|
|
|
@ -15,7 +15,7 @@ import Creds
|
|||
import qualified Remote.WebDAV as WebDAV
|
||||
import Assistant.WebApp.MakeRemote
|
||||
import qualified Remote
|
||||
import Types.Remote (RemoteConfig, configParser)
|
||||
import Types.Remote (RemoteConfig)
|
||||
import Types.StandardGroups
|
||||
import Logs.Remote
|
||||
import Git.Types (RemoteName)
|
||||
|
@ -62,8 +62,7 @@ postEnableWebDAVR uuid = do
|
|||
let url = fromProposedAccepted $ fromJust $ M.lookup (Accepted "url") c
|
||||
mcreds <- liftAnnex $ do
|
||||
dummycfg <- liftIO dummyRemoteGitConfig
|
||||
pc <- either mempty id . parseRemoteConfig c
|
||||
<$> configParser WebDAV.remote c
|
||||
pc <- parsedRemoteConfig WebDAV.remote c
|
||||
getRemoteCredPairFor "webdav" pc dummycfg (WebDAV.davCreds uuid)
|
||||
case mcreds of
|
||||
Just creds -> webDAVConfigurator $ liftH $
|
||||
|
|
22
CHANGELOG
22
CHANGELOG
|
@ -1,4 +1,4 @@
|
|||
git-annex (8.20200221) UNRELEASED; urgency=medium
|
||||
git-annex (8.20200226) UNRELEASED; urgency=medium
|
||||
|
||||
* New v8 repository version.
|
||||
* v7 upgrades automatically to v8. The upgrade deletes old sqlite
|
||||
|
@ -19,8 +19,6 @@ git-annex (8.20200221) UNRELEASED; urgency=medium
|
|||
that no longer adds them to the annex, but to git. This behavior
|
||||
can be configured with annex.dotfiles.
|
||||
* add: Removed the --include-dotfiles option.
|
||||
* Bugfix: export --tracking (a deprecated option) set
|
||||
annex-annex-tracking-branch, instead of annex-tracking-branch.
|
||||
* initremote, enableremote: Set remote.name.skipFetchAll when
|
||||
the remote cannot be fetched from by git, so git fetch --all
|
||||
will not try to use it.
|
||||
|
@ -34,12 +32,24 @@ git-annex (8.20200221) UNRELEASED; urgency=medium
|
|||
* Auto upgrades from older repo versions, like v5, now jump right to v8.
|
||||
* Extended annex.security.allowed-ip-addresses to let specific ports
|
||||
of an IP address to be used, while denying use of other ports.
|
||||
* Bugfix to getting content from an export remote with -J, when the
|
||||
export database was not yet populated.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Wed, 26 Feb 2020 17:18:16 -0400
|
||||
|
||||
git-annex (7.20200226) upstream; urgency=high
|
||||
|
||||
* Fix serious regression in gcrypt and encrypted git-lfs remotes.
|
||||
Since version 7.20200202.7, git-annex incorrectly stored content
|
||||
on those remotes without encrypting it.
|
||||
If your remotes are affected, you will want to make sure to delete
|
||||
any content that git-annex has stored on them that is not encrypted!
|
||||
* info: Fix display of the encryption value.
|
||||
(Some debugging junk had crept in.)
|
||||
* Bugfix to getting content from an export remote with -J, when the
|
||||
export database was not yet populated.
|
||||
* Bugfix: export --tracking (a deprecated option) set
|
||||
annex-annex-tracking-branch, instead of annex-tracking-branch.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Wed, 19 Feb 2020 12:48:58 -0400
|
||||
-- Joey Hess <id@joeyh.name> Wed, 26 Feb 2020 17:18:16 -0400
|
||||
|
||||
git-annex (7.20200219) upstream; urgency=medium
|
||||
|
||||
|
|
|
@ -24,8 +24,8 @@ import Utility.DataUnits
|
|||
import Utility.CopyFile
|
||||
import Types.Messages
|
||||
import Types.Export
|
||||
import Types.Crypto
|
||||
import Types.RemoteConfig
|
||||
import Types.ProposedAccepted
|
||||
import Annex.SpecialRemote.Config (exportTreeField)
|
||||
import Remote.Helper.ExportImport
|
||||
import Remote.Helper.Chunked
|
||||
|
@ -122,18 +122,18 @@ perform rs unavailrs exportr ks = do
|
|||
]
|
||||
|
||||
adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote)
|
||||
adjustChunkSize r chunksize = adjustRemoteConfig r
|
||||
(M.insert chunkField (RemoteConfigValue (show chunksize)))
|
||||
adjustChunkSize r chunksize = adjustRemoteConfig r $
|
||||
M.insert chunkField (Proposed (show chunksize))
|
||||
|
||||
-- Variants of a remote with no encryption, and with simple shared
|
||||
-- encryption. Gpg key based encryption is not tested.
|
||||
encryptionVariants :: Remote -> Annex [Remote]
|
||||
encryptionVariants r = do
|
||||
noenc <- adjustRemoteConfig r $
|
||||
M.insert encryptionField (RemoteConfigValue NoneEncryption)
|
||||
M.insert encryptionField (Proposed "none")
|
||||
sharedenc <- adjustRemoteConfig r $
|
||||
M.insert encryptionField (RemoteConfigValue SharedEncryption) .
|
||||
M.insert highRandomQualityField (RemoteConfigValue False)
|
||||
M.insert encryptionField (Proposed "shared") .
|
||||
M.insert highRandomQualityField (Proposed "false")
|
||||
return $ catMaybes [noenc, sharedenc]
|
||||
|
||||
-- Variant of a remote with exporttree disabled.
|
||||
|
@ -145,19 +145,20 @@ disableExportTree r = maybe (error "failed disabling exportree") return
|
|||
exportTreeVariant :: Remote -> Annex (Maybe Remote)
|
||||
exportTreeVariant r = ifM (Remote.isExportSupported r)
|
||||
( adjustRemoteConfig r $
|
||||
M.insert encryptionField (RemoteConfigValue NoneEncryption) .
|
||||
M.insert exportTreeField (RemoteConfigValue True)
|
||||
M.insert encryptionField (Proposed "none") .
|
||||
M.insert exportTreeField (Proposed "yes")
|
||||
, return Nothing
|
||||
)
|
||||
|
||||
-- Regenerate a remote with a modified config.
|
||||
adjustRemoteConfig :: Remote -> (Remote.ParsedRemoteConfig -> Remote.ParsedRemoteConfig) -> Annex (Maybe Remote)
|
||||
adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote)
|
||||
adjustRemoteConfig r adjustconfig = do
|
||||
repo <- Remote.getRepo r
|
||||
let ParsedRemoteConfig _ origc = Remote.config r
|
||||
Remote.generate (Remote.remotetype r)
|
||||
repo
|
||||
(Remote.uuid r)
|
||||
(adjustconfig (Remote.config r))
|
||||
(adjustconfig origc)
|
||||
(Remote.gitconfig r)
|
||||
(Remote.remoteStateHandle r)
|
||||
|
||||
|
|
11
Creds.hs
11
Creds.hs
|
@ -57,8 +57,9 @@ data CredPairStorage = CredPairStorage
|
|||
- cipher. The EncryptionIsSetup is witness to that being the case.
|
||||
-}
|
||||
setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
|
||||
setRemoteCredPair = setRemoteCredPair' id
|
||||
(either (const mempty) id . parseEncryptionConfig)
|
||||
setRemoteCredPair = setRemoteCredPair' id go
|
||||
where
|
||||
go c = either (const (ParsedRemoteConfig mempty c)) id (parseEncryptionConfig c)
|
||||
|
||||
setRemoteCredPair'
|
||||
:: (ProposedAccepted String -> a)
|
||||
|
@ -203,18 +204,18 @@ removeCreds file = do
|
|||
liftIO $ nukeFile f
|
||||
|
||||
includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)]
|
||||
includeCredsInfo c storage info = do
|
||||
includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do
|
||||
v <- liftIO $ getEnvCredPair storage
|
||||
case v of
|
||||
Just _ -> do
|
||||
let (uenv, penv) = credPairEnvironment storage
|
||||
ret $ "from environment variables (" ++ unwords [uenv, penv] ++ ")"
|
||||
Nothing -> case (`M.lookup` c) (credPairRemoteField storage) of
|
||||
Nothing -> case (`M.lookup` cm) (credPairRemoteField storage) of
|
||||
Nothing -> ifM (existsCacheCredPair storage)
|
||||
( ret "stored locally"
|
||||
, ret "not available"
|
||||
)
|
||||
Just _ -> case extractCipher c of
|
||||
Just _ -> case extractCipher pc of
|
||||
Just (EncryptedCipher {}) -> ret "embedded in git repository (gpg encrypted)"
|
||||
_ -> ret "embedded in git repository (not encrypted)"
|
||||
where
|
||||
|
|
19
NEWS
19
NEWS
|
@ -1,4 +1,4 @@
|
|||
git-annex (8.20191107) upstream; urgency=medium
|
||||
git-annex (8.20200226) upstream; urgency=medium
|
||||
|
||||
This version of git-annex uses repository version 8 for all repositories.
|
||||
|
||||
|
@ -20,7 +20,22 @@ git-annex (8.20191107) upstream; urgency=medium
|
|||
and added dotfiles that were explicitly listed to the annex, it now adds
|
||||
dotfiles to git by default, unless annex.dotfiles is set to true.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Thu, 07 Nov 2019 13:21:11 -0400
|
||||
-- Joey Hess <id@joeyh.name> Wed, 26 Feb 2020 17:18:16 -0400
|
||||
|
||||
git-annex (7.20200226) upstream; urgency=high
|
||||
|
||||
There was a serious regression in gcrypt and encrypted git-lfs remotes.
|
||||
Since version 7.20200202.7, git-annex incorrectly stored content
|
||||
on those remotes without encrypting it.
|
||||
|
||||
If your remotes are affected, you will want to make sure to delete
|
||||
any content that git-annex has stored on them that is not encrypted!
|
||||
|
||||
One way to do so is, before upgrading to this version,
|
||||
run git-annex move --from the affected remotes. It will move
|
||||
only the content that was not encrypted.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Wed, 26 Feb 2020 17:18:16 -0400
|
||||
|
||||
git-annex (7.20191024) upstream; urgency=medium
|
||||
|
||||
|
|
|
@ -54,8 +54,9 @@ 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 :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
let this = Remote
|
||||
{ uuid = u
|
||||
-- adb operates over USB or wifi, so is not as cheap
|
||||
|
|
|
@ -28,6 +28,7 @@ import Annex.Tmp
|
|||
import Annex.UUID
|
||||
import qualified Annex.Url as Url
|
||||
import Remote.Helper.ExportImport
|
||||
import Annex.SpecialRemote.Config
|
||||
|
||||
import Network.URI
|
||||
|
||||
|
@ -53,9 +54,10 @@ list _autoinit = do
|
|||
r <- liftIO $ Git.Construct.remoteNamed "bittorrent" (pure Git.Construct.fromUnknown)
|
||||
return [r]
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r _ c gc rs = do
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r _ rc gc rs = do
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
c <- parsedRemoteConfig remote rc
|
||||
return $ Just Remote
|
||||
{ uuid = bitTorrentUUID
|
||||
, cost = cst
|
||||
|
|
|
@ -55,8 +55,9 @@ remote = specialRemoteType $ RemoteType
|
|||
buprepoField :: RemoteConfigField
|
||||
buprepoField = Accepted "buprepo"
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u c gc rs = do
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
bupr <- liftIO $ bup2GitRemote buprepo
|
||||
cst <- remoteCost gc $
|
||||
if bupLocal buprepo
|
||||
|
@ -99,6 +100,10 @@ gen r u c gc rs = do
|
|||
, checkUrl = Nothing
|
||||
, remoteStateHandle = rs
|
||||
}
|
||||
let specialcfg = (specialRemoteCfg c)
|
||||
-- chunking would not improve bup
|
||||
{ chunkConfig = NoChunks
|
||||
}
|
||||
return $ Just $ specialRemote' specialcfg c
|
||||
(simplyPrepare $ store this buprepo)
|
||||
(simplyPrepare $ retrieve buprepo)
|
||||
|
@ -107,10 +112,6 @@ gen r u c gc rs = do
|
|||
this
|
||||
where
|
||||
buprepo = fromMaybe (giveup "missing buprepo") $ remoteAnnexBupRepo gc
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
-- chunking would not improve bup
|
||||
{ chunkConfig = NoChunks
|
||||
}
|
||||
|
||||
bupSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
bupSetup _ mu _ c gc = do
|
||||
|
|
|
@ -48,20 +48,25 @@ remote = specialRemoteType $ RemoteType
|
|||
ddarrepoField :: RemoteConfigField
|
||||
ddarrepoField = Accepted "ddarrepo"
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u c gc rs = do
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
cst <- remoteCost gc $
|
||||
if ddarLocal ddarrepo
|
||||
then nearlyCheapRemoteCost
|
||||
else expensiveRemoteCost
|
||||
let specialcfg = (specialRemoteCfg c)
|
||||
-- chunking would not improve ddar
|
||||
{ chunkConfig = NoChunks
|
||||
}
|
||||
return $ Just $ specialRemote' specialcfg c
|
||||
(simplyPrepare $ store ddarrepo)
|
||||
(simplyPrepare $ retrieve ddarrepo)
|
||||
(simplyPrepare $ remove ddarrepo)
|
||||
(simplyPrepare $ checkKey ddarrepo)
|
||||
(this cst)
|
||||
(this c cst)
|
||||
where
|
||||
this cst = Remote
|
||||
this c cst = Remote
|
||||
{ uuid = u
|
||||
, cost = cst
|
||||
, name = Git.repoDescribe r
|
||||
|
@ -97,10 +102,6 @@ gen r u c gc rs = do
|
|||
, remoteStateHandle = rs
|
||||
}
|
||||
ddarrepo = maybe (giveup "missing ddarrepo") (DdarRepo gc) (remoteAnnexDdarRepo gc)
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
-- chunking would not improve ddar
|
||||
{ chunkConfig = NoChunks
|
||||
}
|
||||
|
||||
ddarSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
ddarSetup _ mu _ c gc = do
|
||||
|
|
|
@ -54,8 +54,9 @@ remote = specialRemoteType $ RemoteType
|
|||
directoryField :: RemoteConfigField
|
||||
directoryField = Accepted "directory"
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u c gc rs = do
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
cst <- remoteCost gc cheapRemoteCost
|
||||
let chunkconfig = getChunkConfig c
|
||||
return $ Just $ specialRemote c
|
||||
|
@ -106,7 +107,7 @@ gen r u c gc rs = do
|
|||
, appendonly = False
|
||||
, availability = LocallyAvailable
|
||||
, remotetype = remote
|
||||
, mkUnavailable = gen r u c
|
||||
, mkUnavailable = gen r u rc
|
||||
(gc { remoteAnnexDirectory = Just "/dev/null" }) rs
|
||||
, getInfo = return [("directory", dir)]
|
||||
, claimUrl = Nothing
|
||||
|
|
|
@ -62,12 +62,13 @@ externaltypeField = Accepted "externaltype"
|
|||
readonlyField :: RemoteConfigField
|
||||
readonlyField = Accepted "readonly"
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u c gc rs
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs
|
||||
-- readonly mode only downloads urls; does not use external program
|
||||
| remoteAnnexReadOnly gc = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
mk cst GloballyAvailable
|
||||
mk c cst GloballyAvailable
|
||||
readonlyStorer
|
||||
retrieveUrl
|
||||
readonlyRemoveKey
|
||||
|
@ -79,6 +80,7 @@ gen r u c gc rs
|
|||
exportUnsupported
|
||||
exportUnsupported
|
||||
| otherwise = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
external <- newExternal externaltype (Just u) c (Just gc) (Just rs)
|
||||
Annex.addCleanup (RemoteCleanup u) $ stopExternal external
|
||||
cst <- getCost external r gc
|
||||
|
@ -101,7 +103,7 @@ gen r u c gc rs
|
|||
let cheapexportsupported = if exportsupported
|
||||
then exportIsSupported
|
||||
else exportUnsupported
|
||||
mk cst avail
|
||||
mk c cst avail
|
||||
(storeKeyM external)
|
||||
(retrieveKeyFileM external)
|
||||
(removeKeyM external)
|
||||
|
@ -113,7 +115,7 @@ gen r u c gc rs
|
|||
exportactions
|
||||
cheapexportsupported
|
||||
where
|
||||
mk cst avail tostore toretrieve toremove tocheckkey towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = do
|
||||
mk c cst avail tostore toretrieve toremove tocheckkey towhereis togetinfo toclaimurl tocheckurl exportactions cheapexportsupported = do
|
||||
let rmt = Remote
|
||||
{ uuid = u
|
||||
, cost = cst
|
||||
|
@ -144,7 +146,7 @@ gen r u c gc rs
|
|||
, availability = avail
|
||||
, remotetype = remote
|
||||
{ exportSupported = cheapexportsupported }
|
||||
, mkUnavailable = gen r u c
|
||||
, mkUnavailable = gen r u rc
|
||||
(gc { remoteAnnexExternalType = Just "!dne!" }) rs
|
||||
, getInfo = togetinfo
|
||||
, claimUrl = toclaimurl
|
||||
|
@ -409,25 +411,28 @@ handleRequest' st external req mp responsehandler
|
|||
send $ VALUE $ fromRawFilePath $ hashDirLower def k
|
||||
handleRemoteRequest (SETCONFIG setting value) =
|
||||
liftIO $ atomically $ do
|
||||
modifyTVar' (externalConfig st) $
|
||||
M.insert (Accepted setting) $
|
||||
RemoteConfigValue (PassedThrough value)
|
||||
modifyTVar' (externalConfig st) $ \(ParsedRemoteConfig m c) ->
|
||||
let m' = M.insert
|
||||
(Accepted setting)
|
||||
(RemoteConfigValue (PassedThrough value))
|
||||
m
|
||||
in ParsedRemoteConfig m' c
|
||||
modifyTVar' (externalConfigChanges st) $ \f ->
|
||||
f . M.insert (Accepted setting) (Accepted value)
|
||||
handleRemoteRequest (GETCONFIG setting) = do
|
||||
value <- fromMaybe ""
|
||||
. M.lookup (Accepted setting)
|
||||
. (M.lookup (Accepted setting))
|
||||
. getRemoteConfigPassedThrough
|
||||
<$> liftIO (atomically $ readTVar $ externalConfig st)
|
||||
send $ VALUE value
|
||||
handleRemoteRequest (SETCREDS setting login password) = case (externalUUID external, externalGitConfig external) of
|
||||
(Just u, Just gc) -> do
|
||||
let v = externalConfig st
|
||||
c <- liftIO $ atomically $ readTVar v
|
||||
c' <- setRemoteCredPair' RemoteConfigValue id encryptionAlreadySetup c gc
|
||||
(ParsedRemoteConfig m c) <- liftIO $ atomically $ readTVar v
|
||||
m' <- setRemoteCredPair' RemoteConfigValue (\m' -> ParsedRemoteConfig m' c) encryptionAlreadySetup m gc
|
||||
(credstorage setting u)
|
||||
(Just (login, password))
|
||||
void $ liftIO $ atomically $ swapTVar v c'
|
||||
void $ liftIO $ atomically $ swapTVar v (ParsedRemoteConfig m' c)
|
||||
_ -> senderror "cannot send SETCREDS here"
|
||||
handleRemoteRequest (GETCREDS setting) = case (externalUUID external, externalGitConfig external) of
|
||||
(Just u, Just gc) -> do
|
||||
|
|
|
@ -80,16 +80,16 @@ remote = specialRemoteType $ RemoteType
|
|||
gitRepoField :: RemoteConfigField
|
||||
gitRepoField = Accepted "gitrepo"
|
||||
|
||||
chainGen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
chainGen gcryptr u c gc rs = do
|
||||
chainGen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
chainGen gcryptr u rc gc rs = do
|
||||
g <- gitRepo
|
||||
-- get underlying git repo with real path, not gcrypt path
|
||||
r <- liftIO $ Git.GCrypt.encryptedRemote g gcryptr
|
||||
let r' = r { Git.remoteName = Git.remoteName gcryptr }
|
||||
gen r' u c gc rs
|
||||
gen r' u rc gc rs
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen baser u c gc rs = do
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen baser u rc gc rs = do
|
||||
-- doublecheck that cache matches underlying repo's gcrypt-id
|
||||
-- (which might not be set), only for local repos
|
||||
(mgcryptid, r) <- getGCryptId True baser gc
|
||||
|
@ -97,7 +97,9 @@ gen baser u c gc rs = do
|
|||
case (mgcryptid, Git.GCrypt.remoteRepoId g (Git.remoteName baser)) of
|
||||
(Just gcryptid, Just cachedgcryptid)
|
||||
| gcryptid /= cachedgcryptid -> resetup gcryptid r
|
||||
_ -> gen' r u c gc rs
|
||||
_ -> do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
gen' r u c gc rs
|
||||
where
|
||||
-- A different drive may have been mounted, making a different
|
||||
-- gcrypt remote available. So need to set the cached
|
||||
|
@ -108,10 +110,8 @@ gen baser u c gc rs = do
|
|||
let u' = genUUIDInNameSpace gCryptNameSpace gcryptid
|
||||
v <- M.lookup u' <$> readRemoteLog
|
||||
case (Git.remoteName baser, v) of
|
||||
(Just remotename, Just c') -> do
|
||||
pc <- either giveup return
|
||||
. parseRemoteConfig c'
|
||||
=<< configParser remote c'
|
||||
(Just remotename, Just rc') -> do
|
||||
pc <- parsedRemoteConfig remote rc'
|
||||
setGcryptEncryption pc remotename
|
||||
storeUUIDIn (remoteAnnexConfig baser "uuid") u'
|
||||
setConfig (Git.GCrypt.remoteConfigKey "gcrypt-id" remotename) gcryptid
|
||||
|
|
|
@ -161,20 +161,21 @@ configRead autoinit r = do
|
|||
Just r' -> return r'
|
||||
_ -> return r
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u c gc rs
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs
|
||||
-- Remote.GitLFS may be used with a repo that is also encrypted
|
||||
-- with gcrypt so is checked first.
|
||||
| remoteAnnexGitLFS gc = Remote.GitLFS.gen r u c gc rs
|
||||
| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u c gc rs
|
||||
| remoteAnnexGitLFS gc = Remote.GitLFS.gen r u rc gc rs
|
||||
| Git.GCrypt.isEncrypted r = Remote.GCrypt.chainGen r u rc gc rs
|
||||
| otherwise = case repoP2PAddress r of
|
||||
Nothing -> do
|
||||
st <- mkState r u gc
|
||||
go st <$> remoteCost gc defcst
|
||||
Just addr -> Remote.P2P.chainGen addr r u c gc rs
|
||||
c <- parsedRemoteConfig remote rc
|
||||
go st c <$> remoteCost gc defcst
|
||||
Just addr -> Remote.P2P.chainGen addr r u rc gc rs
|
||||
where
|
||||
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
|
||||
go st cst = Just new
|
||||
go st c cst = Just new
|
||||
where
|
||||
new = Remote
|
||||
{ uuid = u
|
||||
|
@ -205,14 +206,14 @@ gen r u c gc rs
|
|||
, appendonly = False
|
||||
, availability = availabilityCalc r
|
||||
, remotetype = remote
|
||||
, mkUnavailable = unavailable r u c gc rs
|
||||
, mkUnavailable = unavailable r u rc gc rs
|
||||
, getInfo = gitRepoInfo new
|
||||
, claimUrl = Nothing
|
||||
, checkUrl = Nothing
|
||||
, remoteStateHandle = rs
|
||||
}
|
||||
|
||||
unavailable :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
unavailable r = gen r'
|
||||
where
|
||||
r' = case Git.location r of
|
||||
|
|
|
@ -73,8 +73,9 @@ remote = specialRemoteType $ RemoteType
|
|||
urlField :: RemoteConfigField
|
||||
urlField = Accepted "url"
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u c gc rs = do
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
-- If the repo uses gcrypt, get the underlaying repo without the
|
||||
-- gcrypt url, to do LFS endpoint discovery on.
|
||||
r' <- if Git.GCrypt.isEncrypted r
|
||||
|
@ -85,14 +86,18 @@ gen r u c gc rs = do
|
|||
sem <- liftIO $ MSemN.new 1
|
||||
h <- liftIO $ newTVarIO $ LFSHandle Nothing Nothing sem r' gc
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
let specialcfg = (specialRemoteCfg c)
|
||||
-- chunking would not improve git-lfs
|
||||
{ chunkConfig = NoChunks
|
||||
}
|
||||
return $ Just $ specialRemote' specialcfg c
|
||||
(simplyPrepare $ store rs h)
|
||||
(simplyPrepare $ retrieve rs h)
|
||||
(simplyPrepare $ remove h)
|
||||
(simplyPrepare $ checkKey rs h)
|
||||
(this cst)
|
||||
(this c cst)
|
||||
where
|
||||
this cst = Remote
|
||||
this c cst = Remote
|
||||
{ uuid = u
|
||||
, cost = cst
|
||||
, name = Git.repoDescribe r
|
||||
|
@ -122,15 +127,11 @@ gen r u c gc rs = do
|
|||
-- content cannot be removed from a git-lfs repo
|
||||
, appendonly = True
|
||||
, mkUnavailable = return Nothing
|
||||
, getInfo = gitRepoInfo (this cst)
|
||||
, getInfo = gitRepoInfo (this c cst)
|
||||
, claimUrl = Nothing
|
||||
, checkUrl = Nothing
|
||||
, remoteStateHandle = rs
|
||||
}
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
-- chunking would not improve git-lfs
|
||||
{ chunkConfig = NoChunks
|
||||
}
|
||||
|
||||
mySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
mySetup _ mu _ c gc = do
|
||||
|
|
|
@ -59,10 +59,12 @@ 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 :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = new
|
||||
<$> parsedRemoteConfig remote rc
|
||||
<*> remoteCost gc veryExpensiveRemoteCost
|
||||
where
|
||||
new cst = Just $ specialRemote' specialcfg c
|
||||
new c cst = Just $ specialRemote' specialcfg c
|
||||
(prepareStore this)
|
||||
(prepareRetrieve this)
|
||||
(simplyPrepare $ remove this)
|
||||
|
@ -105,10 +107,10 @@ gen r u c gc rs = new <$> remoteCost gc veryExpensiveRemoteCost
|
|||
, checkUrl = Nothing
|
||||
, remoteStateHandle = rs
|
||||
}
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
-- Disabled until jobList gets support for chunks.
|
||||
{ chunkConfig = NoChunks
|
||||
}
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
-- Disabled until jobList gets support for chunks.
|
||||
{ chunkConfig = NoChunks
|
||||
}
|
||||
|
||||
glacierSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
glacierSetup ss mu mcreds c gc = do
|
||||
|
|
|
@ -72,15 +72,11 @@ importIsSupported = \_ _ -> return True
|
|||
-- | Prevent or allow exporttree=yes and importtree=yes when
|
||||
-- setting up a new remote, depending on exportSupported and importSupported.
|
||||
adjustExportImportRemoteType :: RemoteType -> RemoteType
|
||||
adjustExportImportRemoteType rt = rt
|
||||
{ setup = setup'
|
||||
, configParser = configparser
|
||||
}
|
||||
adjustExportImportRemoteType rt = rt { setup = setup' }
|
||||
where
|
||||
configparser c = addRemoteConfigParser exportImportConfigParsers
|
||||
<$> configParser rt c
|
||||
setup' st mu cp c gc = do
|
||||
pc <- either giveup return . parseRemoteConfig c =<< configparser c
|
||||
pc <- either giveup return . parseRemoteConfig c
|
||||
=<< configParser rt c
|
||||
let checkconfig supported configured configfield cont =
|
||||
ifM (supported rt pc gc)
|
||||
( case st of
|
||||
|
@ -89,7 +85,7 @@ adjustExportImportRemoteType rt = rt
|
|||
giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield
|
||||
| otherwise -> cont
|
||||
Enable oldc -> do
|
||||
oldpc <- either mempty id . parseRemoteConfig oldc <$> configparser oldc
|
||||
oldpc <- parsedRemoteConfig rt oldc
|
||||
if configured pc /= configured oldpc
|
||||
then giveup $ "cannot change " ++ fromProposedAccepted configfield ++ " of existing special remote"
|
||||
else cont
|
||||
|
@ -103,14 +99,6 @@ adjustExportImportRemoteType rt = rt
|
|||
then giveup "cannot enable importtree=yes without also enabling exporttree=yes"
|
||||
else setup rt st mu cp c gc
|
||||
|
||||
exportImportConfigParsers :: [RemoteConfigFieldParser]
|
||||
exportImportConfigParsers =
|
||||
[ yesNoParser exportTreeField False
|
||||
(FieldDesc "export trees of files to this remote")
|
||||
, yesNoParser importTreeField False
|
||||
(FieldDesc "import trees of files from this remote")
|
||||
]
|
||||
|
||||
-- | Adjust a remote to support exporttree=yes and importree=yes.
|
||||
--
|
||||
-- Note that all remotes with importree=yes also have exporttree=yes.
|
||||
|
|
|
@ -45,8 +45,9 @@ remote = specialRemoteType $ RemoteType
|
|||
hooktypeField :: RemoteConfigField
|
||||
hooktypeField = Accepted "hooktype"
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u c gc rs = do
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
return $ Just $ specialRemote c
|
||||
(simplyPrepare $ store hooktype)
|
||||
|
@ -80,7 +81,7 @@ gen r u c gc rs = do
|
|||
, appendonly = False
|
||||
, availability = GloballyAvailable
|
||||
, remotetype = remote
|
||||
, mkUnavailable = gen r u c
|
||||
, mkUnavailable = gen r u rc
|
||||
(gc { remoteAnnexHookType = Just "!dne!" })
|
||||
rs
|
||||
, getInfo = return [("hooktype", hooktype)]
|
||||
|
|
|
@ -20,7 +20,6 @@ import Annex.UUID
|
|||
import Remote.Helper.Hooks
|
||||
import Remote.Helper.ReadOnly
|
||||
import Remote.Helper.ExportImport
|
||||
import Annex.SpecialRemote.Config
|
||||
import qualified Git
|
||||
import qualified Git.Config
|
||||
|
||||
|
@ -110,8 +109,7 @@ remoteGen m t g = do
|
|||
let cu = fromMaybe u $ remoteAnnexConfigUUID gc
|
||||
let rs = RemoteStateHandle cu
|
||||
let c = fromMaybe M.empty $ M.lookup cu m
|
||||
pc <- either (const mempty) id . parseRemoteConfig c <$> configParser t c
|
||||
generate t g u pc gc rs >>= \case
|
||||
generate t g u c gc rs >>= \case
|
||||
Nothing -> return Nothing
|
||||
Just r -> Just <$> adjustExportImport (adjustReadOnly (addHooks r)) rs
|
||||
|
||||
|
|
|
@ -26,6 +26,7 @@ import Remote.Helper.Git
|
|||
import Remote.Helper.ExportImport
|
||||
import Remote.Helper.P2P
|
||||
import Utility.AuthToken
|
||||
import Annex.SpecialRemote.Config
|
||||
|
||||
import Control.Concurrent.STM
|
||||
|
||||
|
@ -42,8 +43,9 @@ remote = RemoteType
|
|||
, importSupported = importUnsupported
|
||||
}
|
||||
|
||||
chainGen :: P2PAddress -> Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
chainGen addr r u c gc rs = do
|
||||
chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
chainGen addr r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
connpool <- mkConnectionPool
|
||||
cst <- remoteCost gc veryExpensiveRemoteCost
|
||||
let protorunner = runProto u addr connpool
|
||||
|
|
|
@ -67,13 +67,17 @@ shellEscapeField = Accepted "shellescape"
|
|||
rsyncUrlField :: RemoteConfigField
|
||||
rsyncUrlField = Accepted "rsyncurl"
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u c gc rs = do
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
(transport, url) <- rsyncTransport gc $
|
||||
fromMaybe (giveup "missing rsyncurl") $ remoteAnnexRsyncUrl gc
|
||||
let o = genRsyncOpts c gc transport url
|
||||
let islocal = rsyncUrlIsPath $ rsyncUrl o
|
||||
let specialcfg = (specialRemoteCfg c)
|
||||
-- Rsync displays its own progress.
|
||||
{ displayProgress = False }
|
||||
return $ Just $ specialRemote' specialcfg c
|
||||
(simplyPrepare $ fileStorer $ store o)
|
||||
(simplyPrepare $ fileRetriever $ retrieve o)
|
||||
|
@ -119,10 +123,6 @@ gen r u c gc rs = do
|
|||
, checkUrl = Nothing
|
||||
, remoteStateHandle = rs
|
||||
}
|
||||
where
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
-- Rsync displays its own progress.
|
||||
{ displayProgress = False }
|
||||
|
||||
-- Things used by genRsyncOpts
|
||||
rsyncRemoteConfigs :: [RemoteConfigFieldParser]
|
||||
|
|
15
Remote/S3.hs
15
Remote/S3.hs
|
@ -154,15 +154,16 @@ 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 :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
info <- extractS3Info c
|
||||
hdl <- mkS3HandleVar c gc u
|
||||
magic <- liftIO initMagicMime
|
||||
return $ new cst info hdl magic
|
||||
return $ new c cst info hdl magic
|
||||
where
|
||||
new cst info hdl magic = Just $ specialRemote c
|
||||
new c cst info hdl magic = Just $ specialRemote c
|
||||
(simplyPrepare $ store hdl this info magic)
|
||||
(simplyPrepare $ retrieve hdl this rs c info)
|
||||
(simplyPrepare $ remove hdl this info)
|
||||
|
@ -211,7 +212,7 @@ gen r u c gc rs = do
|
|||
, appendonly = versioning info
|
||||
, availability = GloballyAvailable
|
||||
, remotetype = remote
|
||||
, mkUnavailable = gen r u (M.insert hostField (RemoteConfigValue ("!dne!" :: String)) c) gc rs
|
||||
, mkUnavailable = gen r u (M.insert hostField (Proposed "!dne!") rc) gc rs
|
||||
, getInfo = includeCredsInfo c (AWS.creds u) (s3Info c info)
|
||||
, claimUrl = Nothing
|
||||
, checkUrl = Nothing
|
||||
|
@ -1249,9 +1250,7 @@ enableBucketVersioning ss info _ _ _ = do
|
|||
Init -> when (versioning info) $
|
||||
enableversioning (bucket info)
|
||||
Enable oldc -> do
|
||||
oldpc <- either (const mempty) id
|
||||
. parseRemoteConfig oldc
|
||||
<$> configParser remote oldc
|
||||
oldpc <- parsedRemoteConfig remote oldc
|
||||
oldinfo <- extractS3Info oldpc
|
||||
when (versioning info /= versioning oldinfo) $
|
||||
giveup "Cannot change versioning= of existing S3 remote."
|
||||
|
|
|
@ -74,8 +74,9 @@ 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 :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
hdl <- liftIO $ TahoeHandle
|
||||
<$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc)
|
||||
|
|
|
@ -21,6 +21,7 @@ import Annex.UUID
|
|||
import Utility.Metered
|
||||
import qualified Annex.Url as Url
|
||||
import Annex.YoutubeDl
|
||||
import Annex.SpecialRemote.Config
|
||||
|
||||
remote :: RemoteType
|
||||
remote = RemoteType
|
||||
|
@ -41,8 +42,9 @@ list _autoinit = do
|
|||
r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown)
|
||||
return [r]
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r _ c gc rs = do
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r _ rc gc rs = do
|
||||
c <- parsedRemoteConfig remote rc
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
return $ Just Remote
|
||||
{ uuid = webUUID
|
||||
|
|
|
@ -63,10 +63,12 @@ urlField = Accepted "url"
|
|||
davcredsField :: RemoteConfigField
|
||||
davcredsField = Accepted "davcreds"
|
||||
|
||||
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
||||
gen r u rc gc rs = new
|
||||
<$> parsedRemoteConfig remote rc
|
||||
<*> remoteCost gc expensiveRemoteCost
|
||||
where
|
||||
new cst = Just $ specialRemote c
|
||||
new c cst = Just $ specialRemote c
|
||||
(prepareDAV this $ store chunkconfig)
|
||||
(prepareDAV this $ retrieve chunkconfig)
|
||||
(prepareDAV this $ remove)
|
||||
|
@ -108,7 +110,7 @@ gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost
|
|||
, appendonly = False
|
||||
, availability = GloballyAvailable
|
||||
, remotetype = remote
|
||||
, mkUnavailable = gen r u (M.insert urlField (RemoteConfigValue "http://!dne!/") c) gc rs
|
||||
, mkUnavailable = gen r u (M.insert urlField (Proposed "http://!dne!/") rc) gc rs
|
||||
, getInfo = includeCredsInfo c (davCreds u) $
|
||||
[("url", fromMaybe "unknown" $ getRemoteConfigValue urlField c)]
|
||||
, claimUrl = Nothing
|
||||
|
|
4
Test.hs
4
Test.hs
|
@ -1622,7 +1622,7 @@ test_crypto = do
|
|||
checkKeys cip (Just v) <&&> checkCipher encipher ks'
|
||||
_ -> return False
|
||||
where
|
||||
pc =either mempty id $
|
||||
pc = either (const (Types.Remote.ParsedRemoteConfig mempty mempty)) id $
|
||||
Remote.Helper.Encryptable.parseEncryptionConfig c
|
||||
keysMatch (Utility.Gpg.KeyIds ks') =
|
||||
maybe False (\(Utility.Gpg.KeyIds ks2) ->
|
||||
|
@ -1632,7 +1632,7 @@ test_crypto = do
|
|||
checkScheme Types.Crypto.PubKey = scheme == "pubkey"
|
||||
checkKeys cip mvariant = do
|
||||
dummycfg <- Types.GitConfig.dummyRemoteGitConfig
|
||||
let encparams = (mempty :: Types.Remote.ParsedRemoteConfig, dummycfg)
|
||||
let encparams = (Types.Remote.ParsedRemoteConfig mempty mempty, dummycfg)
|
||||
cipher <- Crypto.decryptCipher gpgcmd encparams cip
|
||||
files <- filterM doesFileExist $
|
||||
map ("dir" </>) $ concatMap (serializeKeys cipher) keys
|
||||
|
|
|
@ -58,7 +58,7 @@ data RemoteTypeA a = RemoteType
|
|||
-- The Bool is True if automatic initialization of remotes is desired
|
||||
, enumerate :: Bool -> a [Git.Repo]
|
||||
-- generates a remote of this type
|
||||
, generate :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
|
||||
, generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> a (Maybe (RemoteA a))
|
||||
-- parse configs of remotes of this type
|
||||
, configParser :: RemoteConfig -> a RemoteConfigParser
|
||||
-- initializes or enables a remote
|
||||
|
|
|
@ -22,7 +22,9 @@ type RemoteConfigField = ProposedAccepted String
|
|||
type RemoteConfig = M.Map RemoteConfigField (ProposedAccepted String)
|
||||
|
||||
{- Before being used a RemoteConfig has to be parsed. -}
|
||||
type ParsedRemoteConfig = M.Map RemoteConfigField RemoteConfigValue
|
||||
data ParsedRemoteConfig = ParsedRemoteConfig
|
||||
(M.Map RemoteConfigField RemoteConfigValue)
|
||||
RemoteConfig
|
||||
|
||||
{- Remotes can have configuration values of many types, so use Typeable
|
||||
- to let them all be stored in here. -}
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue