move some stuff out of IO

This commit is contained in:
Joey Hess 2010-10-13 14:51:09 -04:00
parent 771a6b36e1
commit 77055f5ff8
2 changed files with 22 additions and 21 deletions

View file

@ -9,7 +9,7 @@ module Annex (
annexWantFile, annexWantFile,
annexDropFile, annexDropFile,
annexPushRepo, annexPushRepo,
repoCost, annexRemotes,
annexPullRepo annexPullRepo
) where ) where
@ -31,8 +31,9 @@ import Types
startAnnex :: IO State startAnnex :: IO State
startAnnex = do startAnnex = do
r <- gitRepoFromCwd r <- gitRepoFromCwd
r' <- prepUUID r r' <- gitConfigRead r
gitSetup r' r'' <- prepUUID r'
gitSetup r''
return State { return State {
repo = r', repo = r',
@ -168,6 +169,10 @@ logStatus state key status = do
inAnnex :: State -> Backend -> Key -> IO Bool inAnnex :: State -> Backend -> Key -> IO Bool
inAnnex state backend key = doesFileExist $ annexLocation state backend key inAnnex state backend key = doesFileExist $ annexLocation state backend key
{- Ordered list of remotes for the annex. -}
annexRemotes :: State -> [GitRepo]
annexRemotes state = reposByCost state $ gitConfigRemotes (repo state)
{- Orders a list of git repos by cost. -} {- Orders a list of git repos by cost. -}
reposByCost :: State -> [GitRepo] -> [GitRepo] reposByCost :: State -> [GitRepo] -> [GitRepo]
reposByCost state l = reposByCost state l =

View file

@ -54,22 +54,19 @@ data GitRepo =
remoteName :: Maybe String remoteName :: Maybe String
} deriving (Show, Read, Eq) } deriving (Show, Read, Eq)
{- Local GitRepo constructor. Can optionally query the repo for its config. -} {- Local GitRepo constructor. -}
gitRepoFromPath :: FilePath -> Bool -> IO GitRepo gitRepoFromPath :: FilePath -> GitRepo
gitRepoFromPath dir query = do gitRepoFromPath dir =
let r = LocalGitRepo { LocalGitRepo {
top = dir, top = dir,
config = Map.empty, config = Map.empty,
remoteName = Nothing remoteName = Nothing
} }
if (query)
then gitConfigRead r
else return r
{- Remote GitRepo constructor. Throws exception on invalid url. -} {- Remote GitRepo constructor. Throws exception on invalid url. -}
gitRepoFromUrl :: String -> Bool -> IO GitRepo gitRepoFromUrl :: String -> GitRepo
gitRepoFromUrl url query = do gitRepoFromUrl url =
return $ RemoteGitRepo { RemoteGitRepo {
url = url, url = url,
top = path url, top = path url,
config = Map.empty, config = Map.empty,
@ -187,18 +184,17 @@ gitConfig repo key defaultValue =
Map.findWithDefault defaultValue key (config repo) Map.findWithDefault defaultValue key (config repo)
{- Returns a list of a repo's configured remotes. -} {- Returns a list of a repo's configured remotes. -}
gitConfigRemotes :: GitRepo -> IO [GitRepo] gitConfigRemotes :: GitRepo -> [GitRepo]
gitConfigRemotes repo = mapM construct remotes gitConfigRemotes repo = map construct remotes
where where
remotes = toList $ filter $ config repo remotes = toList $ filter $ config repo
filter = filterWithKey (\k _ -> isremote k) filter = filterWithKey (\k _ -> isremote k)
isremote k = (startswith "remote." k) && (endswith ".url" k) isremote k = (startswith "remote." k) && (endswith ".url" k)
remotename k = (split "." k) !! 1 remotename k = (split "." k) !! 1
construct (k,v) = do construct (k,v) = (gen v) { remoteName = Just $ remotename k }
r <- if (isURI v) gen v = if (isURI v)
then gitRepoFromUrl v False then gitRepoFromUrl v
else gitRepoFromPath v False else gitRepoFromPath v
return r { remoteName = Just $ remotename k }
{- Finds the current git repository, which may be in a parent directory. -} {- Finds the current git repository, which may be in a parent directory. -}
gitRepoFromCwd :: IO GitRepo gitRepoFromCwd :: IO GitRepo
@ -206,7 +202,7 @@ gitRepoFromCwd = do
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
top <- seekUp cwd isRepoTop top <- seekUp cwd isRepoTop
case top of case top of
(Just dir) -> gitRepoFromPath dir True (Just dir) -> return $ gitRepoFromPath dir
Nothing -> error "Not in a git repository." Nothing -> error "Not in a git repository."
seekUp :: String -> (String -> IO Bool) -> IO (Maybe String) seekUp :: String -> (String -> IO Bool) -> IO (Maybe String)