move some stuff out of IO
This commit is contained in:
parent
771a6b36e1
commit
77055f5ff8
2 changed files with 22 additions and 21 deletions
11
Annex.hs
11
Annex.hs
|
@ -9,7 +9,7 @@ module Annex (
|
|||
annexWantFile,
|
||||
annexDropFile,
|
||||
annexPushRepo,
|
||||
repoCost,
|
||||
annexRemotes,
|
||||
annexPullRepo
|
||||
) where
|
||||
|
||||
|
@ -31,8 +31,9 @@ import Types
|
|||
startAnnex :: IO State
|
||||
startAnnex = do
|
||||
r <- gitRepoFromCwd
|
||||
r' <- prepUUID r
|
||||
gitSetup r'
|
||||
r' <- gitConfigRead r
|
||||
r'' <- prepUUID r'
|
||||
gitSetup r''
|
||||
|
||||
return State {
|
||||
repo = r',
|
||||
|
@ -168,6 +169,10 @@ logStatus state key status = do
|
|||
inAnnex :: State -> Backend -> Key -> IO Bool
|
||||
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. -}
|
||||
reposByCost :: State -> [GitRepo] -> [GitRepo]
|
||||
reposByCost state l =
|
||||
|
|
32
GitRepo.hs
32
GitRepo.hs
|
@ -54,22 +54,19 @@ data GitRepo =
|
|||
remoteName :: Maybe String
|
||||
} deriving (Show, Read, Eq)
|
||||
|
||||
{- Local GitRepo constructor. Can optionally query the repo for its config. -}
|
||||
gitRepoFromPath :: FilePath -> Bool -> IO GitRepo
|
||||
gitRepoFromPath dir query = do
|
||||
let r = LocalGitRepo {
|
||||
{- Local GitRepo constructor. -}
|
||||
gitRepoFromPath :: FilePath -> GitRepo
|
||||
gitRepoFromPath dir =
|
||||
LocalGitRepo {
|
||||
top = dir,
|
||||
config = Map.empty,
|
||||
remoteName = Nothing
|
||||
}
|
||||
if (query)
|
||||
then gitConfigRead r
|
||||
else return r
|
||||
|
||||
{- Remote GitRepo constructor. Throws exception on invalid url. -}
|
||||
gitRepoFromUrl :: String -> Bool -> IO GitRepo
|
||||
gitRepoFromUrl url query = do
|
||||
return $ RemoteGitRepo {
|
||||
gitRepoFromUrl :: String -> GitRepo
|
||||
gitRepoFromUrl url =
|
||||
RemoteGitRepo {
|
||||
url = url,
|
||||
top = path url,
|
||||
config = Map.empty,
|
||||
|
@ -187,18 +184,17 @@ gitConfig repo key defaultValue =
|
|||
Map.findWithDefault defaultValue key (config repo)
|
||||
|
||||
{- Returns a list of a repo's configured remotes. -}
|
||||
gitConfigRemotes :: GitRepo -> IO [GitRepo]
|
||||
gitConfigRemotes repo = mapM construct remotes
|
||||
gitConfigRemotes :: GitRepo -> [GitRepo]
|
||||
gitConfigRemotes repo = map construct remotes
|
||||
where
|
||||
remotes = toList $ filter $ config repo
|
||||
filter = filterWithKey (\k _ -> isremote k)
|
||||
isremote k = (startswith "remote." k) && (endswith ".url" k)
|
||||
remotename k = (split "." k) !! 1
|
||||
construct (k,v) = do
|
||||
r <- if (isURI v)
|
||||
then gitRepoFromUrl v False
|
||||
else gitRepoFromPath v False
|
||||
return r { remoteName = Just $ remotename k }
|
||||
construct (k,v) = (gen v) { remoteName = Just $ remotename k }
|
||||
gen v = if (isURI v)
|
||||
then gitRepoFromUrl v
|
||||
else gitRepoFromPath v
|
||||
|
||||
{- Finds the current git repository, which may be in a parent directory. -}
|
||||
gitRepoFromCwd :: IO GitRepo
|
||||
|
@ -206,7 +202,7 @@ gitRepoFromCwd = do
|
|||
cwd <- getCurrentDirectory
|
||||
top <- seekUp cwd isRepoTop
|
||||
case top of
|
||||
(Just dir) -> gitRepoFromPath dir True
|
||||
(Just dir) -> return $ gitRepoFromPath dir
|
||||
Nothing -> error "Not in a git repository."
|
||||
|
||||
seekUp :: String -> (String -> IO Bool) -> IO (Maybe String)
|
||||
|
|
Loading…
Reference in a new issue