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
|
{- git repository handling
-
- This is written to be completely independant of git-annex and should be
- suitable for other uses.
-
- Copyright 2010, 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Git (
Repo(..),
Ref(..),
Branch,
Sha,
Tag,
repoIsUrl,
repoIsSsh,
repoIsHttp,
repoIsLocalBare,
repoDescribe,
repoLocation,
workTree,
gitDir,
configTrue,
attributes,
hookPath,
assertLocal,
) where
import qualified Data.Map as M
import Data.Char
import Network.URI (uriPath, uriScheme, unEscapeString)
import System.Directory
import System.Posix.Files
import Common
import Git.Types
import Utility.FileMode
{- 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 = Dir 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 = Dir dir } = dir
repoLocation Repo { location = Unknown } = undefined
{- 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
configAvail ::Repo -> Bool
configAvail Repo { config = c } = c /= M.empty
repoIsLocalBare :: Repo -> Bool
repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r
repoIsLocalBare _ = False
assertLocal :: Repo -> a -> a
assertLocal repo action =
if not $ repoIsUrl repo
then action
else error $ "acting on non-local git repo " ++ repoDescribe repo ++
" not supported"
configBare :: Repo -> Bool
configBare repo = maybe unknown (fromMaybe False . configTrue) $
M.lookup "core.bare" $ config repo
where
unknown = error $ "it is not known if git repo " ++
repoDescribe repo ++
" is a bare repository; config not read"
{- Path to a repository's gitattributes file. -}
attributes :: Repo -> FilePath
attributes repo
| configBare repo = workTree repo ++ "/info/.gitattributes"
| otherwise = workTree repo ++ "/.gitattributes"
{- Path to a repository's .git directory. -}
gitDir :: Repo -> FilePath
gitDir repo
| configBare repo = workTree repo
| otherwise = workTree repo </> ".git"
{- 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 = gitDir repo </> "hooks" </> script
e <- doesFileExist hook
if e
then do
m <- fileMode <$> getFileStatus hook
return $ if isExecutable m then Just hook else Nothing
else return Nothing
{- Path to a repository's --work-tree, that is, its top.
-
- Note that for URL repositories, this is the path on the remote host. -}
workTree :: Repo -> FilePath
workTree Repo { location = Url u } = unEscapeString $ uriPath u
workTree Repo { location = Dir d } = d
workTree Repo { location = Unknown } = undefined
{- Checks if a string from git config is a true value. -}
configTrue :: String -> Maybe Bool
configTrue s
| s' == "true" = Just True
| s' == "false" = Just False
| otherwise = Nothing
where
s' = map toLower s
|
