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
|
{- git repository handling
-
- This is written to be completely independant of git-annex and should be
- suitable for other uses.
-
- Copyright 2010-2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Git (
Repo(..),
Ref(..),
fromRef,
Branch,
Sha,
Tag,
repoIsUrl,
repoIsSsh,
repoIsHttp,
repoIsLocal,
repoIsLocalBare,
repoIsLocalUnknown,
repoDescribe,
repoLocation,
repoPath,
repoWorkTree,
localGitDir,
attributes,
attributesLocal,
hookPath,
assertLocal,
adjustPath,
relPath,
) where
import Network.URI (uriPath, uriScheme, unEscapeString)
#ifndef mingw32_HOST_OS
import System.Posix.Files
#endif
import Common
import Git.Types
#ifndef mingw32_HOST_OS
import Utility.FileMode
#endif
{- User-visible description of a git repo. -}
repoDescribe :: Repo -> String
repoDescribe Repo { remoteName = Just name } = name
repoDescribe Repo { location = Url url } = show url
repoDescribe Repo { location = Local { worktree = Just dir } } = dir
repoDescribe Repo { location = Local { gitdir = dir } } = dir
repoDescribe Repo { location = LocalUnknown dir } = dir
repoDescribe Repo { location = Unknown } = "UNKNOWN"
{- Location of the repo, either as a path or url. -}
repoLocation :: Repo -> String
repoLocation Repo { location = Url url } = show url
repoLocation Repo { location = Local { worktree = Just dir } } = dir
repoLocation Repo { location = Local { gitdir = dir } } = dir
repoLocation Repo { location = LocalUnknown dir } = dir
repoLocation Repo { location = Unknown } = error "unknown repoLocation"
{- Path to a repository. For non-bare, this is the worktree, for bare,
- it's the gitdir, and for URL repositories, is the path on the remote
- host. -}
repoPath :: Repo -> FilePath
repoPath Repo { location = Url u } = unEscapeString $ uriPath u
repoPath Repo { location = Local { worktree = Just d } } = d
repoPath Repo { location = Local { gitdir = d } } = d
repoPath Repo { location = LocalUnknown dir } = dir
repoPath Repo { location = Unknown } = error "unknown repoPath"
repoWorkTree :: Repo -> Maybe FilePath
repoWorkTree Repo { location = Local { worktree = Just d } } = Just d
repoWorkTree _ = Nothing
{- Path to a local repository's .git directory. -}
localGitDir :: Repo -> FilePath
localGitDir Repo { location = Local { gitdir = d } } = d
localGitDir _ = error "unknown localGitDir"
{- Some code needs to vary between URL and normal repos,
- or bare and non-bare, these functions help with that. -}
repoIsUrl :: Repo -> Bool
repoIsUrl Repo { location = Url _ } = True
repoIsUrl _ = False
repoIsSsh :: Repo -> Bool
repoIsSsh Repo { location = Url url }
| scheme == "ssh:" = True
-- git treats these the same as ssh
| scheme == "git+ssh:" = True
| scheme == "ssh+git:" = True
| otherwise = False
where
scheme = uriScheme url
repoIsSsh _ = False
repoIsHttp :: Repo -> Bool
repoIsHttp Repo { location = Url url }
| uriScheme url == "http:" = True
| uriScheme url == "https:" = True
| otherwise = False
repoIsHttp _ = False
repoIsLocal :: Repo -> Bool
repoIsLocal Repo { location = Local { } } = True
repoIsLocal _ = False
repoIsLocalBare :: Repo -> Bool
repoIsLocalBare Repo { location = Local { worktree = Nothing } } = True
repoIsLocalBare _ = False
repoIsLocalUnknown :: Repo -> Bool
repoIsLocalUnknown Repo { location = LocalUnknown { } } = True
repoIsLocalUnknown _ = False
assertLocal :: Repo -> a -> a
assertLocal repo action
| repoIsUrl repo = error $ unwords
[ "acting on non-local git repo"
, repoDescribe repo
, "not supported"
]
| otherwise = action
{- Path to a repository's gitattributes file. -}
attributes :: Repo -> FilePath
attributes repo
| repoIsLocalBare repo = attributesLocal repo
| otherwise = repoPath repo </> ".gitattributes"
attributesLocal :: Repo -> FilePath
attributesLocal repo = localGitDir repo </> "info" </> "attributes"
{- Path to a given hook script in a repository, only if the hook exists
- and is executable. -}
hookPath :: String -> Repo -> IO (Maybe FilePath)
hookPath script repo = do
let hook = localGitDir repo </> "hooks" </> script
ifM (catchBoolIO $ isexecutable hook)
( return $ Just hook , return Nothing )
where
#if mingw32_HOST_OS
isexecutable f = doesFileExist f
#else
isexecutable f = isExecutable . fileMode <$> getFileStatus f
#endif
{- Makes the path to a local Repo be relative to the cwd. -}
relPath :: Repo -> IO Repo
relPath = adjustPath torel
where
torel p = do
p' <- relPathCwdToFile p
if null p'
then return "."
else return p'
{- Adusts the path to a local Repo using the provided function. -}
adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo
adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do
d' <- f d
w' <- maybe (pure Nothing) (Just <$$> f) w
return $ r
{ location = l
{ gitdir = d'
, worktree = w'
}
}
adjustPath f r@(Repo { location = LocalUnknown d }) = do
d' <- f d
return $ r { location = LocalUnknown d' }
adjustPath _ r = pure r
|
