Merge branch 'v7'

This commit is contained in:
Joey Hess 2020-02-26 18:15:18 -04:00
commit 81e3faf810
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
30 changed files with 207 additions and 158 deletions

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -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 $

View file

@ -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

View file

@ -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)

View file

@ -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
View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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.

View file

@ -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)]

View file

@ -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

View file

@ -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

View file

@ -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]

View file

@ -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."

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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. -}