type based git config handling for remotes
Still a couple of places that use git config ad-hoc, but this is most of it done.
This commit is contained in:
parent
16b2454680
commit
4008590c68
33 changed files with 341 additions and 299 deletions
26
Annex.hs
26
Annex.hs
|
@ -28,8 +28,8 @@ module Annex (
|
|||
gitRepo,
|
||||
inRepo,
|
||||
fromRepo,
|
||||
getConfig,
|
||||
changeConfig,
|
||||
getGitConfig,
|
||||
changeGitConfig,
|
||||
changeGitRepo,
|
||||
) where
|
||||
|
||||
|
@ -46,7 +46,7 @@ import Git.CheckAttr
|
|||
import Git.SharedRepository
|
||||
import qualified Git.Queue
|
||||
import Types.Backend
|
||||
import Types.Config
|
||||
import Types.GitConfig
|
||||
import qualified Types.Remote
|
||||
import Types.Crypto
|
||||
import Types.BranchState
|
||||
|
@ -92,7 +92,7 @@ type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> Fi
|
|||
-- internal state storage
|
||||
data AnnexState = AnnexState
|
||||
{ repo :: Git.Repo
|
||||
, config :: Config
|
||||
, gitconfig :: GitConfig
|
||||
, backends :: [BackendA Annex]
|
||||
, remotes :: [Types.Remote.RemoteA Annex]
|
||||
, output :: MessageState
|
||||
|
@ -122,7 +122,7 @@ data AnnexState = AnnexState
|
|||
newState :: Git.Repo -> AnnexState
|
||||
newState gitrepo = AnnexState
|
||||
{ repo = gitrepo
|
||||
, config = extractConfig gitrepo
|
||||
, gitconfig = extractGitConfig gitrepo
|
||||
, backends = []
|
||||
, remotes = []
|
||||
, output = defaultMessageState
|
||||
|
@ -202,17 +202,17 @@ inRepo a = liftIO . a =<< gitRepo
|
|||
fromRepo :: (Git.Repo -> a) -> Annex a
|
||||
fromRepo a = a <$> gitRepo
|
||||
|
||||
{- Gets the Config settings. -}
|
||||
getConfig :: Annex Config
|
||||
getConfig = getState config
|
||||
{- Gets the GitConfig settings. -}
|
||||
getGitConfig :: Annex GitConfig
|
||||
getGitConfig = getState gitconfig
|
||||
|
||||
{- Modifies a Config setting. -}
|
||||
changeConfig :: (Config -> Config) -> Annex ()
|
||||
changeConfig a = changeState $ \s -> s { config = a (config s) }
|
||||
{- Modifies a GitConfig setting. -}
|
||||
changeGitConfig :: (GitConfig -> GitConfig) -> Annex ()
|
||||
changeGitConfig a = changeState $ \s -> s { gitconfig = a (gitconfig s) }
|
||||
|
||||
{- Changing the git Repo data also involves re-extracting its Config. -}
|
||||
{- Changing the git Repo data also involves re-extracting its GitConfig. -}
|
||||
changeGitRepo :: Git.Repo -> Annex ()
|
||||
changeGitRepo r = changeState $ \s -> s
|
||||
{ repo = r
|
||||
, config = extractConfig r
|
||||
, gitconfig = extractGitConfig r
|
||||
}
|
||||
|
|
|
@ -187,7 +187,7 @@ withTmp key action = do
|
|||
- in a destination (or the annex) printing a warning if not. -}
|
||||
checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
|
||||
checkDiskSpace destination key alreadythere = do
|
||||
reserve <- annexDiskReserve <$> Annex.getConfig
|
||||
reserve <- annexDiskReserve <$> Annex.getGitConfig
|
||||
free <- liftIO . getDiskFree =<< dir
|
||||
force <- Annex.getState Annex.force
|
||||
case (free, keySize key) of
|
||||
|
@ -395,7 +395,7 @@ saveState :: Bool -> Annex ()
|
|||
saveState nocommit = doSideAction $ do
|
||||
Annex.Queue.flush
|
||||
unless nocommit $
|
||||
whenM (annexAlwaysCommit <$> Annex.getConfig) $
|
||||
whenM (annexAlwaysCommit <$> Annex.getGitConfig) $
|
||||
Annex.Branch.commit "update"
|
||||
|
||||
{- Downloads content from any of a list of urls. -}
|
||||
|
|
|
@ -54,7 +54,7 @@ get = maybe new return =<< getState repoqueue
|
|||
|
||||
new :: Annex Git.Queue.Queue
|
||||
new = do
|
||||
q <- Git.Queue.new . annexQueueSize <$> getConfig
|
||||
q <- Git.Queue.new . annexQueueSize <$> getGitConfig
|
||||
store q
|
||||
return q
|
||||
|
||||
|
|
|
@ -59,7 +59,7 @@ sshInfo (host, port) = ifM caching
|
|||
caching = return False
|
||||
#else
|
||||
caching = fromMaybe SysConfig.sshconnectioncaching
|
||||
. annexSshCaching <$> Annex.getConfig
|
||||
. annexSshCaching <$> Annex.getGitConfig
|
||||
#endif
|
||||
|
||||
cacheParams :: FilePath -> [CommandParam]
|
||||
|
|
|
@ -9,6 +9,7 @@ module Annex.Version where
|
|||
|
||||
import Common.Annex
|
||||
import Config
|
||||
import qualified Annex
|
||||
|
||||
type Version = String
|
||||
|
||||
|
@ -25,10 +26,7 @@ versionField :: ConfigKey
|
|||
versionField = annexConfig "version"
|
||||
|
||||
getVersion :: Annex (Maybe Version)
|
||||
getVersion = handle <$> getConfig versionField ""
|
||||
where
|
||||
handle [] = Nothing
|
||||
handle v = Just v
|
||||
getVersion = annexVersion <$> Annex.getGitConfig
|
||||
|
||||
setVersion :: Annex ()
|
||||
setVersion = setConfig versionField defaultVersion
|
||||
|
|
|
@ -17,7 +17,6 @@ import Logs.Trust
|
|||
import qualified Remote
|
||||
import qualified Types.Remote as Remote
|
||||
import qualified Git
|
||||
import Config
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import System.Posix.Types
|
||||
|
@ -48,7 +47,7 @@ modifyDaemonStatus a = do
|
|||
{- Returns a function that updates the lists of syncable remotes. -}
|
||||
calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus)
|
||||
calcSyncRemotes = do
|
||||
rs <- filterM (repoSyncable . Remote.repo) =<<
|
||||
rs <- filter (remoteAnnexSync . Remote.gitconfig) .
|
||||
concat . Remote.byCost <$> Remote.enabledRemoteList
|
||||
alive <- trustExclude DeadTrusted (map Remote.uuid rs)
|
||||
let good r = Remote.uuid r `elem` alive
|
||||
|
|
|
@ -44,7 +44,7 @@ commitThread :: NamedThread
|
|||
commitThread = NamedThread "Committer" $ do
|
||||
delayadd <- liftAnnex $
|
||||
maybe delayaddDefault (return . Just . Seconds)
|
||||
=<< annexDelayAdd <$> Annex.getConfig
|
||||
=<< annexDelayAdd <$> Annex.getGitConfig
|
||||
runEvery (Seconds 1) <~> do
|
||||
-- We already waited one second as a simple rate limiter.
|
||||
-- Next, wait until at least one change is available for
|
||||
|
|
|
@ -19,7 +19,6 @@ import qualified Types.Remote as Remote
|
|||
import Annex.UUID (getUUID)
|
||||
import Logs.Remote
|
||||
import Logs.Trust
|
||||
import Config
|
||||
import qualified Git
|
||||
#ifdef WITH_XMPP
|
||||
import Assistant.XMPP.Client
|
||||
|
@ -146,9 +145,9 @@ repoList reposelector
|
|||
unconfigured <- map snd . catMaybes . filter wantedremote
|
||||
. map (findinfo m)
|
||||
<$> (trustExclude DeadTrusted $ M.keys m)
|
||||
unsyncable <- map Remote.uuid . filter wantedrepo <$>
|
||||
(filterM (\r -> not <$> repoSyncable (Remote.repo r))
|
||||
=<< Remote.enabledRemoteList)
|
||||
unsyncable <- map Remote.uuid . filter wantedrepo .
|
||||
filter (not . remoteAnnexSync . Remote.gitconfig)
|
||||
<$> Remote.enabledRemoteList
|
||||
return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured
|
||||
wantedrepo r
|
||||
| Remote.readonly r = False
|
||||
|
@ -189,6 +188,6 @@ getDisableSyncR = flipSync False
|
|||
|
||||
flipSync :: Bool -> UUID -> Handler ()
|
||||
flipSync enable uuid = do
|
||||
mremote <- runAnnex undefined $ snd <$> Remote.repoFromUUID uuid
|
||||
mremote <- runAnnex undefined $ Remote.remoteFromUUID uuid
|
||||
changeSyncable mremote enable
|
||||
redirect RepositoriesR
|
||||
|
|
|
@ -15,12 +15,12 @@ import Assistant.DaemonStatus
|
|||
import Assistant.MakeRemote (uniqueRemoteName)
|
||||
import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
|
||||
import qualified Remote
|
||||
import qualified Types.Remote as Remote
|
||||
import qualified Remote.List as Remote
|
||||
import Logs.UUID
|
||||
import Logs.Group
|
||||
import Logs.PreferredContent
|
||||
import Types.StandardGroups
|
||||
import qualified Config
|
||||
import qualified Git
|
||||
import qualified Git.Command
|
||||
import qualified Git.Config
|
||||
|
@ -40,12 +40,12 @@ data RepoConfig = RepoConfig
|
|||
}
|
||||
deriving (Show)
|
||||
|
||||
getRepoConfig :: UUID -> Git.Repo -> Maybe Remote -> Annex RepoConfig
|
||||
getRepoConfig uuid r mremote = RepoConfig
|
||||
getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
|
||||
getRepoConfig uuid mremote = RepoConfig
|
||||
<$> pure (T.pack $ maybe "here" Remote.name mremote)
|
||||
<*> (maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap)
|
||||
<*> getrepogroup
|
||||
<*> Config.repoSyncable r
|
||||
<*> pure (maybe True (remoteAnnexSync . Remote.gitconfig) mremote)
|
||||
where
|
||||
getrepogroup = do
|
||||
groups <- lookupGroups uuid
|
||||
|
@ -113,8 +113,8 @@ getEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
|
|||
|
||||
editForm :: Bool -> UUID -> Handler RepHtml
|
||||
editForm new uuid = page "Configure repository" (Just Configuration) $ do
|
||||
(repo, mremote) <- lift $ runAnnex undefined $ Remote.repoFromUUID uuid
|
||||
curr <- lift $ runAnnex undefined $ getRepoConfig uuid repo mremote
|
||||
mremote <- lift $ runAnnex undefined $ Remote.remoteFromUUID uuid
|
||||
curr <- lift $ runAnnex undefined $ getRepoConfig uuid mremote
|
||||
lift $ checkarchivedirectory curr
|
||||
((result, form), enctype) <- lift $
|
||||
runFormGet $ renderBootstrap $ editRepositoryAForm curr
|
||||
|
|
|
@ -44,7 +44,7 @@ orderedList = do
|
|||
Just name | not (null name) ->
|
||||
return [lookupBackendName name]
|
||||
_ -> do
|
||||
l' <- gen . annexBackends <$> Annex.getConfig
|
||||
l' <- gen . annexBackends <$> Annex.getGitConfig
|
||||
Annex.changeState $ \s -> s { Annex.backends = l' }
|
||||
return l'
|
||||
where
|
||||
|
|
|
@ -200,7 +200,7 @@ transfer_list = stat "transfers in progress" $ nojson $ lift $ do
|
|||
disk_size :: Stat
|
||||
disk_size = stat "available local disk space" $ json id $ lift $
|
||||
calcfree
|
||||
<$> (annexDiskReserve <$> Annex.getConfig)
|
||||
<$> (annexDiskReserve <$> Annex.getGitConfig)
|
||||
<*> inRepo (getDiskFree . gitAnnexDir)
|
||||
where
|
||||
calcfree reserve (Just have) = unwords
|
||||
|
|
|
@ -72,8 +72,8 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted )
|
|||
unwords (map Types.Remote.name s)
|
||||
return l
|
||||
available = filter (not . Remote.specialRemote)
|
||||
<$> (filterM (repoSyncable . Types.Remote.repo)
|
||||
=<< Remote.enabledRemoteList)
|
||||
. filter (remoteAnnexSync . Types.Remote.gitconfig)
|
||||
<$> Remote.enabledRemoteList
|
||||
good = filterM $ Remote.Git.repoAvail . Types.Remote.repo
|
||||
fastest = fromMaybe [] . headMaybe . Remote.byCost
|
||||
|
||||
|
|
|
@ -180,9 +180,9 @@ exclude smaller larger = S.toList $ remove larger $ S.fromList smaller
|
|||
- so will easily fit on even my lowest memory systems.
|
||||
-}
|
||||
bloomCapacity :: Annex Int
|
||||
bloomCapacity = fromMaybe 500000 . annexBloomCapacity <$> Annex.getConfig
|
||||
bloomCapacity = fromMaybe 500000 . annexBloomCapacity <$> Annex.getGitConfig
|
||||
bloomAccuracy :: Annex Int
|
||||
bloomAccuracy = fromMaybe 1000 . annexBloomAccuracy <$> Annex.getConfig
|
||||
bloomAccuracy = fromMaybe 1000 . annexBloomAccuracy <$> Annex.getGitConfig
|
||||
bloomBitsHashes :: Annex (Int, Int)
|
||||
bloomBitsHashes = do
|
||||
capacity <- bloomCapacity
|
||||
|
|
55
Config.hs
55
Config.hs
|
@ -16,6 +16,10 @@ import qualified Annex
|
|||
type UnqualifiedConfigKey = String
|
||||
data ConfigKey = ConfigKey String
|
||||
|
||||
{- Looks up a setting in git config. -}
|
||||
getConfig :: ConfigKey -> String -> Annex String
|
||||
getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def
|
||||
|
||||
{- Changes a git config setting in both internal state and .git/config -}
|
||||
setConfig :: ConfigKey -> String -> Annex ()
|
||||
setConfig (ConfigKey key) value = do
|
||||
|
@ -27,16 +31,6 @@ unsetConfig :: ConfigKey -> Annex ()
|
|||
unsetConfig (ConfigKey key) = inRepo $ Git.Command.run "config"
|
||||
[Param "--unset", Param key]
|
||||
|
||||
{- Looks up a setting in git config. -}
|
||||
getConfig :: ConfigKey -> String -> Annex String
|
||||
getConfig (ConfigKey key) def = fromRepo $ Git.Config.get key def
|
||||
|
||||
{- Looks up a per-remote config setting in git config.
|
||||
- Failing that, tries looking for a global config option. -}
|
||||
getRemoteConfig :: Git.Repo -> UnqualifiedConfigKey -> String -> Annex String
|
||||
getRemoteConfig r key def =
|
||||
getConfig (remoteConfig r key) =<< getConfig (annexConfig key) def
|
||||
|
||||
{- A per-remote config setting in git config. -}
|
||||
remoteConfig :: Git.Repo -> UnqualifiedConfigKey -> ConfigKey
|
||||
remoteConfig r key = ConfigKey $
|
||||
|
@ -46,16 +40,15 @@ remoteConfig r key = ConfigKey $
|
|||
annexConfig :: UnqualifiedConfigKey -> ConfigKey
|
||||
annexConfig key = ConfigKey $ "annex." ++ key
|
||||
|
||||
{- Calculates cost for a remote. Either the default, or as configured
|
||||
{- Calculates cost for a remote. Either the specific default, or as configured
|
||||
- by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command
|
||||
- is set and prints a number, that is used. -}
|
||||
remoteCost :: Git.Repo -> Int -> Annex Int
|
||||
remoteCost r def = do
|
||||
cmd <- getRemoteConfig r "cost-command" ""
|
||||
(fromMaybe def . readish) <$>
|
||||
if not $ null cmd
|
||||
then liftIO $ readProcess "sh" ["-c", cmd]
|
||||
else getRemoteConfig r "cost" ""
|
||||
remoteCost :: RemoteGitConfig -> Int -> Annex Int
|
||||
remoteCost c def = case remoteAnnexCostCommand c of
|
||||
Just cmd | not (null cmd) -> liftIO $
|
||||
(fromMaybe def . readish) <$>
|
||||
readProcess "sh" ["-c", cmd]
|
||||
_ -> return $ fromMaybe def $ remoteAnnexCost c
|
||||
|
||||
cheapRemoteCost :: Int
|
||||
cheapRemoteCost = 100
|
||||
|
@ -81,38 +74,22 @@ prop_cost_sane = False `notElem`
|
|||
, semiCheapRemoteCost + encryptedRemoteCostAdj < expensiveRemoteCost
|
||||
]
|
||||
|
||||
{- Checks if a repo should be ignored. -}
|
||||
repoNotIgnored :: Git.Repo -> Annex Bool
|
||||
repoNotIgnored r = not . fromMaybe False . Git.Config.isTrue
|
||||
<$> getRemoteConfig r "ignore" ""
|
||||
|
||||
{- Checks if a repo should be synced. -}
|
||||
repoSyncable :: Git.Repo -> Annex Bool
|
||||
repoSyncable r = fromMaybe True . Git.Config.isTrue
|
||||
<$> getRemoteConfig r "sync" ""
|
||||
|
||||
{- Gets the trust level set for a remote in git config. -}
|
||||
getTrustLevel :: Git.Repo -> Annex (Maybe String)
|
||||
getTrustLevel r = fromRepo $ Git.Config.getMaybe key
|
||||
where
|
||||
(ConfigKey key) = remoteConfig r "trustlevel"
|
||||
|
||||
getNumCopies :: Maybe Int -> Annex Int
|
||||
getNumCopies (Just v) = return v
|
||||
getNumCopies Nothing = annexNumCopies <$> Annex.getConfig
|
||||
getNumCopies Nothing = annexNumCopies <$> Annex.getGitConfig
|
||||
|
||||
isDirect :: Annex Bool
|
||||
isDirect = annexDirect <$> Annex.getConfig
|
||||
isDirect = annexDirect <$> Annex.getGitConfig
|
||||
|
||||
setDirect :: Bool -> Annex ()
|
||||
setDirect b = do
|
||||
setConfig (annexConfig "direct") $ if b then "true" else "false"
|
||||
Annex.changeConfig $ \c -> c { annexDirect = b }
|
||||
Annex.changeGitConfig $ \c -> c { annexDirect = b }
|
||||
|
||||
{- Gets the http headers to use. -}
|
||||
getHttpHeaders :: Annex [String]
|
||||
getHttpHeaders = do
|
||||
v <- annexHttpHeadersCommand <$> Annex.getConfig
|
||||
v <- annexHttpHeadersCommand <$> Annex.getGitConfig
|
||||
case v of
|
||||
Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd])
|
||||
Nothing -> annexHttpHeaders <$> Annex.getConfig
|
||||
Nothing -> annexHttpHeaders <$> Annex.getGitConfig
|
||||
|
|
|
@ -171,7 +171,7 @@ options = Option.common ++
|
|||
] ++ Option.matcher
|
||||
where
|
||||
setnumcopies v = maybe noop
|
||||
(\n -> Annex.changeConfig $ \c -> c { annexNumCopies = n })
|
||||
(\n -> Annex.changeGitConfig $ \c -> c { annexNumCopies = n })
|
||||
(readish v)
|
||||
setgitconfig v = Annex.changeGitRepo =<< inRepo (Git.Config.store v)
|
||||
|
||||
|
|
|
@ -28,7 +28,6 @@ import qualified Annex.Branch
|
|||
import qualified Annex
|
||||
import Logs.UUIDBased
|
||||
import Remote.List
|
||||
import Config
|
||||
import qualified Types.Remote
|
||||
|
||||
{- Filename of trust.log. -}
|
||||
|
@ -85,14 +84,14 @@ trustMapLoad = do
|
|||
overrides <- Annex.getState Annex.forcetrust
|
||||
logged <- trustMapRaw
|
||||
configured <- M.fromList . catMaybes
|
||||
<$> (mapM configuredtrust =<< remoteList)
|
||||
<$> (map configuredtrust <$> remoteList)
|
||||
let m = M.union overrides $ M.union configured logged
|
||||
Annex.changeState $ \s -> s { Annex.trustmap = Just m }
|
||||
return m
|
||||
where
|
||||
configuredtrust r = maybe Nothing (\l -> Just (Types.Remote.uuid r, l))
|
||||
<$> maybe Nothing readTrustLevel
|
||||
<$> getTrustLevel (Types.Remote.repo r)
|
||||
configuredtrust r = (\l -> Just (Types.Remote.uuid r, l))
|
||||
=<< readTrustLevel
|
||||
=<< remoteAnnexTrustLevel (Types.Remote.gitconfig r)
|
||||
|
||||
{- Does not include forcetrust or git config values, just those from the
|
||||
- log file. -}
|
||||
|
|
16
Remote.hs
16
Remote.hs
|
@ -27,7 +27,7 @@ module Remote (
|
|||
byCost,
|
||||
prettyPrintUUIDs,
|
||||
prettyListUUIDs,
|
||||
repoFromUUID,
|
||||
remoteFromUUID,
|
||||
remotesWithUUID,
|
||||
remotesWithoutUUID,
|
||||
keyLocations,
|
||||
|
@ -53,7 +53,6 @@ import Logs.UUID
|
|||
import Logs.Trust
|
||||
import Logs.Location hiding (logStatus)
|
||||
import Remote.List
|
||||
import qualified Git
|
||||
|
||||
{- Map from UUIDs of Remotes to a calculated value. -}
|
||||
remoteMap :: (Remote -> a) -> Annex (M.Map UUID a)
|
||||
|
@ -147,15 +146,12 @@ prettyListUUIDs uuids = do
|
|||
where
|
||||
n = finddescription m u
|
||||
|
||||
{- Gets the git repo associated with a UUID.
|
||||
{- Gets the remote associated with a UUID.
|
||||
- There's no associated remote when this is the UUID of the local repo. -}
|
||||
repoFromUUID :: UUID -> Annex (Git.Repo, Maybe Remote)
|
||||
repoFromUUID u = ifM ((==) u <$> getUUID)
|
||||
( (,) <$> gitRepo <*> pure Nothing
|
||||
, do
|
||||
remote <- fromMaybe (error "Unknown UUID") . M.lookup u
|
||||
<$> remoteMap id
|
||||
return (repo remote, Just remote)
|
||||
remoteFromUUID :: UUID -> Annex (Maybe Remote)
|
||||
remoteFromUUID u = ifM ((==) u <$> getUUID)
|
||||
( return Nothing
|
||||
, Just . fromMaybe (error "Unknown UUID") . M.lookup u <$> remoteMap id
|
||||
)
|
||||
|
||||
{- Filters a list of remotes to ones that have the listed uuids. -}
|
||||
|
|
|
@ -38,35 +38,41 @@ remote = RemoteType {
|
|||
setup = bupSetup
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
||||
gen r u c = do
|
||||
buprepo <- getRemoteConfig r "buprepo" (error "missing buprepo")
|
||||
cst <- remoteCost r (if bupLocal buprepo then semiCheapRemoteCost else expensiveRemoteCost)
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
||||
gen r u c gc = do
|
||||
bupr <- liftIO $ bup2GitRemote buprepo
|
||||
cst <- remoteCost gc $
|
||||
if bupLocal buprepo
|
||||
then semiCheapRemoteCost
|
||||
else expensiveRemoteCost
|
||||
(u', bupr') <- getBupUUID bupr u
|
||||
|
||||
let new = Remote
|
||||
{ uuid = u'
|
||||
, cost = cst
|
||||
, name = Git.repoDescribe r
|
||||
, storeKey = store new buprepo
|
||||
, retrieveKeyFile = retrieve buprepo
|
||||
, retrieveKeyFileCheap = retrieveCheap buprepo
|
||||
, removeKey = remove
|
||||
, hasKey = checkPresent r bupr'
|
||||
, hasKeyCheap = bupLocal buprepo
|
||||
, whereisKey = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, gitconfig = gc
|
||||
, localpath = if bupLocal buprepo && not (null buprepo)
|
||||
then Just buprepo
|
||||
else Nothing
|
||||
, remotetype = remote
|
||||
, readonly = False
|
||||
}
|
||||
return $ encryptableRemote c
|
||||
(storeEncrypted r buprepo)
|
||||
(storeEncrypted new buprepo)
|
||||
(retrieveEncrypted buprepo)
|
||||
Remote
|
||||
{ uuid = u'
|
||||
, cost = cst
|
||||
, name = Git.repoDescribe r
|
||||
, storeKey = store r buprepo
|
||||
, retrieveKeyFile = retrieve buprepo
|
||||
, retrieveKeyFileCheap = retrieveCheap buprepo
|
||||
, removeKey = remove
|
||||
, hasKey = checkPresent r bupr'
|
||||
, hasKeyCheap = bupLocal buprepo
|
||||
, whereisKey = Nothing
|
||||
, config = c
|
||||
, repo = r
|
||||
, localpath = if bupLocal buprepo && not (null buprepo)
|
||||
then Just buprepo
|
||||
else Nothing
|
||||
, remotetype = remote
|
||||
, readonly = False
|
||||
}
|
||||
new
|
||||
where
|
||||
buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
|
||||
|
||||
bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
bupSetup u c = do
|
||||
|
@ -106,21 +112,20 @@ pipeBup params inh outh = do
|
|||
ExitSuccess -> return True
|
||||
_ -> return False
|
||||
|
||||
bupSplitParams :: Git.Repo -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam]
|
||||
bupSplitParams :: Remote -> BupRepo -> Key -> [CommandParam] -> Annex [CommandParam]
|
||||
bupSplitParams r buprepo k src = do
|
||||
o <- getRemoteConfig r "bup-split-options" ""
|
||||
let os = map Param $ words o
|
||||
let os = map Param $ remoteAnnexBupSplitOptions $ gitconfig r
|
||||
showOutput -- make way for bup output
|
||||
return $ bupParams "split" buprepo
|
||||
(os ++ [Param "-n", Param (bupRef k)] ++ src)
|
||||
|
||||
store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
store :: Remote -> BupRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
store r buprepo k _f _p = do
|
||||
src <- inRepo $ gitAnnexLocation k
|
||||
params <- bupSplitParams r buprepo k [File src]
|
||||
liftIO $ boolSystem "bup" params
|
||||
|
||||
storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
||||
storeEncrypted :: Remote -> BupRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
||||
storeEncrypted r buprepo (cipher, enck) k _p = do
|
||||
src <- inRepo $ gitAnnexLocation k
|
||||
params <- bupSplitParams r buprepo enck []
|
||||
|
|
|
@ -33,10 +33,9 @@ remote = RemoteType {
|
|||
setup = directorySetup
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
||||
gen r u c = do
|
||||
dir <- getRemoteConfig r "directory" (error "missing directory")
|
||||
cst <- remoteCost r cheapRemoteCost
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
||||
gen r u c gc = do
|
||||
cst <- remoteCost gc cheapRemoteCost
|
||||
let chunksize = chunkSize c
|
||||
return $ encryptableRemote c
|
||||
(storeEncrypted dir chunksize)
|
||||
|
@ -54,10 +53,13 @@ gen r u c = do
|
|||
whereisKey = Nothing,
|
||||
config = M.empty,
|
||||
repo = r,
|
||||
gitconfig = gc,
|
||||
localpath = Just dir,
|
||||
readonly = False,
|
||||
remotetype = remote
|
||||
}
|
||||
where
|
||||
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
|
||||
|
||||
directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
directorySetup u c = do
|
||||
|
|
124
Remote/Git.hs
124
Remote/Git.hs
|
@ -19,6 +19,7 @@ import Utility.CopyFile
|
|||
import Utility.Rsync
|
||||
import Remote.Helper.Ssh
|
||||
import Types.Remote
|
||||
import Types.GitConfig
|
||||
import qualified Git
|
||||
import qualified Git.Config
|
||||
import qualified Git.Construct
|
||||
|
@ -73,10 +74,11 @@ list = do
|
|||
- cached UUID value. -}
|
||||
configRead :: Git.Repo -> Annex Git.Repo
|
||||
configRead r = do
|
||||
notignored <- repoNotIgnored r
|
||||
g <- fromRepo id
|
||||
let c = extractRemoteGitConfig g (Git.repoDescribe r)
|
||||
u <- getRepoUUID r
|
||||
case (repoCheap r, notignored, u) of
|
||||
(_, False, _) -> return r
|
||||
case (repoCheap r, remoteAnnexIgnore c, u) of
|
||||
(_, True, _) -> return r
|
||||
(True, _, _) -> tryGitConfigRead r
|
||||
(False, _, NoUUID) -> tryGitConfigRead r
|
||||
_ -> return r
|
||||
|
@ -84,29 +86,32 @@ configRead r = do
|
|||
repoCheap :: Git.Repo -> Bool
|
||||
repoCheap = not . Git.repoIsUrl
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
||||
gen r u _ = new <$> remoteCost r defcst
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
||||
gen r u _ gc = go <$> remoteCost gc defcst
|
||||
where
|
||||
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
|
||||
new cst = Remote
|
||||
{ uuid = u
|
||||
, cost = cst
|
||||
, name = Git.repoDescribe r
|
||||
, storeKey = copyToRemote r
|
||||
, retrieveKeyFile = copyFromRemote r
|
||||
, retrieveKeyFileCheap = copyFromRemoteCheap r
|
||||
, removeKey = dropKey r
|
||||
, hasKey = inAnnex r
|
||||
, hasKeyCheap = repoCheap r
|
||||
, whereisKey = Nothing
|
||||
, config = M.empty
|
||||
, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r
|
||||
then Just $ Git.repoPath r
|
||||
else Nothing
|
||||
, repo = r
|
||||
, readonly = Git.repoIsHttp r
|
||||
, remotetype = remote
|
||||
}
|
||||
go cst = new
|
||||
where
|
||||
new = Remote
|
||||
{ uuid = u
|
||||
, cost = cst
|
||||
, name = Git.repoDescribe r
|
||||
, storeKey = copyToRemote new
|
||||
, retrieveKeyFile = copyFromRemote new
|
||||
, retrieveKeyFileCheap = copyFromRemoteCheap new
|
||||
, removeKey = dropKey new
|
||||
, hasKey = inAnnex r
|
||||
, hasKeyCheap = repoCheap r
|
||||
, whereisKey = Nothing
|
||||
, config = M.empty
|
||||
, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r
|
||||
then Just $ Git.repoPath r
|
||||
else Nothing
|
||||
, repo = r
|
||||
, gitconfig = gc
|
||||
, readonly = Git.repoIsHttp r
|
||||
, remotetype = remote
|
||||
}
|
||||
|
||||
{- Checks relatively inexpensively if a repository is available for use. -}
|
||||
repoAvail :: Git.Repo -> Annex Bool
|
||||
|
@ -236,10 +241,10 @@ keyUrls r key = map tourl (annexLocations key)
|
|||
where
|
||||
tourl l = Git.repoLocation r ++ "/" ++ l
|
||||
|
||||
dropKey :: Git.Repo -> Key -> Annex Bool
|
||||
dropKey :: Remote -> Key -> Annex Bool
|
||||
dropKey r key
|
||||
| not $ Git.repoIsUrl r =
|
||||
guardUsable r False $ commitOnCleanup r $ liftIO $ onLocal r $ do
|
||||
| not $ Git.repoIsUrl (repo r) =
|
||||
guardUsable (repo r) False $ commitOnCleanup r $ liftIO $ onLocal (repo r) $ do
|
||||
ensureInitialized
|
||||
whenM (Annex.Content.inAnnex key) $ do
|
||||
Annex.Content.lockContent key $
|
||||
|
@ -247,29 +252,29 @@ dropKey r key
|
|||
logStatus key InfoMissing
|
||||
Annex.Content.saveState True
|
||||
return True
|
||||
| Git.repoIsHttp r = error "dropping from http repo not supported"
|
||||
| otherwise = commitOnCleanup r $ onRemote r (boolSystem, False) "dropkey"
|
||||
| Git.repoIsHttp (repo r) = error "dropping from http repo not supported"
|
||||
| otherwise = commitOnCleanup r $ onRemote (repo r) (boolSystem, False) "dropkey"
|
||||
[ Params "--quiet --force"
|
||||
, Param $ key2file key
|
||||
]
|
||||
[]
|
||||
|
||||
{- Tries to copy a key's content from a remote's annex to a file. -}
|
||||
copyFromRemote :: Git.Repo -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
copyFromRemote r key file dest
|
||||
| not $ Git.repoIsUrl r = guardUsable r False $ do
|
||||
params <- rsyncParams r
|
||||
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
|
||||
let params = rsyncParams r
|
||||
u <- getUUID
|
||||
-- run copy from perspective of remote
|
||||
liftIO $ onLocal r $ do
|
||||
liftIO $ onLocal (repo r) $ do
|
||||
ensureInitialized
|
||||
Annex.Content.sendAnnex key $ \object ->
|
||||
upload u key file noRetry $
|
||||
rsyncOrCopyFile params object dest
|
||||
| Git.repoIsSsh r = feedprogressback $ \feeder ->
|
||||
| Git.repoIsSsh (repo r) = feedprogressback $ \feeder ->
|
||||
rsyncHelper (Just feeder)
|
||||
=<< rsyncParamsRemote r True key dest file
|
||||
| Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest
|
||||
| Git.repoIsHttp (repo r) = Annex.Content.downloadUrl (keyUrls (repo r) key) dest
|
||||
| otherwise = error "copying from non-ssh, non-http repo not supported"
|
||||
where
|
||||
{- Feed local rsync's progress info back to the remote,
|
||||
|
@ -289,7 +294,7 @@ copyFromRemote r key file dest
|
|||
u <- getUUID
|
||||
let fields = (Fields.remoteUUID, fromUUID u)
|
||||
: maybe [] (\f -> [(Fields.associatedFile, f)]) file
|
||||
Just (cmd, params) <- git_annex_shell r "transferinfo"
|
||||
Just (cmd, params) <- git_annex_shell (repo r) "transferinfo"
|
||||
[Param $ key2file key] fields
|
||||
v <- liftIO $ newEmptySV
|
||||
tid <- liftIO $ forkIO $ void $ tryIO $ do
|
||||
|
@ -310,12 +315,12 @@ copyFromRemote r key file dest
|
|||
let feeder = writeSV v
|
||||
bracketIO noop (const $ tryIO $ killThread tid) (a feeder)
|
||||
|
||||
copyFromRemoteCheap :: Git.Repo -> Key -> FilePath -> Annex Bool
|
||||
copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool
|
||||
copyFromRemoteCheap r key file
|
||||
| not $ Git.repoIsUrl r = guardUsable r False $ do
|
||||
loc <- liftIO $ gitAnnexLocation key r
|
||||
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
|
||||
loc <- liftIO $ gitAnnexLocation key (repo r)
|
||||
liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
|
||||
| Git.repoIsSsh r =
|
||||
| Git.repoIsSsh (repo r) =
|
||||
ifM (Annex.Content.preseedTmp key file)
|
||||
( copyFromRemote r key Nothing file
|
||||
, return False
|
||||
|
@ -323,18 +328,20 @@ copyFromRemoteCheap r key file
|
|||
| otherwise = return False
|
||||
|
||||
{- Tries to copy a key's content to a remote's annex. -}
|
||||
copyToRemote :: Git.Repo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
||||
copyToRemote r key file p
|
||||
| not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ copylocal
|
||||
| Git.repoIsSsh r = commitOnCleanup r $ Annex.Content.sendAnnex key $ \object ->
|
||||
rsyncHelper (Just p) =<< rsyncParamsRemote r False key object file
|
||||
| not $ Git.repoIsUrl (repo r) =
|
||||
guardUsable (repo r) False $ commitOnCleanup r $ copylocal
|
||||
| Git.repoIsSsh (repo r) = commitOnCleanup r $
|
||||
Annex.Content.sendAnnex key $ \object ->
|
||||
rsyncHelper (Just p) =<< rsyncParamsRemote r False key object file
|
||||
| otherwise = error "copying to non-ssh repo not supported"
|
||||
where
|
||||
copylocal = Annex.Content.sendAnnex key $ \object -> do
|
||||
params <- rsyncParams r
|
||||
let params = rsyncParams r
|
||||
u <- getUUID
|
||||
-- run copy from perspective of remote
|
||||
liftIO $ onLocal r $ ifM (Annex.Content.inAnnex key)
|
||||
liftIO $ onLocal (repo r) $ ifM (Annex.Content.inAnnex key)
|
||||
( return False
|
||||
, do
|
||||
ensureInitialized
|
||||
|
@ -382,18 +389,18 @@ rsyncOrCopyFile rsyncparams src dest p =
|
|||
|
||||
{- Generates rsync parameters that ssh to the remote and asks it
|
||||
- to either receive or send the key's content. -}
|
||||
rsyncParamsRemote :: Git.Repo -> Bool -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
|
||||
rsyncParamsRemote :: Remote -> Bool -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
|
||||
rsyncParamsRemote r sending key file afile = do
|
||||
u <- getUUID
|
||||
let fields = (Fields.remoteUUID, fromUUID u)
|
||||
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
|
||||
Just (shellcmd, shellparams) <- git_annex_shell r
|
||||
Just (shellcmd, shellparams) <- git_annex_shell (repo r)
|
||||
(if sending then "sendkey" else "recvkey")
|
||||
[ Param $ key2file key ]
|
||||
fields
|
||||
-- Convert the ssh command into rsync command line.
|
||||
let eparam = rsyncShell (Param shellcmd:shellparams)
|
||||
o <- rsyncParams r
|
||||
let o = rsyncParams r
|
||||
if sending
|
||||
then return $ o ++ rsyncopts eparam dummy (File file)
|
||||
else return $ o ++ rsyncopts eparam (File file) dummy
|
||||
|
@ -410,25 +417,22 @@ rsyncParamsRemote r sending key file afile = do
|
|||
- even though this hostname will never be used. -}
|
||||
dummy = Param "dummy:"
|
||||
|
||||
rsyncParams :: Git.Repo -> Annex [CommandParam]
|
||||
rsyncParams r = do
|
||||
o <- getRemoteConfig r "rsync-options" ""
|
||||
return $ options ++ map Param (words o)
|
||||
where
|
||||
-- --inplace to resume partial files
|
||||
options = [Params "-p --progress --inplace"]
|
||||
-- --inplace to resume partial files
|
||||
rsyncParams :: Remote -> [CommandParam]
|
||||
rsyncParams r = [Params "-p --progress --inplace"] ++
|
||||
map Param (remoteAnnexRsyncOptions $ gitconfig r)
|
||||
|
||||
commitOnCleanup :: Git.Repo -> Annex a -> Annex a
|
||||
commitOnCleanup :: Remote -> Annex a -> Annex a
|
||||
commitOnCleanup r a = go `after` a
|
||||
where
|
||||
go = Annex.addCleanup (Git.repoLocation r) cleanup
|
||||
go = Annex.addCleanup (Git.repoLocation $ repo r) cleanup
|
||||
cleanup
|
||||
| not $ Git.repoIsUrl r = liftIO $ onLocal r $
|
||||
| not $ Git.repoIsUrl (repo r) = liftIO $ onLocal (repo r) $
|
||||
doQuietSideAction $
|
||||
Annex.Branch.commit "update"
|
||||
| otherwise = void $ do
|
||||
Just (shellcmd, shellparams) <-
|
||||
git_annex_shell r "commit" [] []
|
||||
git_annex_shell (repo r) "commit" [] []
|
||||
|
||||
-- Throw away stderr, since the remote may not
|
||||
-- have a new enough git-annex shell to
|
||||
|
|
|
@ -37,8 +37,8 @@ remote = RemoteType {
|
|||
setup = glacierSetup
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
||||
gen r u c = new <$> remoteCost r veryExpensiveRemoteCost
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
||||
gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
|
||||
where
|
||||
new cst = encryptableRemote c
|
||||
(storeEncrypted this)
|
||||
|
@ -58,6 +58,7 @@ gen r u c = new <$> remoteCost r veryExpensiveRemoteCost
|
|||
whereisKey = Nothing,
|
||||
config = c,
|
||||
repo = r,
|
||||
gitconfig = gc,
|
||||
localpath = Nothing,
|
||||
readonly = False,
|
||||
remotetype = remote
|
||||
|
|
|
@ -13,15 +13,16 @@ import Common.Annex
|
|||
import Types.Remote
|
||||
import qualified Annex
|
||||
import Annex.LockPool
|
||||
import Config
|
||||
import Annex.Perms
|
||||
|
||||
{- Modifies a remote's access functions to first run the
|
||||
- annex-start-command hook, and trigger annex-stop-command on shutdown.
|
||||
- This way, the hooks are only run when a remote is actively being used.
|
||||
-}
|
||||
addHooks :: Remote -> Annex Remote
|
||||
addHooks r = addHooks' r <$> lookupHook r "start" <*> lookupHook r "stop"
|
||||
addHooks :: Remote -> Remote
|
||||
addHooks r = addHooks' r
|
||||
(remoteAnnexStartCommand $ gitconfig r)
|
||||
(remoteAnnexStopCommand $ gitconfig r)
|
||||
addHooks' :: Remote -> Maybe String -> Maybe String -> Remote
|
||||
addHooks' r Nothing Nothing = r
|
||||
addHooks' r starthook stophook = r'
|
||||
|
@ -83,10 +84,3 @@ runHooks r starthook stophook a = do
|
|||
Left _ -> noop
|
||||
Right _ -> run stophook
|
||||
liftIO $ closeFd fd
|
||||
|
||||
lookupHook :: Remote -> String -> Annex (Maybe String)
|
||||
lookupHook r n = go =<< getRemoteConfig (repo r) hookname ""
|
||||
where
|
||||
go "" = return Nothing
|
||||
go command = return $ Just command
|
||||
hookname = n ++ "-command"
|
||||
|
|
|
@ -10,17 +10,19 @@ module Remote.Helper.Ssh where
|
|||
import Common.Annex
|
||||
import qualified Git
|
||||
import qualified Git.Url
|
||||
import Config
|
||||
import Annex.UUID
|
||||
import Annex.Ssh
|
||||
import Fields
|
||||
import Types.GitConfig
|
||||
|
||||
{- Generates parameters to ssh to a repository's host and run a command.
|
||||
- Caller is responsible for doing any neccessary shellEscaping of the
|
||||
- passed command. -}
|
||||
sshToRepo :: Git.Repo -> [CommandParam] -> Annex [CommandParam]
|
||||
sshToRepo repo sshcmd = do
|
||||
opts <- map Param . words <$> getRemoteConfig repo "ssh-options" ""
|
||||
g <- fromRepo id
|
||||
let c = extractRemoteGitConfig g (Git.repoDescribe repo)
|
||||
let opts = map Param $ remoteAnnexSshOptions c
|
||||
params <- sshParams (Git.Url.hostuser repo, Git.Url.port repo) opts
|
||||
return $ params ++ sshcmd
|
||||
|
||||
|
|
|
@ -29,10 +29,9 @@ remote = RemoteType {
|
|||
setup = hookSetup
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
||||
gen r u c = do
|
||||
hooktype <- getRemoteConfig r "hooktype" (error "missing hooktype")
|
||||
cst <- remoteCost r expensiveRemoteCost
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
||||
gen r u c gc = do
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
return $ encryptableRemote c
|
||||
(storeEncrypted hooktype)
|
||||
(retrieveEncrypted hooktype)
|
||||
|
@ -50,9 +49,12 @@ gen r u c = do
|
|||
config = M.empty,
|
||||
localpath = Nothing,
|
||||
repo = r,
|
||||
gitconfig = gc,
|
||||
readonly = False,
|
||||
remotetype = remote
|
||||
}
|
||||
where
|
||||
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
|
||||
|
||||
hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
hookSetup u c = do
|
||||
|
|
|
@ -15,8 +15,8 @@ import Common.Annex
|
|||
import qualified Annex
|
||||
import Logs.Remote
|
||||
import Types.Remote
|
||||
import Types.GitConfig
|
||||
import Annex.UUID
|
||||
import Config
|
||||
import Remote.Helper.Hooks
|
||||
import qualified Git
|
||||
import qualified Git.Config
|
||||
|
@ -81,7 +81,10 @@ remoteListRefresh = do
|
|||
remoteGen :: (M.Map UUID RemoteConfig) -> RemoteType -> Git.Repo -> Annex Remote
|
||||
remoteGen m t r = do
|
||||
u <- getRepoUUID r
|
||||
addHooks =<< generate t r u (fromMaybe M.empty $ M.lookup u m)
|
||||
g <- fromRepo id
|
||||
let gc = extractRemoteGitConfig g (Git.repoDescribe r)
|
||||
let c = fromMaybe M.empty $ M.lookup u m
|
||||
addHooks <$> generate t r u c gc
|
||||
|
||||
{- Updates a local git Remote, re-reading its git config. -}
|
||||
updateRemote :: Remote -> Annex Remote
|
||||
|
@ -97,7 +100,7 @@ updateRemote remote = do
|
|||
|
||||
{- All remotes that are not ignored. -}
|
||||
enabledRemoteList :: Annex [Remote]
|
||||
enabledRemoteList = filterM (repoNotIgnored . repo) =<< remoteList
|
||||
enabledRemoteList = filter (not . remoteAnnexIgnore . gitconfig) <$> remoteList
|
||||
|
||||
{- Checks if a remote is a special remote -}
|
||||
specialRemote :: Remote -> Bool
|
||||
|
|
|
@ -38,10 +38,9 @@ remote = RemoteType {
|
|||
setup = rsyncSetup
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
||||
gen r u c = do
|
||||
o <- genRsyncOpts r c
|
||||
cst <- remoteCost r expensiveRemoteCost
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
||||
gen r u c gc = do
|
||||
cst <- remoteCost gc expensiveRemoteCost
|
||||
return $ encryptableRemote c
|
||||
(storeEncrypted o)
|
||||
(retrieveEncrypted o)
|
||||
|
@ -58,27 +57,24 @@ gen r u c = do
|
|||
, whereisKey = Nothing
|
||||
, config = M.empty
|
||||
, repo = r
|
||||
, gitconfig = gc
|
||||
, localpath = if rsyncUrlIsPath $ rsyncUrl o
|
||||
then Just $ rsyncUrl o
|
||||
else Nothing
|
||||
, readonly = False
|
||||
, remotetype = remote
|
||||
}
|
||||
|
||||
genRsyncOpts :: Git.Repo -> RemoteConfig -> Annex RsyncOpts
|
||||
genRsyncOpts r c = do
|
||||
url <- getRemoteConfig r "rsyncurl" (error "missing rsyncurl")
|
||||
opts <- map Param . filter safe . words
|
||||
<$> getRemoteConfig r "rsync-options" ""
|
||||
let escape = M.lookup "shellescape" c /= Just "no"
|
||||
return $ RsyncOpts url opts escape
|
||||
where
|
||||
safe o
|
||||
o = RsyncOpts url opts escape
|
||||
url = fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc
|
||||
opts = map Param $ filter safe $ remoteAnnexRsyncOptions gc
|
||||
escape = M.lookup "shellescape" c /= Just "no"
|
||||
safe opt
|
||||
-- Don't allow user to pass --delete to rsync;
|
||||
-- that could cause it to delete other keys
|
||||
-- in the same hash bucket as a key it sends.
|
||||
| o == "--delete" = False
|
||||
| o == "--delete-excluded" = False
|
||||
| opt == "--delete" = False
|
||||
| opt == "--delete-excluded" = False
|
||||
| otherwise = True
|
||||
|
||||
rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
||||
|
|
|
@ -37,8 +37,8 @@ remote = RemoteType {
|
|||
setup = s3Setup
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
||||
gen r u c = new <$> remoteCost r expensiveRemoteCost
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
||||
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
||||
where
|
||||
new cst = encryptableRemote c
|
||||
(storeEncrypted this)
|
||||
|
@ -58,6 +58,7 @@ gen r u c = new <$> remoteCost r expensiveRemoteCost
|
|||
whereisKey = Nothing,
|
||||
config = c,
|
||||
repo = r,
|
||||
gitconfig = gc,
|
||||
localpath = Nothing,
|
||||
readonly = False,
|
||||
remotetype = remote
|
||||
|
|
|
@ -35,8 +35,8 @@ list = do
|
|||
r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown
|
||||
return [r]
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
||||
gen r _ _ =
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
||||
gen r _ _ gc =
|
||||
return Remote {
|
||||
uuid = webUUID,
|
||||
cost = expensiveRemoteCost,
|
||||
|
@ -49,6 +49,7 @@ gen r _ _ =
|
|||
hasKeyCheap = False,
|
||||
whereisKey = Just getUrls,
|
||||
config = M.empty,
|
||||
gitconfig = gc,
|
||||
localpath = Nothing,
|
||||
repo = r,
|
||||
readonly = True,
|
||||
|
|
|
@ -43,8 +43,8 @@ remote = RemoteType {
|
|||
setup = webdavSetup
|
||||
}
|
||||
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
||||
gen r u c = new <$> remoteCost r expensiveRemoteCost
|
||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
||||
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
||||
where
|
||||
new cst = encryptableRemote c
|
||||
(storeEncrypted this)
|
||||
|
@ -64,6 +64,7 @@ gen r u c = new <$> remoteCost r expensiveRemoteCost
|
|||
whereisKey = Nothing,
|
||||
config = c,
|
||||
repo = r,
|
||||
gitconfig = gc,
|
||||
localpath = Nothing,
|
||||
readonly = False,
|
||||
remotetype = remote
|
||||
|
|
5
Types.hs
5
Types.hs
|
@ -10,7 +10,8 @@ module Types (
|
|||
Backend,
|
||||
Key,
|
||||
UUID(..),
|
||||
Config(..),
|
||||
GitConfig(..),
|
||||
RemoteGitConfig(..),
|
||||
Remote,
|
||||
RemoteType,
|
||||
Option,
|
||||
|
@ -19,7 +20,7 @@ module Types (
|
|||
|
||||
import Annex
|
||||
import Types.Backend
|
||||
import Types.Config
|
||||
import Types.GitConfig
|
||||
import Types.Key
|
||||
import Types.UUID
|
||||
import Types.Remote
|
||||
|
|
|
@ -1,64 +0,0 @@
|
|||
{- git-annex configuration
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Types.Config (
|
||||
Config(..),
|
||||
extractConfig,
|
||||
) where
|
||||
|
||||
import Common
|
||||
import qualified Git
|
||||
import qualified Git.Config
|
||||
import Utility.DataUnits
|
||||
|
||||
{- Main git-annex settings. Each setting corresponds to a git-config key
|
||||
- such as annex.foo -}
|
||||
data Config = Config
|
||||
{ annexNumCopies :: Int
|
||||
, annexDiskReserve :: Integer
|
||||
, annexDirect :: Bool
|
||||
, annexBackends :: [String]
|
||||
, annexQueueSize :: Maybe Int
|
||||
, annexBloomCapacity :: Maybe Int
|
||||
, annexBloomAccuracy :: Maybe Int
|
||||
, annexSshCaching :: Maybe Bool
|
||||
, annexAlwaysCommit :: Bool
|
||||
, annexDelayAdd :: Maybe Int
|
||||
, annexHttpHeaders :: [String]
|
||||
, annexHttpHeadersCommand :: Maybe String
|
||||
}
|
||||
|
||||
extractConfig :: Git.Repo -> Config
|
||||
extractConfig r = Config
|
||||
{ annexNumCopies = get "numcopies" 1
|
||||
, annexDiskReserve = fromMaybe onemegabyte $
|
||||
readSize dataUnits =<< getmaybe "diskreserve"
|
||||
, annexDirect = getbool "direct" False
|
||||
, annexBackends = fromMaybe [] $
|
||||
words <$> getmaybe "backends"
|
||||
, annexQueueSize = getmayberead "queuesize"
|
||||
, annexBloomCapacity = getmayberead "bloomcapacity"
|
||||
, annexBloomAccuracy = getmayberead "bloomaccuracy"
|
||||
, annexSshCaching = getmaybebool "sshcaching"
|
||||
, annexAlwaysCommit = getbool "alwayscommit" True
|
||||
, annexDelayAdd = getmayberead "delayadd"
|
||||
, annexHttpHeaders = getlist "http-headers"
|
||||
, annexHttpHeadersCommand = getmaybe "http-headers-command"
|
||||
}
|
||||
where
|
||||
get k def = fromMaybe def $ getmayberead k
|
||||
getbool k def = fromMaybe def $ getmaybebool k
|
||||
getmaybebool k = Git.Config.isTrue =<< getmaybe k
|
||||
getmayberead k = readish =<< getmaybe k
|
||||
getmaybe k = Git.Config.getMaybe (key k) r
|
||||
getlist k = Git.Config.getList (key k) r
|
||||
key k = "annex." ++ k
|
||||
|
||||
onemegabyte = 1000000
|
||||
|
||||
{- Per-remote git-annex settings. Each setting corresponds to a git-config
|
||||
- key such as annex.<remote>.foo -}
|
122
Types/GitConfig.hs
Normal file
122
Types/GitConfig.hs
Normal file
|
@ -0,0 +1,122 @@
|
|||
{- git-annex configuration
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Types.GitConfig (
|
||||
GitConfig(..),
|
||||
extractGitConfig,
|
||||
RemoteGitConfig(..),
|
||||
extractRemoteGitConfig,
|
||||
) where
|
||||
|
||||
import Common
|
||||
import qualified Git
|
||||
import qualified Git.Config
|
||||
import Utility.DataUnits
|
||||
|
||||
{- Main git-annex settings. Each setting corresponds to a git-config key
|
||||
- such as annex.foo -}
|
||||
data GitConfig = GitConfig
|
||||
{ annexVersion :: Maybe String
|
||||
, annexNumCopies :: Int
|
||||
, annexDiskReserve :: Integer
|
||||
, annexDirect :: Bool
|
||||
, annexBackends :: [String]
|
||||
, annexQueueSize :: Maybe Int
|
||||
, annexBloomCapacity :: Maybe Int
|
||||
, annexBloomAccuracy :: Maybe Int
|
||||
, annexSshCaching :: Maybe Bool
|
||||
, annexAlwaysCommit :: Bool
|
||||
, annexDelayAdd :: Maybe Int
|
||||
, annexHttpHeaders :: [String]
|
||||
, annexHttpHeadersCommand :: Maybe String
|
||||
}
|
||||
|
||||
extractGitConfig :: Git.Repo -> GitConfig
|
||||
extractGitConfig r = GitConfig
|
||||
{ annexVersion = notempty $ getmaybe "version"
|
||||
, annexNumCopies = get "numcopies" 1
|
||||
, annexDiskReserve = fromMaybe onemegabyte $
|
||||
readSize dataUnits =<< getmaybe "diskreserve"
|
||||
, annexDirect = getbool "direct" False
|
||||
, annexBackends = fromMaybe [] $ words <$> getmaybe "backends"
|
||||
, annexQueueSize = getmayberead "queuesize"
|
||||
, annexBloomCapacity = getmayberead "bloomcapacity"
|
||||
, annexBloomAccuracy = getmayberead "bloomaccuracy"
|
||||
, annexSshCaching = getmaybebool "sshcaching"
|
||||
, annexAlwaysCommit = getbool "alwayscommit" True
|
||||
, annexDelayAdd = getmayberead "delayadd"
|
||||
, annexHttpHeaders = getlist "http-headers"
|
||||
, annexHttpHeadersCommand = getmaybe "http-headers-command"
|
||||
}
|
||||
where
|
||||
get k def = fromMaybe def $ getmayberead k
|
||||
getbool k def = fromMaybe def $ getmaybebool k
|
||||
getmaybebool k = Git.Config.isTrue =<< getmaybe k
|
||||
getmayberead k = readish =<< getmaybe k
|
||||
getmaybe k = Git.Config.getMaybe (key k) r
|
||||
getlist k = Git.Config.getList (key k) r
|
||||
|
||||
key k = "annex." ++ k
|
||||
|
||||
onemegabyte = 1000000
|
||||
|
||||
{- Per-remote git-annex settings. Each setting corresponds to a git-config
|
||||
- key such as <remote>.annex-foo, or if that is not set, a default from
|
||||
- annex.foo -}
|
||||
data RemoteGitConfig = RemoteGitConfig
|
||||
{ remoteAnnexCost :: Maybe Int
|
||||
, remoteAnnexCostCommand :: Maybe String
|
||||
, remoteAnnexIgnore :: Bool
|
||||
, remoteAnnexSync :: Bool
|
||||
, remoteAnnexTrustLevel :: Maybe String
|
||||
, remoteAnnexStartCommand :: Maybe String
|
||||
, remoteAnnexStopCommand :: Maybe String
|
||||
|
||||
-- these settings are specific to particular types of remotes
|
||||
, remoteAnnexSshOptions :: [String]
|
||||
, remoteAnnexRsyncOptions :: [String]
|
||||
, remoteAnnexRsyncUrl :: Maybe String
|
||||
, remoteAnnexBupRepo :: Maybe String
|
||||
, remoteAnnexBupSplitOptions :: [String]
|
||||
, remoteAnnexDirectory :: Maybe FilePath
|
||||
, remoteAnnexHookType :: Maybe String
|
||||
}
|
||||
|
||||
extractRemoteGitConfig :: Git.Repo -> String -> RemoteGitConfig
|
||||
extractRemoteGitConfig r remotename = RemoteGitConfig
|
||||
{ remoteAnnexCost = getmayberead "cost"
|
||||
, remoteAnnexCostCommand = notempty $ getmaybe "cost-command"
|
||||
, remoteAnnexIgnore = getbool "ignore" False
|
||||
, remoteAnnexSync = getbool "sync" True
|
||||
, remoteAnnexTrustLevel = notempty $ getmaybe "trustlevel"
|
||||
, remoteAnnexStartCommand = notempty $ getmaybe "start-command"
|
||||
, remoteAnnexStopCommand = notempty $ getmaybe "stop-command"
|
||||
|
||||
, remoteAnnexSshOptions = getoptions "ssh-options"
|
||||
, remoteAnnexRsyncOptions = getoptions "rsync-options"
|
||||
, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl"
|
||||
, remoteAnnexBupRepo = getmaybe "buprepo"
|
||||
, remoteAnnexBupSplitOptions = getoptions "bup-split-options"
|
||||
, remoteAnnexDirectory = notempty $ getmaybe "directory"
|
||||
, remoteAnnexHookType = notempty $ getmaybe "hooktype"
|
||||
}
|
||||
where
|
||||
getbool k def = fromMaybe def $ getmaybebool k
|
||||
getmaybebool k = Git.Config.isTrue =<< getmaybe k
|
||||
getmayberead k = readish =<< getmaybe k
|
||||
getmaybe k = maybe (Git.Config.getMaybe (key k) r) Just $
|
||||
Git.Config.getMaybe (remotekey k) r
|
||||
getoptions k = fromMaybe [] $ words <$> getmaybe k
|
||||
|
||||
key k = "annex." ++ k
|
||||
remotekey k = "remote." ++ remotename ++ ".annex-" ++ k
|
||||
|
||||
notempty :: Maybe String -> Maybe String
|
||||
notempty Nothing = Nothing
|
||||
notempty (Just "") = Nothing
|
||||
notempty (Just s) = Just s
|
||||
|
|
@ -16,6 +16,7 @@ import qualified Git
|
|||
import Types.Key
|
||||
import Types.UUID
|
||||
import Types.Meters
|
||||
import Types.GitConfig
|
||||
|
||||
type RemoteConfigKey = String
|
||||
type RemoteConfig = M.Map RemoteConfigKey String
|
||||
|
@ -27,7 +28,7 @@ data RemoteTypeA a = RemoteType {
|
|||
-- enumerates remotes of this type
|
||||
enumerate :: a [Git.Repo],
|
||||
-- generates a remote of this type
|
||||
generate :: Git.Repo -> UUID -> RemoteConfig -> a (RemoteA a),
|
||||
generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (RemoteA a),
|
||||
-- initializes or changes a remote
|
||||
setup :: UUID -> RemoteConfig -> a RemoteConfig
|
||||
}
|
||||
|
@ -64,8 +65,10 @@ data RemoteA a = Remote {
|
|||
whereisKey :: Maybe (Key -> a [String]),
|
||||
-- a Remote has a persistent configuration store
|
||||
config :: RemoteConfig,
|
||||
-- git configuration for the remote
|
||||
-- git repo for the Remote
|
||||
repo :: Git.Repo,
|
||||
-- a Remote's configuration from git
|
||||
gitconfig :: RemoteGitConfig,
|
||||
-- a Remote can be assocated with a specific local filesystem path
|
||||
localpath :: Maybe FilePath,
|
||||
-- a Remote can be known to be readonly
|
||||
|
|
Loading…
Reference in a new issue