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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
{- git repository handling
-
- This is written to be completely independant of git-annex and should be
- suitable for other uses.
-
- -}
module GitRepo (
GitRepo,
gitRepoCurrent,
gitRepoTop,
gitDir,
gitRelative,
gitConfig,
gitAdd,
gitAttributes
) where
import Directory
import System
import System.Directory
import System.Path
import System.Cmd.Utils
import System.IO
import System.Posix.Process
import Data.String.Utils
import Data.Map as Map (fromList, empty, lookup, Map)
import Utility
-- a git repository
data GitRepo = GitRepo {
top :: FilePath,
bare :: Bool,
config :: Map String String
} deriving (Show, Read, Eq)
{- GitRepo constructor -}
gitRepo :: FilePath -> IO GitRepo
gitRepo dir = do
b <- isBareRepo dir
let r = GitRepo {
top = dir,
bare = b,
config = Map.empty
}
r' <- gitConfigRead r
return r'
{- Field accessor. -}
gitRepoTop :: GitRepo -> FilePath
gitRepoTop repo = top repo
{- 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 -> String
gitDir repo =
if (bare repo)
then top repo
else 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 = runGit repo ["add", file]
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: GitRepo -> [String] -> [String]
gitCommandLine repo params =
-- force use of specified repo via --git-dir and --work-tree
["--git-dir="++(gitDir repo), "--work-tree="++(top repo)] ++ params
{- Runs git in the specified repo. -}
runGit :: GitRepo -> [String] -> IO ()
runGit repo params = do
r <- executeFile "git" True (gitCommandLine repo params) Nothing
return ()
{- Runs a git subcommand and returns its output. -}
gitPipeRead :: GitRepo -> [String] -> IO String
gitPipeRead repo params =
pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
ret <- hGetContentsStrict h
return ret
{- Runs git config and populates a repo with its settings. -}
gitConfigRead :: GitRepo -> IO GitRepo
gitConfigRead repo = do
c <- gitPipeRead repo ["config", "--list"]
return repo { config = Map.fromList $ parse c }
where
parse s = map ( \l -> (key l, val l) ) $ lines s
keyval l = split sep l :: [String]
key l = (keyval l) !! 0
val l = join sep $ drop 1 $ keyval l
sep = "="
{- Returns a single git config setting, or a default value if not set. -}
gitConfig :: GitRepo -> String -> String -> String
gitConfig repo key defaultValue =
case (Map.lookup key $ config repo) of
Just value -> value
Nothing -> defaultValue
{- 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)
|
