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
|
{- git repository handling
-
- This is written to be completely independant of git-annex and should be
- suitable for other uses.
-
- -}
module GitRepo (
GitRepo,
gitRepoCurrent,
gitRepoFromPath,
gitRepoFromUrl,
gitWorkTree,
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 Network.URI
import Maybe
import Utility
{- A git repository can be local or remote. -}
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. -}
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 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 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
if (local repo)
then ["--git-dir="++(gitDir repo), "--work-tree="++(top repo)] ++ params
else error "gitCommandLine not implemented for remote repo"
{- Runs git in the specified repo. -}
runGit :: GitRepo -> [String] -> IO ()
runGit repo params =
if (local repo)
then do
r <- executeFile "git" True (gitCommandLine repo params) Nothing
return ()
else error "runGit not implemented for remote repo"
{- Runs a git subcommand and returns its output. -}
gitPipeRead :: GitRepo -> [String] -> IO String
gitPipeRead repo params =
if (local repo)
then pOpen ReadFromPipe "git" (gitCommandLine repo params) $ \h -> do
ret <- hGetContentsStrict h
return ret
else error "gitPipeRead not implemented for remote repo"
{- Runs git config and populates a repo with its settings. -}
gitConfigRead :: GitRepo -> IO GitRepo
gitConfigRead repo =
if (local repo)
then do
c <- gitPipeRead repo ["config", "--list"]
return repo { config = gitConfigParse c }
else error "gitConfigRead not implemented for remote repo"
{- 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 =
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) -> 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)
|
