fix encryption of content to gcrypt and git-lfs
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. Problem was, Remote.Git enumerates all git remotes, including git-lfs and gcrypt. It then dispatches to those. So, Remote.List used the RemoteConfigParser from Remote.Git, instead of from git-lfs or gcrypt, and that parser does not know about encryption fields, so did not include them in the ParsedRemoteConfig. (Also didn't include other fields specific to those remotes, perhaps chunking etc also didn't get through.) To fix, had to move RemoteConfig parsing down into the generate methods of each remote, rather than doing it in Remote.List. And a consequence of that was that ParsedRemoteConfig had to change to include the RemoteConfig that got parsed, so that testremote can generate a new remote based on an existing remote. (I would have rather fixed this just inside Remote.Git, but that was not practical, at least not w/o re-doing work that Remote.List already did. Big ugly mostly mechanical patch seemed preferable to making git-annex slower.)
This commit is contained in:
Joey Hess
parent
cd8a208b8c
commit
8af6d2c3c5
31 changed files with 202 additions and 151 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 $
|
||||
|
|
|
|||
12
CHANGELOG
12
CHANGELOG
|
|
@ -1,3 +1,15 @@
|
|||
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.)
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Wed, 26 Feb 2020 17:18:16 -0400
|
||||
|
||||
git-annex (7.20200219) upstream; urgency=medium
|
||||
|
||||
* Added sync --only-annex, which syncs the git-annex branch and annexed
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
15
NEWS
15
NEWS
|
|
@ -1,3 +1,18 @@
|
|||
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
|
||||
|
||||
When annex.largefiles is not configured, `git add` and `git commit -a`
|
||||
|
|
|
|||
|
|
@ -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 (remoteConfig 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
|
||||
|
|
|
|||
|
|
@ -284,7 +284,7 @@ isEncrypted = isJust . extractCipher
|
|||
|
||||
describeEncryption :: ParsedRemoteConfig -> String
|
||||
describeEncryption c = case extractCipher c of
|
||||
Nothing -> "none" ++ show (getRemoteConfigValue cipherField c :: Maybe String) ++ show (M.keys c)
|
||||
Nothing -> "none"
|
||||
Just cip -> nameCipher cip ++ " (" ++ describeCipher cip ++ ")"
|
||||
|
||||
nameCipher :: StorableCipher -> String
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1251,9 +1252,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…
Reference in a new issue