more Wall cleaning

This commit is contained in:
Joey Hess 2010-10-31 15:38:47 -04:00
parent 435ec21d58
commit aa05859410
2 changed files with 33 additions and 26 deletions

View file

@ -74,7 +74,7 @@ gitAttributes repo = do
{- set up a git pre-commit hook, if one is not already present -} {- set up a git pre-commit hook, if one is not already present -}
gitPreCommitHook :: Git.Repo -> IO () gitPreCommitHook :: Git.Repo -> IO ()
gitPreCommitHook repo = do gitPreCommitHook repo = do
let hook = (Git.workTree repo) ++ "/" ++ (Git.dir repo) ++ let hook = (Git.workTree repo) ++ "/" ++ (Git.gitDir repo) ++
"/hooks/pre-commit" "/hooks/pre-commit"
exists <- doesFileExist hook exists <- doesFileExist hook
if (exists) if (exists)

View file

@ -17,7 +17,7 @@ module GitRepo (
repoIsSsh, repoIsSsh,
repoDescribe, repoDescribe,
workTree, workTree,
dir, gitDir,
relative, relative,
urlPath, urlPath,
urlHost, urlHost,
@ -38,17 +38,14 @@ module GitRepo (
stagedFiles stagedFiles
) where ) where
import Monad (when, unless) import Monad (unless)
import Directory import Directory
import System
import System.Directory
import System.Posix.Directory import System.Posix.Directory
import System.Path import System.Path
import System.Cmd
import System.Cmd.Utils import System.Cmd.Utils
import System.IO
import IO (bracket_) import IO (bracket_)
import Data.String.Utils import Data.String.Utils
import System.IO
import qualified Data.Map as Map hiding (map, split) import qualified Data.Map as Map hiding (map, split)
import Network.URI import Network.URI
import Maybe import Maybe
@ -69,6 +66,7 @@ data Repo = Repo {
remoteName :: Maybe String remoteName :: Maybe String
} deriving (Show, Eq) } deriving (Show, Eq)
newFrom :: RepoLocation -> Repo
newFrom l = newFrom l =
Repo { Repo {
location = l, location = l,
@ -89,6 +87,7 @@ repoFromUrl url
where u = fromJust $ parseURI url where u = fromJust $ parseURI url
{- User-visible description of a git repo. -} {- User-visible description of a git repo. -}
repoDescribe :: Repo -> String
repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = Dir dir } = dir 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 {- Returns the name of the remote that corresponds to the repo, if
- it is a remote. Otherwise, "" -} - it is a remote. Otherwise, "" -}
repoRemoteName :: Repo -> String
repoRemoteName Repo { remoteName = Just name } = name repoRemoteName Repo { remoteName = Just name } = name
repoRemoteName _ = "" repoRemoteName _ = ""
{- Some code needs to vary between URL and normal repos, {- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -} - or bare and non-bare, these functions help with that. -}
repoIsUrl :: Repo -> Bool
repoIsUrl Repo { location = Url _ } = True repoIsUrl Repo { location = Url _ } = True
repoIsUrl _ = False repoIsUrl _ = False
repoIsSsh :: Repo -> Bool
repoIsSsh Repo { location = Url url } repoIsSsh Repo { location = Url url }
| uriScheme url == "ssh:" = True | uriScheme url == "ssh:" = True
| otherwise = False | otherwise = False
repoIsSsh _ = False repoIsSsh _ = False
assertLocal :: Repo -> a -> a
assertLocal repo action = assertLocal repo action =
if (not $ repoIsUrl repo) if (not $ repoIsUrl repo)
then action then action
else error $ "acting on URL git repo " ++ (repoDescribe repo) ++ else error $ "acting on URL git repo " ++ (repoDescribe repo) ++
" not supported" " not supported"
assertUrl :: Repo -> a -> a
assertUrl repo action = assertUrl repo action =
if (repoIsUrl repo) if (repoIsUrl repo)
then action then action
else error $ "acting on local git repo " ++ (repoDescribe repo) ++ else error $ "acting on local git repo " ++ (repoDescribe repo) ++
" not supported" " not supported"
assertSsh :: Repo -> a -> a
assertSsh repo action = assertSsh repo action =
if (repoIsSsh repo) if (repoIsSsh repo)
then action then action
@ -141,8 +146,8 @@ attributes repo
| otherwise = (workTree repo) ++ "/.gitattributes" | otherwise = (workTree repo) ++ "/.gitattributes"
{- Path to a repository's .git directory, relative to its workTree. -} {- Path to a repository's .git directory, relative to its workTree. -}
dir :: Repo -> String gitDir :: Repo -> String
dir repo gitDir repo
| bare repo = "" | bare repo = ""
| otherwise = ".git" | otherwise = ".git"
@ -167,7 +172,7 @@ relative repo@(Repo { location = Dir d }) file = drop (length absrepo) absfile
absfile = case (secureAbsNormPath absrepo file) of absfile = case (secureAbsNormPath absrepo file) of
Just f -> f Just f -> f
Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo 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.) -} {- Hostname of an URL repo. (May include a username and/or port too.) -}
urlHost :: Repo -> String urlHost :: Repo -> String
@ -184,7 +189,7 @@ urlPath repo = assertUrl repo $ error "internal"
gitCommandLine :: Repo -> [String] -> [String] gitCommandLine :: Repo -> [String] -> [String]
gitCommandLine repo@(Repo { location = Dir d} ) params = gitCommandLine repo@(Repo { location = Dir d} ) params =
-- force use of specified repo via --git-dir and --work-tree -- 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" gitCommandLine repo _ = assertLocal repo $ error "internal"
{- Runs git in the specified repo, throwing an error if it fails. -} {- 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 {- Passed a location, recursively scans for all files that
- are checked into git at that location. -} - are checked into git at that location. -}
inRepo :: Repo -> FilePath -> IO [FilePath] inRepo :: Repo -> FilePath -> IO [FilePath]
inRepo repo location = pipeNullSplit repo inRepo repo l = pipeNullSplit repo
["ls-files", "--cached", "--exclude-standard", "-z", location] ["ls-files", "--cached", "--exclude-standard", "-z", l]
{- Passed a location, recursively scans for all files that are not checked {- Passed a location, recursively scans for all files that are not checked
- into git, and not gitignored. -} - into git, and not gitignored. -}
notInRepo :: Repo -> FilePath -> IO [FilePath] notInRepo :: Repo -> FilePath -> IO [FilePath]
notInRepo repo location = pipeNullSplit repo notInRepo repo l = pipeNullSplit repo
["ls-files", "--others", "--exclude-standard", "-z", location] ["ls-files", "--others", "--exclude-standard", "-z", l]
{- Passed a location, returns a list of the files, staged for {- Passed a location, returns a list of the files, staged for
- commit, that are being added, moved, or changed (but not deleted). -} - commit, that are being added, moved, or changed (but not deleted). -}
stagedFiles :: Repo -> FilePath -> IO [FilePath] stagedFiles :: Repo -> FilePath -> IO [FilePath]
stagedFiles repo location = pipeNullSplit repo stagedFiles repo l = pipeNullSplit repo
["diff", "--cached", "--name-only", "--diff-filter=ACMRT", "-z", ["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 {- Reads null terminated output of a git command (as enabled by the -z
- parameter), and splits it into a list of files. -} - parameter), and splits it into a list of files. -}
@ -236,7 +241,7 @@ pipeNullSplit :: Repo -> [String] -> IO [FilePath]
pipeNullSplit repo params = do pipeNullSplit repo params = do
-- XXX handle is left open, this is ok for git-annex, but may need -- XXX handle is left open, this is ok for git-annex, but may need
-- to be cleaned up for other uses. -- to be cleaned up for other uses.
(handle, fs0) <- hPipeRead repo params (_, fs0) <- hPipeRead repo params
return $ split0 fs0 return $ split0 fs0
where where
split0 s = filter (not . null) $ split "\0" s split0 s = filter (not . null) $ split "\0" s
@ -256,6 +261,7 @@ configRead repo = assertSsh repo $ do
where where
sshcommand = "cd " ++ (shellEscape $ urlPath repo) ++ sshcommand = "cd " ++ (shellEscape $ urlPath repo) ++
" && git config --list" " && git config --list"
hConfigRead :: Repo -> Handle -> IO Repo
hConfigRead repo h = do hConfigRead repo h = do
val <- hGetContentsStrict h val <- hGetContentsStrict h
let r = repo { config = configParse val } 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. -} {- Calculates a list of a repo's configured remotes, by parsing its config. -}
configRemotes :: Repo -> [Repo] configRemotes :: Repo -> [Repo]
configRemotes repo = map construct remotes configRemotes repo = map construct remotepairs
where where
remotes = Map.toList $ filter $ config repo remotepairs = Map.toList $ filterremotes $ config repo
filter = Map.filterWithKey (\k _ -> isremote k) filterremotes = Map.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) = (gen v) { remoteName = Just $ remotename k } construct (k,v) = (gen v) { remoteName = Just $ remotename k }
@ -314,14 +320,15 @@ seekUp dir want = do
"" -> return Nothing "" -> return Nothing
d -> seekUp d want d -> seekUp d want
isRepoTop :: FilePath -> IO Bool
isRepoTop dir = do isRepoTop dir = do
r <- isRepo dir r <- isRepo
b <- isBareRepo dir b <- isBareRepo
return (r || b) return (r || b)
where where
isRepo dir = gitSignature dir ".git" ".git/config" isRepo = gitSignature ".git" ".git/config"
isBareRepo dir = gitSignature dir "objects" "config" isBareRepo = gitSignature "objects" "config"
gitSignature dir subdir file = do gitSignature subdir file = do
s <- (doesDirectoryExist (dir ++ "/" ++ subdir)) s <- (doesDirectoryExist (dir ++ "/" ++ subdir))
f <- (doesFileExist (dir ++ "/" ++ file)) f <- (doesFileExist (dir ++ "/" ++ file))
return (s && f) return (s && f)