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,
|
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 =
|
||||||
|
|
32
GitRepo.hs
32
GitRepo.hs
|
@ -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)
|
||||||
|
|
Loading…
Reference in a new issue