summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2010-10-31 15:38:47 -0400
committerGravatar Joey Hess <joey@kitenet.net>2010-10-31 15:38:47 -0400
commitaa05859410b43da72c3165b7915d8c917bc015ca (patch)
tree3d52ac20c3170d915906af37d341866243911bb7
parent435ec21d58f9c7ddb622f290648b31da2c9a8f1e (diff)
more Wall cleaning
-rw-r--r--Core.hs2
-rw-r--r--GitRepo.hs57
2 files changed, 33 insertions, 26 deletions
diff --git a/Core.hs b/Core.hs
index 5f799161c..c5026c6a5 100644
--- a/Core.hs
+++ b/Core.hs
@@ -74,7 +74,7 @@ gitAttributes repo = do
{- set up a git pre-commit hook, if one is not already present -}
gitPreCommitHook :: Git.Repo -> IO ()
gitPreCommitHook repo = do
- let hook = (Git.workTree repo) ++ "/" ++ (Git.dir repo) ++
+ let hook = (Git.workTree repo) ++ "/" ++ (Git.gitDir repo) ++
"/hooks/pre-commit"
exists <- doesFileExist hook
if (exists)
diff --git a/GitRepo.hs b/GitRepo.hs
index 9ecd3923a..874b5c3c9 100644
--- a/GitRepo.hs
+++ b/GitRepo.hs
@@ -17,7 +17,7 @@ module GitRepo (
repoIsSsh,
repoDescribe,
workTree,
- dir,
+ gitDir,
relative,
urlPath,
urlHost,
@@ -38,17 +38,14 @@ module GitRepo (
stagedFiles
) where
-import Monad (when, unless)
+import Monad (unless)
import Directory
-import System
-import System.Directory
import System.Posix.Directory
import System.Path
-import System.Cmd
import System.Cmd.Utils
-import System.IO
import IO (bracket_)
import Data.String.Utils
+import System.IO
import qualified Data.Map as Map hiding (map, split)
import Network.URI
import Maybe
@@ -69,6 +66,7 @@ data Repo = Repo {
remoteName :: Maybe String
} deriving (Show, Eq)
+newFrom :: RepoLocation -> Repo
newFrom l =
Repo {
location = l,
@@ -89,6 +87,7 @@ repoFromUrl url
where u = fromJust $ parseURI url
{- User-visible description of a git repo. -}
+repoDescribe :: Repo -> String
repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = Dir dir } = dir
@@ -100,29 +99,35 @@ remotesAdd repo rs = repo { remotes = rs }
{- Returns the name of the remote that corresponds to the repo, if
- it is a remote. Otherwise, "" -}
+repoRemoteName :: Repo -> String
repoRemoteName Repo { remoteName = Just name } = name
repoRemoteName _ = ""
{- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -}
+repoIsUrl :: Repo -> Bool
repoIsUrl Repo { location = Url _ } = True
repoIsUrl _ = False
+repoIsSsh :: Repo -> Bool
repoIsSsh Repo { location = Url url }
| uriScheme url == "ssh:" = True
| otherwise = False
repoIsSsh _ = False
+assertLocal :: Repo -> a -> a
assertLocal repo action =
if (not $ repoIsUrl repo)
then action
else error $ "acting on URL git repo " ++ (repoDescribe repo) ++
" not supported"
+assertUrl :: Repo -> a -> a
assertUrl repo action =
if (repoIsUrl repo)
then action
else error $ "acting on local git repo " ++ (repoDescribe repo) ++
" not supported"
+assertSsh :: Repo -> a -> a
assertSsh repo action =
if (repoIsSsh repo)
then action
@@ -141,8 +146,8 @@ attributes repo
| otherwise = (workTree repo) ++ "/.gitattributes"
{- Path to a repository's .git directory, relative to its workTree. -}
-dir :: Repo -> String
-dir repo
+gitDir :: Repo -> String
+gitDir repo
| bare repo = ""
| otherwise = ".git"
@@ -167,7 +172,7 @@ relative repo@(Repo { location = Dir d }) file = drop (length absrepo) absfile
absfile = case (secureAbsNormPath absrepo file) of
Just f -> f
Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
-relative repo file = assertLocal repo $ error "internal"
+relative repo _ = assertLocal repo $ error "internal"
{- Hostname of an URL repo. (May include a username and/or port too.) -}
urlHost :: Repo -> String
@@ -184,7 +189,7 @@ urlPath repo = assertUrl repo $ error "internal"
gitCommandLine :: Repo -> [String] -> [String]
gitCommandLine repo@(Repo { location = Dir d} ) params =
-- force use of specified repo via --git-dir and --work-tree
- ["--git-dir="++d++"/"++(dir repo), "--work-tree="++d] ++ params
+ ["--git-dir="++d++"/"++(gitDir repo), "--work-tree="++d] ++ params
gitCommandLine repo _ = assertLocal repo $ error "internal"
{- Runs git in the specified repo, throwing an error if it fails. -}
@@ -214,21 +219,21 @@ hPipeRead repo params = assertLocal repo $ do
{- Passed a location, recursively scans for all files that
- are checked into git at that location. -}
inRepo :: Repo -> FilePath -> IO [FilePath]
-inRepo repo location = pipeNullSplit repo
- ["ls-files", "--cached", "--exclude-standard", "-z", location]
+inRepo repo l = pipeNullSplit repo
+ ["ls-files", "--cached", "--exclude-standard", "-z", l]
{- Passed a location, recursively scans for all files that are not checked
- into git, and not gitignored. -}
notInRepo :: Repo -> FilePath -> IO [FilePath]
-notInRepo repo location = pipeNullSplit repo
- ["ls-files", "--others", "--exclude-standard", "-z", location]
+notInRepo repo l = pipeNullSplit repo
+ ["ls-files", "--others", "--exclude-standard", "-z", l]
{- Passed a location, returns a list of the files, staged for
- commit, that are being added, moved, or changed (but not deleted). -}
stagedFiles :: Repo -> FilePath -> IO [FilePath]
-stagedFiles repo location = pipeNullSplit repo
+stagedFiles repo l = pipeNullSplit repo
["diff", "--cached", "--name-only", "--diff-filter=ACMRT", "-z",
- "HEAD", location]
+ "HEAD", l]
{- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it into a list of files. -}
@@ -236,7 +241,7 @@ pipeNullSplit :: Repo -> [String] -> IO [FilePath]
pipeNullSplit repo params = do
-- XXX handle is left open, this is ok for git-annex, but may need
-- to be cleaned up for other uses.
- (handle, fs0) <- hPipeRead repo params
+ (_, fs0) <- hPipeRead repo params
return $ split0 fs0
where
split0 s = filter (not . null) $ split "\0" s
@@ -256,6 +261,7 @@ configRead repo = assertSsh repo $ do
where
sshcommand = "cd " ++ (shellEscape $ urlPath repo) ++
" && git config --list"
+hConfigRead :: Repo -> Handle -> IO Repo
hConfigRead repo h = do
val <- hGetContentsStrict h
let r = repo { config = configParse val }
@@ -267,10 +273,10 @@ configTrue s = map toLower s == "true"
{- Calculates a list of a repo's configured remotes, by parsing its config. -}
configRemotes :: Repo -> [Repo]
-configRemotes repo = map construct remotes
+configRemotes repo = map construct remotepairs
where
- remotes = Map.toList $ filter $ config repo
- filter = Map.filterWithKey (\k _ -> isremote k)
+ remotepairs = Map.toList $ filterremotes $ config repo
+ filterremotes = Map.filterWithKey (\k _ -> isremote k)
isremote k = (startswith "remote." k) && (endswith ".url" k)
remotename k = (split "." k) !! 1
construct (k,v) = (gen v) { remoteName = Just $ remotename k }
@@ -314,14 +320,15 @@ seekUp dir want = do
"" -> return Nothing
d -> seekUp d want
+isRepoTop :: FilePath -> IO Bool
isRepoTop dir = do
- r <- isRepo dir
- b <- isBareRepo dir
+ r <- isRepo
+ b <- isBareRepo
return (r || b)
where
- isRepo dir = gitSignature dir ".git" ".git/config"
- isBareRepo dir = gitSignature dir "objects" "config"
- gitSignature dir subdir file = do
+ isRepo = gitSignature ".git" ".git/config"
+ isBareRepo = gitSignature "objects" "config"
+ gitSignature subdir file = do
s <- (doesDirectoryExist (dir ++ "/" ++ subdir))
f <- (doesFileExist (dir ++ "/" ++ file))
return (s && f)