1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
{- git repository handling -}
module GitRepo (
GitRepo,
gitRepoCurrent,
gitRepoTop,
gitDir,
gitRelative,
gitConfigGet,
gitAdd,
gitAttributes
) where
import Directory
import System.Directory
import System.Path
import System.Cmd.Utils
import System.IO
import System.IO.Error
import Data.String.Utils
import Utility
-- a git repository
data GitRepo = GitRepo {
gitRepoTop :: FilePath,
bare :: Bool
}
{- GitRepo constructor -}
gitRepo :: FilePath -> IO GitRepo
gitRepo dir = do
b <- isBareRepo dir
return GitRepo {
gitRepoTop = dir,
bare = b
}
{- Short name used in here for top of repo. -}
top = gitRepoTop
{- Path to a repository's gitattributes file. -}
gitAttributes :: GitRepo -> IO String
gitAttributes repo = do
if (bare repo)
then return $ (top repo) ++ "/info/.gitattributes"
else return $ (top repo) ++ "/.gitattributes"
{- Path to a repository's .git directory.
- (For a bare repository, that is the root of the repository.)
- TODO: support GIT_DIR -}
gitDir :: GitRepo -> IO String
gitDir repo = do
if (bare repo)
then return $ (top repo)
else return $ (top repo) ++ "/.git"
{- Given a relative or absolute filename, calculates the name to use
- to refer to the file relative to a git repository directory.
- This is the same form displayed and used by git. -}
gitRelative :: GitRepo -> String -> String
gitRelative repo file = drop (length absrepo) absfile
where
-- normalize both repo and file, so that repo
-- will be substring of file
absrepo = case (absNormPath "/" (top repo)) of
Just f -> f ++ "/"
Nothing -> error $ "bad repo" ++ (top repo)
absfile = case (secureAbsNormPath absrepo file) of
Just f -> f
Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
{- Stages a changed file in git's index. -}
gitAdd :: GitRepo -> FilePath -> IO ()
gitAdd repo file = do
-- TODO
return ()
{- Queries git-config. -}
gitConfigGet :: String -> String -> IO String
gitConfigGet name defaultValue =
flip catch (\_ -> return defaultValue) $
pOpen ReadFromPipe "git" ["config", "--get", name] $ \h -> do
ret <- hGetLine h
return ret
{- Finds the current git repository, which may be in a parent directory. -}
gitRepoCurrent :: IO GitRepo
gitRepoCurrent = do
cwd <- getCurrentDirectory
top <- seekUp cwd isRepoTop
case top of
(Just dir) -> gitRepo dir
Nothing -> error "Not in a git repository."
seekUp :: String -> (String -> IO Bool) -> IO (Maybe String)
seekUp dir want = do
ok <- want dir
if ok
then return (Just dir)
else case (parentDir dir) of
"" -> return Nothing
d -> seekUp d want
isRepoTop dir = do
r <- isGitRepo dir
b <- isBareRepo dir
return (r || b)
isGitRepo dir = gitSignature dir ".git" ".git/config"
isBareRepo dir = gitSignature dir "objects" "config"
gitSignature dir subdir file = do
s <- (doesDirectoryExist (dir ++ "/" ++ subdir))
f <- (doesFileExist (dir ++ "/" ++ file))
return (s && f)
|
