some reorg and further remote generalization

Annex.hs

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

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

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

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

Remote.hs

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

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

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,

Ssh.hs

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

UUID.hs

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

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