diff options
| -rw-r--r-- | Annex.hs | 23 | ||||
| -rw-r--r-- | Config.hs | 68 | ||||
| -rw-r--r-- | Content.hs | 3 | ||||
| -rw-r--r-- | GitRepo.hs | 30 | ||||
| -rw-r--r-- | Remote.hs | 24 | ||||
| -rw-r--r-- | Remote/Git.hs | 106 | ||||
| -rw-r--r-- | RemoteClass.hs | 5 | ||||
| -rw-r--r-- | Ssh.hs | 4 | ||||
| -rw-r--r-- | UUID.hs | 5 | ||||
| -rw-r--r-- | Version.hs | 3 |
10 files changed, 154 insertions, 117 deletions
@@ -17,12 +17,9 @@ module Annex ( queue, queueRun, queueRunAt, - setConfig, - repoConfig ) where import Control.Monad.State -import Data.Maybe import qualified GitRepo as Git import qualified GitQueue @@ -119,23 +116,3 @@ queueRunAt n = do state <- get let q = repoqueue state when (GitQueue.size q >= n) queueRun - -{- Changes a git config setting in both internal state and .git/config -} -setConfig :: String -> String -> Annex () -setConfig k value = do - g <- Annex.gitRepo - liftIO $ Git.run g "config" [Param k, Param value] - -- re-read git config and update the repo's state - g' <- liftIO $ Git.configRead g - Annex.changeState $ \s -> s { Annex.repo = g' } - -{- Looks up a per-remote config option in git config. - - Failing that, tries looking for a global config option. -} -repoConfig :: Git.Repo -> String -> String -> Annex String -repoConfig r key def = do - g <- Annex.gitRepo - let def' = Git.configGet g global def - return $ Git.configGet g local def' - where - local = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key - global = "annex." ++ key diff --git a/Config.hs b/Config.hs new file mode 100644 index 000000000..aae7d8291 --- /dev/null +++ b/Config.hs @@ -0,0 +1,68 @@ +{- Git configuration + - + - Copyright 2011 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Config where + +import Data.Maybe +import Control.Monad.State (liftIO) + +import qualified GitRepo as Git +import qualified Annex +import Types +import Utility + +type ConfigKey = String + +{- Changes a git config setting in both internal state and .git/config -} +setConfig :: ConfigKey -> String -> Annex () +setConfig k value = do + g <- Annex.gitRepo + liftIO $ Git.run g "config" [Param k, Param value] + -- re-read git config and update the repo's state + g' <- liftIO $ Git.configRead g + Annex.changeState $ \s -> s { Annex.repo = g' } + +{- Looks up a per-remote config setting in git config. + - Failing that, tries looking for a global config option. -} +getConfig :: Git.Repo -> ConfigKey -> String -> Annex String +getConfig r key def = do + g <- Annex.gitRepo + let def' = Git.configGet g global def + return $ Git.configGet g local def' + where + local = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key + global = "annex." ++ key + +{- Calculates cost for a remote. + - + - The default cost is 100 for local repositories, and 200 for remote + - repositories; it can also be configured by remote.<name>.annex-cost + -} +remoteCost :: Git.Repo -> Annex Int +remoteCost r = do + c <- getConfig r "cost" "" + if not $ null c + then return $ read c + else if not $ Git.repoIsUrl r + then return 100 + else return 200 + +{- Checks if a repo should be ignored, based either on annex-ignore + - setting, or on command-line options. Allows command-line to override + - annex-ignore. -} +remoteNotIgnored :: Git.Repo -> Annex Bool +remoteNotIgnored r = do + ignored <- getConfig r "ignore" "false" + to <- match Annex.toremote + from <- match Annex.fromremote + if to || from + then return True + else return $ not $ Git.configTrue ignored + where + match a = do + n <- Annex.getState a + return $ n == Git.repoRemoteName r diff --git a/Content.hs b/Content.hs index 7aa30f7ff..88e8dbc00 100644 --- a/Content.hs +++ b/Content.hs @@ -40,6 +40,7 @@ import Utility import StatFS import Key import DataUnits +import Config {- Checks if a given key is currently present in the gitAnnexLocation. -} inAnnex :: Key -> Annex Bool @@ -121,7 +122,7 @@ checkDiskSpace = checkDiskSpace' 0 checkDiskSpace' :: Integer -> Key -> Annex () checkDiskSpace' adjustment key = do g <- Annex.gitRepo - r <- Annex.repoConfig g "diskreserve" "" + r <- getConfig g "diskreserve" "" let reserve = case readSize dataUnits r of Nothing -> megabyte Just v -> v diff --git a/GitRepo.hs b/GitRepo.hs index ad58b28a0..1b14e4a63 100644 --- a/GitRepo.hs +++ b/GitRepo.hs @@ -12,6 +12,7 @@ module GitRepo ( Repo, repoFromCwd, repoFromAbsPath, + repoFromUnknown, repoFromUrl, localToUrl, repoIsUrl, @@ -41,6 +42,7 @@ module GitRepo ( remotes, remotesAdd, repoRemoteName, + repoRemoteNameSet, inRepo, notInRepo, stagedFiles, @@ -81,7 +83,7 @@ import Utility {- There are two types of repositories; those on local disk and those - accessed via an URL. -} -data RepoLocation = Dir FilePath | Url URI +data RepoLocation = Dir FilePath | Url URI | Unknown deriving (Show, Eq) data Repo = Repo { @@ -123,6 +125,10 @@ repoFromUrl url Just v -> v Nothing -> error $ "bad url " ++ url +{- Creates a repo that has an unknown location. -} +repoFromUnknown :: Repo +repoFromUnknown = newFrom Unknown + {- Converts a Local Repo into a remote repo, using the reference repo - which is assumed to be on the same host. -} localToUrl :: Repo -> Repo -> Repo @@ -141,11 +147,13 @@ repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url repoDescribe Repo { location = Dir dir } = dir +repoDescribe Repo { location = Unknown } = "UNKNOWN" {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url repoLocation Repo { location = Dir dir } = dir +repoLocation Repo { location = Unknown } = undefined {- Constructs and returns an updated version of a repo with - different remotes list. -} @@ -158,6 +166,14 @@ repoRemoteName :: Repo -> Maybe String repoRemoteName Repo { remoteName = Just name } = Just name repoRemoteName _ = Nothing +{- Sets the name of a remote based on the git config key, such as + "remote.foo.url". -} +repoRemoteNameSet :: Repo -> String -> Repo +repoRemoteNameSet r k = r { remoteName = Just basename } + where + basename = join "." $ reverse $ drop 1 $ + reverse $ drop 1 $ split "." k + {- Some code needs to vary between URL and normal repos, - or bare and non-bare, these functions help with that. -} repoIsUrl :: Repo -> Bool @@ -218,6 +234,7 @@ gitDir repo workTree :: Repo -> FilePath workTree r@(Repo { location = Url _ }) = urlPath r workTree (Repo { location = Dir d }) = d +workTree Repo { location = Unknown } = undefined {- Given a relative or absolute filename in a repository, calculates the - name to use to refer to the file relative to a git repository's top. @@ -393,10 +410,6 @@ configStore repo s = do where r = repo { config = configParse s } -{- Checks if a string from git config is a true value. -} -configTrue :: String -> Bool -configTrue s = map toLower s == "true" - {- Calculates a list of a repo's configured remotes, by parsing its config. -} configRemotes :: Repo -> IO [Repo] configRemotes repo = mapM construct remotepairs @@ -404,10 +417,9 @@ configRemotes repo = mapM construct remotepairs remotepairs = Map.toList $ filterremotes $ config repo filterremotes = Map.filterWithKey (\k _ -> isremote k) isremote k = startswith "remote." k && endswith ".url" k - remotename k = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k construct (k,v) = do r <- gen v - return $ r { remoteName = Just $ remotename k } + return $ repoRemoteNameSet r k gen v | scpstyle v = repoFromUrl $ scptourl v | isURI v = repoFromUrl v | otherwise = repoFromRemotePath v repo @@ -423,6 +435,10 @@ configRemotes repo = mapM construct remotepairs | d !! 0 == '~' = '/':dir | otherwise = "/~/" ++ dir +{- Checks if a string from git config is a true value. -} +configTrue :: String -> Bool +configTrue s = map toLower s == "true" + {- Parses git config --list output into a config map. -} configParse :: String -> Map.Map String String configParse s = Map.fromList $ map pair $ lines s @@ -25,20 +25,35 @@ module Remote ( import Control.Monad.State (liftIO) import Control.Monad (when, liftM) import Data.List +import Data.String.Utils import RemoteClass import qualified Remote.Git -import qualified Remote.S3 +--import qualified Remote.S3 import Types import UUID import qualified Annex import Trust import LocationLog +import Messages -{- add generators for new Remotes here -} -generators :: [Annex [Remote Annex]] +{- Add generators for new Remotes here. -} +generators :: [Annex (RemoteGenerator Annex)] generators = [Remote.Git.generate] +{- Runs a list of generators. -} +runGenerators :: [Annex (RemoteGenerator Annex)] -> Annex [Remote Annex] +runGenerators gs = do + (actions, expensive) <- collect ([], []) gs + when (not $ null expensive) $ + showNote $ "getting UUID for " ++ join ", " expensive + sequence actions + where + collect v [] = return v + collect (actions, expensive) (x:xs) = do + (a, e) <- x + collect (a++actions, e++expensive) xs + {- Builds a list of all available Remotes. - Since doing so can be expensive, the list is cached in the Annex. -} genList :: Annex [Remote Annex] @@ -46,8 +61,7 @@ genList = do rs <- Annex.getState Annex.remotes if null rs then do - lists <- sequence generators - let rs' = concat lists + rs' <- runGenerators generators Annex.changeState $ \s -> s { Annex.remotes = rs' } return rs' else return rs diff --git a/Remote/Git.hs b/Remote/Git.hs index 43e75b97b..9021a2230 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Remote.GitRemote ( +module Remote.Git ( generate, onRemote ) where @@ -13,9 +13,8 @@ module Remote.GitRemote ( import Control.Exception.Extensible import Control.Monad.State (liftIO) import qualified Data.Map as Map -import Data.String.Utils import System.Cmd.Utils -import Control.Monad (unless, filterM) +import Control.Monad (filterM, liftM) import RemoteClass import Types @@ -29,18 +28,34 @@ import Messages import CopyFile import RsyncFile import Ssh +import Config -generate :: Annex [Remote Annex] +generate :: Annex (RemoteGenerator Annex) generate = do - readConfigs g <- Annex.gitRepo - rs <- filterM repoNotIgnored (Git.remotes g) - mapM genRemote rs + allremotes <- filterM remoteNotIgnored $ Git.remotes g + + {- It's assumed to be cheap to read the config of non-URL remotes, + - so this is done each time git-annex is run. Conversely, + - the config of an URL remote is only read when there is no + - cached UUID value. -} + let cheap = filter (not . Git.repoIsUrl) allremotes + let expensive = filter Git.repoIsUrl allremotes + expensive_todo <- filterM cachedUUID expensive + let skip = filter (`notElem` expensive_todo) expensive + let todo = cheap++expensive_todo + + let actions = map genRemote skip ++ + map (\r -> genRemote =<< tryGitConfigRead r) todo + return (actions, map Git.repoDescribe expensive_todo) + + where + cachedUUID r = liftM null $ getUUID r genRemote :: Git.Repo -> Annex (Remote Annex) genRemote r = do u <- getUUID r - c <- repoCost r + c <- remoteCost r return Remote { uuid = u, cost = c, @@ -52,40 +67,13 @@ genRemote r = do hasKeyCheap = not (Git.repoIsUrl r) } -{- Reads the configs of git remotes. - - - - It's assumed to be cheap to read the config of non-URL remotes, - - so this is done each time git-annex is run. Conversely, - - the config of an URL remote is only read when there is no - - cached UUID value. - -} -readConfigs :: Annex () -readConfigs = do - g <- Annex.gitRepo - allremotes <- filterM repoNotIgnored $ Git.remotes g - let cheap = filter (not . Git.repoIsUrl) allremotes - let expensive = filter Git.repoIsUrl allremotes - doexpensive <- filterM cachedUUID expensive - unless (null doexpensive) $ - showNote $ "getting UUID for " ++ - list doexpensive ++ "..." - let todo = cheap ++ doexpensive - unless (null todo) $ do - mapM_ tryGitConfigRead todo - where - cachedUUID r = do - u <- getUUID r - return $ null u - -{- The git configs for the git repo's remotes is not read on startup - - because reading it may be expensive. This function tries to read the - - config for a specified remote, and updates state. If successful, it - - returns the updated git repo. -} -tryGitConfigRead :: Git.Repo -> Annex (Either Git.Repo Git.Repo) +{- Tries to read the config for a specified remote, updates state, and + - returns the updated repo. -} +tryGitConfigRead :: Git.Repo -> Annex Git.Repo tryGitConfigRead r - | not $ Map.null $ Git.configMap r = return $ Right r -- already read + | not $ Map.null $ Git.configMap r = return r -- already read | Git.repoIsSsh r = store $ onRemote r (pipedconfig, r) "configlist" [] - | Git.repoIsUrl r = return $ Left r + | Git.repoIsUrl r = return r | otherwise = store $ safely $ Git.configRead r where -- Reading config can fail due to IO error or @@ -104,43 +92,13 @@ tryGitConfigRead r let l = Git.remotes g let g' = Git.remotesAdd g $ exchange l r' Annex.changeState $ \s -> s { Annex.repo = g' } - return $ Right r' + return r' exchange [] _ = [] exchange (old:ls) new = if Git.repoRemoteName old == Git.repoRemoteName new then new : exchange ls new else old : exchange ls new -{- Calculates cost for a repo. - - - - The default cost is 100 for local repositories, and 200 for remote - - repositories; it can also be configured by remote.<name>.annex-cost - -} -repoCost :: Git.Repo -> Annex Int -repoCost r = do - c <- Annex.repoConfig r "cost" "" - if not $ null c - then return $ read c - else if Git.repoIsUrl r - then return 200 - else return 100 - -{- Checks if a repo should be ignored, based either on annex-ignore - - setting, or on command-line options. Allows command-line to override - - annex-ignore. -} -repoNotIgnored :: Git.Repo -> Annex Bool -repoNotIgnored r = do - ignored <- Annex.repoConfig r "ignore" "false" - to <- match Annex.toremote - from <- match Annex.fromremote - if to || from - then return True - else return $ not $ Git.configTrue ignored - where - match a = do - n <- Annex.getState a - return $ n == Git.repoRemoteName r - {- Checks if a given remote has the content for a key inAnnex. - If the remote cannot be accessed, returns a Left error. -} @@ -219,7 +177,7 @@ rsyncParams r sending key file = do ] -- Convert the ssh command into rsync command line. let eparam = rsyncShell (Param shellcmd:shellparams) - o <- Annex.repoConfig r "rsync-options" "" + o <- getConfig r "rsync-options" "" let base = options ++ map Param (words o) ++ eparam if sending then return $ base ++ [dummy, File file] @@ -262,7 +220,3 @@ git_annex_shell r command params shellopts = (Param command):(File dir):params sshcmd = shellcmd ++ " " ++ unwords (map shellEscape $ toCommand shellopts) - -{- Human visible list of remotes. -} -list :: [Git.Repo] -> String -list remotes = join ", " $ map Git.repoDescribe remotes diff --git a/RemoteClass.hs b/RemoteClass.hs index 38e8407a5..eb4a01748 100644 --- a/RemoteClass.hs +++ b/RemoteClass.hs @@ -13,6 +13,11 @@ import Control.Exception import Key +{- A remote generator identifies configured remotes, and returns an action + - that can be run to set up each remote, and a list of names of remotes + - that are not cheap to set up. -} +type RemoteGenerator a = ([a (Remote a)], [String]) + data Remote a = Remote { -- each Remote has a unique uuid uuid :: String, @@ -7,17 +7,17 @@ module Ssh where -import qualified Annex import qualified GitRepo as Git import Utility import Types +import Config {- 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 - s <- Annex.repoConfig repo "ssh-options" "" + s <- getConfig repo "ssh-options" "" let sshoptions = map Param (words s) let sshport = case Git.urlPort repo of Nothing -> [] @@ -35,6 +35,7 @@ import Locations import qualified Annex import Utility import qualified SysConfig +import Config type UUID = String @@ -69,7 +70,7 @@ getUUID r = do else return c where cached g = Git.configGet g cachekey "" - updatecache g u = when (g /= r) $ Annex.setConfig cachekey u + updatecache g u = when (g /= r) $ setConfig cachekey u cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid" getUncachedUUID :: Git.Repo -> UUID @@ -82,7 +83,7 @@ prepUUID = do u <- getUUID g when ("" == u) $ do uuid <- liftIO $ genUUID - Annex.setConfig configkey uuid + setConfig configkey uuid {- Pretty-prints a list of UUIDs -} prettyPrintUUIDs :: [UUID] -> Annex String diff --git a/Version.hs b/Version.hs index d061a2eab..947af8cef 100644 --- a/Version.hs +++ b/Version.hs @@ -15,6 +15,7 @@ import Types import qualified Annex import qualified GitRepo as Git import Locations +import Config type Version = String @@ -54,7 +55,7 @@ getVersion = do return defaultVersion setVersion :: Annex () -setVersion = Annex.setConfig versionField defaultVersion +setVersion = setConfig versionField defaultVersion checkVersion :: Annex () checkVersion = do |