summaryrefslogtreecommitdiff
path: root/GitRepo.hs
blob: 32383197b55394829ddceb52e06c24cd66ed5340 (plain)
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
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
{- git repository handling 
 -
 - This is written to be completely independant of git-annex and should be
 - suitable for other uses.
 -
 -}

module GitRepo (
	Repo,
	repoFromCwd,
	repoFromPath,
	repoFromUrl,
	repoIsLocal,
	repoIsRemote,
	repoDescribe,
	workTree,
	dir,
	relative,
	configGet,
	configMap,
	configRead,
	run,
	pipeRead,
	attributes,
	remotes,
	remotesAdd,
	repoRemoteName,
	inRepo,
	notInRepo
) 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 Repo = 
	LocalRepo {
		top :: FilePath,
		config :: Map String String,
		remotes :: [Repo],
		-- remoteName holds the name used for this repo in remotes
		remoteName :: Maybe String 
	} | RemoteRepo {
		url :: String,
		top :: FilePath,
		config :: Map String String,
		remotes :: [Repo],
		remoteName :: Maybe String
	} deriving (Show, Read, Eq)

{- Local Repo constructor. -}
repoFromPath :: FilePath -> Repo
repoFromPath dir =
	LocalRepo {
		top = dir,
		config = Map.empty,
		remotes = [],
		remoteName = Nothing
	}

{- Remote Repo constructor. Throws exception on invalid url. -}
repoFromUrl :: String -> Repo
repoFromUrl url =
	RemoteRepo {
		url = url,
		top = path url,
		config = Map.empty,
		remotes = [],
		remoteName = Nothing
	}
	where path url = uriPath $ fromJust $ parseURI url

{- User-visible description of a git repo. -}
repoDescribe repo = 
	if (isJust $ remoteName repo)
		then fromJust $ remoteName repo
		else if (repoIsLocal repo)
			then top repo
			else url repo

{- Constructs and returns an updated version of a repo with
 - different remotes list. -}
remotesAdd :: Repo -> [Repo] -> Repo
remotesAdd repo rs = repo { remotes = rs }

{- Returns the name of the remote that corresponds to the repo, if 
 - it is a remote. Otherwise, "" -}
repoRemoteName r = 
	if (isJust $ remoteName r)
		then fromJust $ remoteName r
		else ""

{- Some code needs to vary between remote and local repos, or bare and
 - non-bare, these functions help with that. -}
repoIsLocal repo = case (repo) of
	LocalRepo {} -> True
	RemoteRepo {} -> False
repoIsRemote repo = not $ repoIsLocal repo
assertlocal repo action = 
	if (repoIsLocal repo)
		then action
		else error $ "acting on remote git repo " ++  (repoDescribe repo) ++ 
				" not supported"
bare :: Repo -> 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 " ++ (repoDescribe repo) ++
			" is a bare repository; config not read"
	where
		b = "core.bare"

{- Path to a repository's gitattributes file. -}
attributes :: Repo -> String
attributes repo = assertlocal repo $ do
	if (bare repo)
		then (top repo) ++ "/info/.gitattributes"
		else (top repo) ++ "/.gitattributes"

{- Path to a repository's .git directory, relative to its topdir. -}
dir :: Repo -> String
dir repo = assertlocal repo $
	if (bare repo)
		then ""
		else ".git"

{- Path to a repository's --work-tree. -}
workTree :: Repo -> FilePath
workTree 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. -}
relative :: Repo -> String -> String
relative 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 :: Repo -> [String] -> [String]
gitCommandLine repo params = assertlocal repo $
	-- force use of specified repo via --git-dir and --work-tree
	["--git-dir="++(top repo)++"/"++(dir repo), "--work-tree="++(top repo)] ++ params

{- Runs git in the specified repo. -}
run :: Repo -> [String] -> IO ()
run repo params = assertlocal repo $ do
	r <- rawSystem "git" (gitCommandLine repo params)
	return ()

{- Runs a git subcommand and returns its output. -}
pipeRead :: Repo -> [String] -> IO String
pipeRead repo params = assertlocal repo $ do
	pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
	ret <- hGetContentsStrict h
	return ret

{- Passed a location, recursively scans for all files that
 - are checked into git at that location. -}
inRepo :: Repo -> FilePath -> IO [FilePath]
inRepo repo location = do
	s <- pipeRead repo ["ls-files", "--cached", "--exclude-standard", location]
	return $ lines s

{- Passed a location, recursively scans for all files that are not checked
 - into git, and not gitignored. -}
notInRepo :: Repo -> FilePath -> IO [FilePath]
notInRepo repo location = do
	s <- pipeRead repo ["ls-files", "--others", "--exclude-standard", location]
	return $ lines s

{- Runs git config and populates a repo with its config. -}
configRead :: Repo -> IO Repo
configRead repo = assertlocal repo $ do
	{- Cannot use pipeRead because it relies on the config having
           been already read. Instead, chdir to the repo. -}
	cwd <- getCurrentDirectory
	bracket_ (changeWorkingDirectory (top repo))
		(\_ -> changeWorkingDirectory cwd) $
			pOpen ReadFromPipe "git" ["config", "--list"] $ \h -> do
				val <- hGetContentsStrict h
				let r = repo { config = configParse val }
				return r { remotes = configRemotes r }

{- Calculates a list of a repo's configured remotes, by parsing its config. -}
configRemotes :: Repo -> [Repo]
configRemotes repo = map construct remotes
	where
		remotes = toList $ filter $ config repo
		filter = filterWithKey (\k _ -> isremote k)
		isremote k = (startswith "remote." k) && (endswith ".url" k)
		remotename k = (split "." k) !! 1
		construct (k,v) = (gen v) { remoteName = Just $ remotename k }
		gen v = if (isURI v)
			then repoFromUrl v
			else repoFromPath v

{- Parses git config --list output into a config map. -}
configParse :: String -> Map.Map String String
configParse 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. -}
configGet :: Repo -> String -> String -> String
configGet repo key defaultValue = 
	Map.findWithDefault defaultValue key (config repo)

{- Access to raw config Map -}
configMap :: Repo -> Map String String
configMap repo = config repo

{- Finds the current git repository, which may be in a parent directory. -}
repoFromCwd :: IO Repo
repoFromCwd = do
	cwd <- getCurrentDirectory
	top <- seekUp cwd isRepoTop
	case top of
		(Just dir) -> return $ repoFromPath 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 <- isRepo dir
	b <- isBareRepo dir
	return (r || b)
	where
		isRepo 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)