more Wall cleaning
This commit is contained in:
parent
435ec21d58
commit
aa05859410
2 changed files with 33 additions and 26 deletions
2
Core.hs
2
Core.hs
|
@ -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)
|
||||||
|
|
57
GitRepo.hs
57
GitRepo.hs
|
@ -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)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue