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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
{- git repository handling
-
- This is written to be completely independant of git-annex and should be
- suitable for other uses.
-
- -}
module GitRepo (
GitRepo,
gitRepoFromCwd,
gitRepoFromPath,
gitRepoFromUrl,
gitWorkTree,
gitDir,
gitRelative,
gitConfig,
gitConfigRead,
gitRun,
gitAttributes
) where
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 Data.Map as Map hiding (map, split)
import Network.URI
import Maybe
import Utility
{- A git repository can be on local disk or remote. Not to be confused
- with a git repo's configured remotes, some of which may be on local
- disk. -}
data GitRepo =
LocalGitRepo {
top :: FilePath,
config :: Map String String
} | RemoteGitRepo {
url :: String,
top :: FilePath,
config :: Map String String
} deriving (Show, Read, Eq)
{- Local GitRepo constructor. Can optionally query the repo for its config. -}
gitRepoFromPath :: FilePath -> Bool -> IO GitRepo
gitRepoFromPath dir query = do
let r = LocalGitRepo {
top = dir,
config = Map.empty
}
if (query)
then gitConfigRead r
else return r
{- Remote GitRepo constructor. Throws exception on invalid url. -}
gitRepoFromUrl :: String -> Bool -> IO GitRepo
gitRepoFromUrl url query = do
return $ RemoteGitRepo {
url = url,
top = path url,
config = Map.empty
}
where path url = uriPath $ fromJust $ parseURI url
{- User-visible description of a git repo by path or url -}
describe repo = if (local repo) then top repo else url repo
{- Some code needs to vary between remote and local repos, or bare and
- non-bare, these functions help with that. -}
local repo = case (repo) of
LocalGitRepo {} -> True
RemoteGitRepo {} -> False
remote repo = not $ local repo
assertlocal repo action =
if (local repo)
then action
else error $ "acting on remote git repo " ++ (describe repo) ++
" not supported"
bare :: GitRepo -> Bool
bare repo =
if (member b (config repo))
then ("true" == fromJust (Map.lookup b (config repo)))
else error $ "it is not known if git repo " ++ (describe repo) ++
" is a bare repository; config not read"
where
b = "core.bare"
{- Path to a repository's gitattributes file. -}
gitAttributes :: GitRepo -> String
gitAttributes repo = assertlocal repo $ do
if (bare repo)
then (top repo) ++ "/info/.gitattributes"
else (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 = assertlocal repo $
if (bare repo)
then top repo
else top repo ++ "/.git"
{- Path to a repository's --work-tree. -}
gitWorkTree :: GitRepo -> FilePath
gitWorkTree repo = top repo
{- Given a relative or absolute filename in a repository, calculates the
- name to use to refer to the file relative to a git repository's top.
- 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
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: GitRepo -> [String] -> [String]
gitCommandLine repo params = assertlocal repo $
-- 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. -}
gitRun :: GitRepo -> [String] -> IO ()
gitRun repo params = assertlocal repo $ do
r <- rawSystem "git" (gitCommandLine repo params)
return ()
{- Runs a git subcommand and returns its output. -}
gitPipeRead :: GitRepo -> [String] -> IO String
gitPipeRead repo params = assertlocal repo $ do
pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
ret <- hGetContentsStrict h
return ret
{- Runs git config and populates a repo with its config. -}
gitConfigRead :: GitRepo -> IO GitRepo
gitConfigRead repo = assertlocal repo $ do
{- Cannot use gitPipeRead because it relies on the config having
been already read. Instead, chdir to the repo. -}
cwd <- getCurrentDirectory
bracket_ (changeWorkingDirectory (top repo))
(\_ -> changeWorkingDirectory cwd) $ do
pOpen ReadFromPipe "git" ["config", "--list"] $ \h -> do
val <- hGetContentsStrict h
return repo { config = gitConfigParse val }
{- Parses git config --list output into a config map. -}
gitConfigParse :: String -> Map.Map String String
gitConfigParse s = Map.fromList $ map pair $ lines s
where
pair l = (key l, val l)
key l = (keyval l) !! 0
val l = join sep $ drop 1 $ keyval l
keyval l = split sep l :: [String]
sep = "="
{- Returns a single git config setting, or a default value if not set. -}
gitConfig :: GitRepo -> String -> String -> String
gitConfig repo key defaultValue =
Map.findWithDefault defaultValue key (config repo)
{- Returns a list of a repo's configured remotes. -}
gitConfigRemotes :: GitRepo -> IO [GitRepo]
gitConfigRemotes repo = mapM construct remotes
where
remotes = elems $ filter $ config repo
filter = filterWithKey (\k _ -> isremote k)
isremote k = (startswith "remote." k) && (endswith ".url" k)
construct r =
if (isURI r)
then gitRepoFromUrl r False
else gitRepoFromPath r False
{- Finds the current git repository, which may be in a parent directory. -}
gitRepoFromCwd :: IO GitRepo
gitRepoFromCwd = do
cwd <- getCurrentDirectory
top <- seekUp cwd isRepoTop
case top of
(Just dir) -> gitRepoFromPath dir True
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)
where
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)
|
