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
|
{- 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,
gitAdd,
gitRm,
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 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,
bare :: Bool,
config :: Map String String
} | RemoteGitRepo {
url :: String,
top :: FilePath,
config :: Map String String
} deriving (Show, Read, Eq)
{- Local GitRepo constructor. -}
gitRepoFromPath :: FilePath -> IO GitRepo
gitRepoFromPath dir = do
b <- isBareRepo dir
let r = LocalGitRepo {
top = dir,
bare = b,
config = Map.empty
}
r' <- gitConfigRead r
return r'
{- Remote GitRepo constructor. Note that remote repo config is not read.
- Throws exception on invalid url. -}
gitRepoFromUrl :: String -> IO GitRepo
gitRepoFromUrl url = do
return $ RemoteGitRepo {
url = url,
top = path url,
config = Map.empty
}
where path url = uriPath $ fromJust $ parseURI url
{- Some code needs to vary between remote and local repos, 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 " ++ (url repo) ++
" not supported"
{- 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
{- Stages a changed/new file in git's index. -}
gitAdd :: GitRepo -> FilePath -> IO ()
gitAdd repo file = runGit repo ["add", file]
{- Removes a file. -}
gitRm :: GitRepo -> FilePath -> IO ()
gitRm repo file = runGit repo ["rm", file]
{- 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. -}
runGit :: GitRepo -> [String] -> IO ()
runGit repo params = assertlocal repo $ 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 = 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 settings. -}
gitConfigRead :: GitRepo -> IO GitRepo
gitConfigRead repo = assertlocal repo $ do
c <- gitPipeRead repo ["config", "--list"]
return repo { config = gitConfigParse c }
{- 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 key defaultValue (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
else gitRepoFromPath r
{- 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
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)
|
