handle importtree=yes config
For now, it's only allowed when exporttree=yes is also set. That simplified the implementation, but could later be changed if there's a remote that makes sense to be an import but not an export. However, it may work just as well to make a remote be readonly to prevent export to it while still allowing import.
This commit is contained in:
parent
5f17a9cc50
commit
aaacf431d8
7 changed files with 72 additions and 29 deletions
|
@ -8,6 +8,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Annex.Import (
|
||||
importTree,
|
||||
ImportTreeConfig(..),
|
||||
ImportCommitConfig(..),
|
||||
buildImportCommit,
|
||||
|
@ -30,6 +31,7 @@ import Annex.LockFile
|
|||
import Annex.Content
|
||||
import Annex.Export
|
||||
import Backend
|
||||
import Config
|
||||
import Types.Key
|
||||
import Types.KeySource
|
||||
import Utility.Metered
|
||||
|
@ -43,6 +45,9 @@ import qualified Database.ContentIdentifier as CID
|
|||
import Control.Concurrent.STM
|
||||
import qualified Data.Map.Strict as M
|
||||
|
||||
importTree :: Remote.RemoteConfig -> Bool
|
||||
importTree c = fromMaybe False $ yesNo =<< M.lookup "importtree" c
|
||||
|
||||
{- Configures how to build an import tree. -}
|
||||
data ImportTreeConfig
|
||||
= ImportTree
|
||||
|
|
|
@ -245,6 +245,8 @@ verifyExisting key destfile (yes, no) = do
|
|||
|
||||
seekRemote :: Remote -> Branch -> Maybe TopFilePath -> CommandSeek
|
||||
seekRemote remote branch msubdir = allowConcurrentOutput $ do
|
||||
unlessM (Remote.isImportSupported remote) $
|
||||
giveup "That remote does not support imports."
|
||||
importtreeconfig <- case msubdir of
|
||||
Nothing -> return ImportTree
|
||||
Just subdir ->
|
||||
|
|
|
@ -42,7 +42,7 @@ remote = RemoteType
|
|||
, generate = gen
|
||||
, setup = directorySetup
|
||||
, exportSupported = exportIsSupported
|
||||
, importSupported = importUnsupported
|
||||
, importSupported = importIsSupported
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||
|
|
|
@ -17,6 +17,7 @@ import Backend
|
|||
import Remote.Helper.Encryptable (isEncrypted)
|
||||
import Database.Export
|
||||
import Annex.Export
|
||||
import Annex.Import
|
||||
import Config
|
||||
import Git.Types (fromRef)
|
||||
import Logs.Export
|
||||
|
@ -60,27 +61,57 @@ instance HasImportUnsupported (ImportActions Annex) where
|
|||
exportIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
|
||||
exportIsSupported = \_ _ -> return True
|
||||
|
||||
-- | Prevent or allow exporttree=yes when setting up a new remote,
|
||||
-- depending on exportSupported and other configuration.
|
||||
adjustExportableRemoteType :: RemoteType -> RemoteType
|
||||
adjustExportableRemoteType rt = rt { setup = setup' }
|
||||
importIsSupported :: RemoteConfig -> RemoteGitConfig -> Annex Bool
|
||||
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' }
|
||||
where
|
||||
setup' st mu cp c gc = do
|
||||
let cont = setup rt st mu cp c gc
|
||||
ifM (exportSupported rt c gc)
|
||||
setup' st mu cp c gc =
|
||||
let checkconfig supported configured setting cont =
|
||||
ifM (supported rt c gc)
|
||||
( case st of
|
||||
Init
|
||||
| exportTree c && isEncrypted c ->
|
||||
giveup "cannot enable both encryption and exporttree"
|
||||
| configured c && isEncrypted c ->
|
||||
giveup $ "cannot enable both encryption and " ++ setting
|
||||
| otherwise -> cont
|
||||
Enable oldc
|
||||
| exportTree c /= exportTree oldc ->
|
||||
giveup "cannot change exporttree of existing special remote"
|
||||
| configured c /= configured oldc ->
|
||||
giveup $ "cannot change " ++ setting ++ " of existing special remote"
|
||||
| otherwise -> cont
|
||||
, if exportTree c
|
||||
then giveup "exporttree=yes is not supported by this special remote"
|
||||
, if configured c
|
||||
then giveup $ setting ++ " is not supported by this special remote"
|
||||
else cont
|
||||
)
|
||||
in checkconfig exportSupported exportTree "exporttree" $
|
||||
checkconfig importSupported importTree "importtree" $
|
||||
if importTree c && not (exportTree c)
|
||||
then giveup "cannot enable importtree=yes without also enabling exporttree=yes"
|
||||
else setup rt st mu cp c gc
|
||||
|
||||
-- | If the remote is importSupported, and importtree=yes, adjust the
|
||||
-- remote to be an import.
|
||||
--
|
||||
-- (This relies on all import remotes also being export remotes,
|
||||
-- so adjustExportable will adjust the remote actions to use the
|
||||
-- exported/imported tree.)
|
||||
adjustImportable :: Remote -> Annex Remote
|
||||
adjustImportable r
|
||||
| importTree (config r) =
|
||||
ifM (isExportSupported r)
|
||||
( return r
|
||||
, notimport
|
||||
)
|
||||
| otherwise = notimport
|
||||
where
|
||||
notimport = return $ r
|
||||
{ importActions = importUnsupported
|
||||
, remotetype = (remotetype r)
|
||||
{ importSupported = importUnsupported
|
||||
}
|
||||
}
|
||||
|
||||
-- | If the remote is exportSupported, and exporttree=yes, adjust the
|
||||
-- remote to be an export.
|
||||
|
|
|
@ -44,7 +44,7 @@ import qualified Remote.Hook
|
|||
import qualified Remote.External
|
||||
|
||||
remoteTypes :: [RemoteType]
|
||||
remoteTypes = map adjustExportableRemoteType
|
||||
remoteTypes = map adjustExportImportRemoteType
|
||||
[ Remote.Git.remote
|
||||
, Remote.GCrypt.remote
|
||||
, Remote.P2P.remote
|
||||
|
@ -100,13 +100,16 @@ remoteListRefresh = do
|
|||
|
||||
{- Generates a Remote. -}
|
||||
remoteGen :: M.Map UUID RemoteConfig -> RemoteType -> Git.Repo -> Annex (Maybe Remote)
|
||||
remoteGen m t r = do
|
||||
u <- getRepoUUID r
|
||||
gc <- Annex.getRemoteGitConfig r
|
||||
remoteGen m t g = do
|
||||
u <- getRepoUUID g
|
||||
gc <- Annex.getRemoteGitConfig g
|
||||
let c = fromMaybe M.empty $ M.lookup u m
|
||||
generate t r u c gc >>= maybe
|
||||
(return Nothing)
|
||||
(Just <$$> adjustExportable . adjustReadOnly . addHooks)
|
||||
generate t g u c gc >>= \case
|
||||
Nothing -> return Nothing
|
||||
Just r -> do
|
||||
r' <- adjustImportable (adjustReadOnly (addHooks r))
|
||||
r'' <- adjustExportable r'
|
||||
return $ Just r''
|
||||
|
||||
{- Updates a local git Remote, re-reading its git config. -}
|
||||
updateRemote :: Remote -> Annex (Maybe Remote)
|
||||
|
|
|
@ -20,6 +20,7 @@ module Types.Remote
|
|||
, unVerified
|
||||
, RetrievalSecurityPolicy(..)
|
||||
, isExportSupported
|
||||
, isImportSupported
|
||||
, ExportActions(..)
|
||||
, ImportActions(..)
|
||||
, ByteSize
|
||||
|
@ -215,6 +216,9 @@ data RetrievalSecurityPolicy
|
|||
isExportSupported :: RemoteA a -> a Bool
|
||||
isExportSupported r = exportSupported (remotetype r) (config r) (gitconfig r)
|
||||
|
||||
isImportSupported :: RemoteA a -> a Bool
|
||||
isImportSupported r = importSupported (remotetype r) (config r) (gitconfig r)
|
||||
|
||||
data ExportActions a = ExportActions
|
||||
-- Exports content to an ExportLocation.
|
||||
-- The exported file should not appear to be present on the remote
|
||||
|
|
|
@ -13,8 +13,6 @@ this.
|
|||
* Need to support annex-tracking-branch configuration, which documentation
|
||||
says makes git-annex sync and assistant do imports.
|
||||
|
||||
* need to check if a remote has importtree=yes before trying to import from it
|
||||
|
||||
* export needs to use storeExportWithContentIdentifierM for importtree=yes
|
||||
remotes
|
||||
|
||||
|
|
Loading…
Reference in a new issue