From 18a3a186e9cdb69ee503d961d8285a341d818c48 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 1 Jan 2013 13:52:47 -0400 Subject: 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. --- Annex.hs | 26 ++++----- Annex/Content.hs | 4 +- Annex/Queue.hs | 2 +- Annex/Ssh.hs | 2 +- Annex/Version.hs | 6 +- Assistant/DaemonStatus.hs | 3 +- Assistant/Threads/Committer.hs | 2 +- Backend.hs | 2 +- Command/Status.hs | 2 +- Command/Sync.hs | 4 +- Command/Unused.hs | 4 +- Config.hs | 55 ++++++------------ GitAnnex.hs | 2 +- Logs/Trust.hs | 9 ++- Remote.hs | 16 ++---- Remote/Bup.hs | 63 +++++++++++---------- Remote/Directory.hs | 10 ++-- Remote/Git.hs | 124 +++++++++++++++++++++-------------------- Remote/Glacier.hs | 5 +- Remote/Helper/Hooks.hs | 14 ++--- Remote/Helper/Ssh.hs | 6 +- Remote/Hook.hs | 10 ++-- Remote/List.hs | 9 ++- Remote/Rsync.hs | 26 ++++----- Remote/S3.hs | 5 +- Remote/Web.hs | 5 +- Remote/WebDAV.hs | 5 +- Types.hs | 5 +- Types/Config.hs | 64 --------------------- Types/GitConfig.hs | 122 ++++++++++++++++++++++++++++++++++++++++ Types/Remote.hs | 7 ++- 31 files changed, 331 insertions(+), 288 deletions(-) delete mode 100644 Types/Config.hs create mode 100644 Types/GitConfig.hs diff --git a/Annex.hs b/Annex.hs index bb3548b00..f253c48f5 100644 --- a/Annex.hs +++ b/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 } diff --git a/Annex/Content.hs b/Annex/Content.hs index 1f7516fe1..4c6802bf8 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -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. -} diff --git a/Annex/Queue.hs b/Annex/Queue.hs index 0f8c38ab9..a5ef60037 100644 --- a/Annex/Queue.hs +++ b/Annex/Queue.hs @@ -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 diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index d3622686c..b6811858f 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -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] diff --git a/Annex/Version.hs b/Annex/Version.hs index 30ad957c3..6149e6fb7 100644 --- a/Annex/Version.hs +++ b/Annex/Version.hs @@ -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 diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index cb9133b2a..28383a4dd 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -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 diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 7940b0836..6e5412e00 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -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 diff --git a/Backend.hs b/Backend.hs index 4972288c3..9c08e1437 100644 --- a/Backend.hs +++ b/Backend.hs @@ -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 diff --git a/Command/Status.hs b/Command/Status.hs index 9c5e3e70a..89ba55cfa 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -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 diff --git a/Command/Sync.hs b/Command/Sync.hs index f7241ce82..61ac3802a 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -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 diff --git a/Command/Unused.hs b/Command/Unused.hs index 2823ccefd..5f8af2185 100644 --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -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 diff --git a/Config.hs b/Config.hs index afda3e7cb..f2f12a266 100644 --- a/Config.hs +++ b/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..annex-cost, or if remote..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 diff --git a/GitAnnex.hs b/GitAnnex.hs index c807326ad..8b8b4ad1b 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -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) diff --git a/Logs/Trust.hs b/Logs/Trust.hs index 8f568eba7..058250740 100644 --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -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. -} diff --git a/Remote.hs b/Remote.hs index c4291a997..8b1d7cd61 100644 --- a/Remote.hs +++ b/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. -} diff --git a/Remote/Bup.hs b/Remote/Bup.hs index e14185017..2f71e516d 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -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 [] diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 946df6111..12875770f 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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 diff --git a/Remote/Git.hs b/Remote/Git.hs index db73247a1..9b0617652 100644 --- a/Remote/Git.hs +++ b/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 diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 05cdf8978..04b70e2f1 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -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 diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index 91190d841..bdeb653eb 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -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" diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index b6da80ec6..135b5c144 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -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 diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 8f9aaafd6..c9edda133 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -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 diff --git a/Remote/List.hs b/Remote/List.hs index 4622f1e99..1cfbab872 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -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 diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 4c61d8e62..b05753830 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -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 diff --git a/Remote/S3.hs b/Remote/S3.hs index 345d93872..0c0737841 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -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 diff --git a/Remote/Web.hs b/Remote/Web.hs index f1eee7feb..f984137a9 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -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, diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 70faa7539..752e0d7ff 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -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 diff --git a/Types.hs b/Types.hs index 16f901b26..d19ac3de1 100644 --- a/Types.hs +++ b/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 diff --git a/Types/Config.hs b/Types/Config.hs deleted file mode 100644 index 898c153d5..000000000 --- a/Types/Config.hs +++ /dev/null @@ -1,64 +0,0 @@ -{- git-annex configuration - - - - Copyright 2012 Joey Hess - - - - 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..foo -} diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs new file mode 100644 index 000000000..f93ef1529 --- /dev/null +++ b/Types/GitConfig.hs @@ -0,0 +1,122 @@ +{- git-annex configuration + - + - Copyright 2012 Joey Hess + - + - 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 .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 + diff --git a/Types/Remote.hs b/Types/Remote.hs index f01ae01f6..05763e4d3 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -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 -- cgit v1.2.3