summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Git.hs
blob: a0ed4f0293bb0cafa0cad7bf7c525f0d4400c298 (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
module Propellor.Property.Git where

import Propellor.Base
import Propellor.Property.File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service

import Data.List

-- | Exports all git repos in a directory (that user nobody can read)
-- using git-daemon, run from inetd.
--
-- Note that reverting this property does not remove or stop inetd.
daemonRunning :: FilePath -> RevertableProperty DebianLike DebianLike
daemonRunning exportdir = setup <!> unsetup
  where
	setup = containsLine conf (mkl "tcp4")
		`requires`
		containsLine conf (mkl "tcp6")
		`requires`
		dirExists exportdir
		`requires`
		Apt.serviceInstalledRunning "openbsd-inetd"
		`onChange`
		Service.reloaded "openbsd-inetd"
		`describe` ("git-daemon exporting " ++ exportdir)
	unsetup = lacksLine conf (mkl "tcp4")
		`requires`
		lacksLine conf (mkl "tcp6")
		`onChange`
		Service.reloaded "openbsd-inetd"

	conf = "/etc/inetd.conf"

	mkl tcpv = intercalate "\t"
		[ "git"
		, "stream"
		, tcpv
		, "nowait"
		, "nobody"
		, "/usr/bin/git"
		, "git"
		, "daemon"
		, "--inetd"
		, "--export-all"
		, "--base-path=" ++ exportdir
		, exportdir
		]

installed :: Property DebianLike
installed = Apt.installed ["git"]

type RepoUrl = String

type Branch = String

-- | Specified git repository is cloned to the specified directory.
--
-- If the directory exists with some other content (either a non-git
-- repository, or a git repository cloned from some other location),
-- it will be recursively deleted first.
--
-- A branch can be specified, to check out.
--
-- Does not make subsequent changes be pulled into the repository after
-- it's cloned.
cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike
cloned owner url dir mbranch = check originurl go
	`requires` installed
  where
	desc = "git cloned " ++ url ++ " to " ++ dir
	gitconfig = dir </> ".git/config"
	originurl = ifM (doesFileExist gitconfig)
		( do
			v <- catchDefaultIO Nothing $ headMaybe . lines <$>
				readProcess "git" ["config", "--file", gitconfig, "remote.origin.url"]
			return (v /= Just url)
		, return True
		)
	go :: Property DebianLike
	go = property' desc $ \w -> do
		liftIO $ do
			whenM (doesDirectoryExist dir) $
				removeDirectoryRecursive dir
			createDirectoryIfMissing True (takeDirectory dir)
		ensureProperty w $ userScriptProperty owner (catMaybes checkoutcmds)
			`assume` MadeChange
	checkoutcmds = 
		-- The </dev/null fixes an intermittent
		-- "fatal: read error: Bad file descriptor"
		-- when run across ssh with propellor --spin
		[ Just $ "git clone " ++ shellEscape url ++ " " ++ shellEscape dir ++ " < /dev/null"
		, Just $ "cd " ++ shellEscape dir
		, ("git checkout " ++) <$> mbranch
		-- In case this repo is exposted via the web,
		-- although the hook to do this ongoing is not
		-- installed here.
		, Just "git update-server-info"
		]

-- | Specified git repository is cloned to the specified directory,
-- and any new commits are pulled into it each time this property runs.
pulled :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike
pulled owner url dir mbranch = go
	`requires` cloned owner url dir mbranch
	`describe` desc
  where
	desc = "git pulled " ++ url ++ " to " ++ dir
	go = userScriptProperty owner
		[ "cd " ++ shellEscape dir
		, "git pull"
		]
		`changesFileContent` (dir </> ".git" </> "FETCH_HEAD")

isGitDir :: FilePath -> IO Bool
isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", dir])

data GitShared = Shared Group | SharedAll | NotShared

-- | Sets up a new, empty bare git repository.
bareRepo :: FilePath -> User -> GitShared -> Property UnixLike
bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $
	dirExists repo : case gitshared of
		NotShared ->
			[ ownerGroup repo user (userGroup user)
			, userScriptProperty user ["git init --bare --shared=false " ++ shellEscape repo]
				`assume` MadeChange
			]
		SharedAll ->
			[ ownerGroup repo user (userGroup user)
			, userScriptProperty user ["git init --bare --shared=all " ++ shellEscape repo]
				`assume` MadeChange
			]
		Shared group' ->
			[ ownerGroup repo user group'
			, userScriptProperty user ["git init --bare --shared=group " ++ shellEscape repo]
				`assume` MadeChange
			]
  where
	isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo'])

-- | Set a key value pair in a git repo's configuration.
repoConfigured :: FilePath -> (String, String) -> Property UnixLike
repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $
	userScriptProperty (User "root")
		[ "cd " ++ repo
		, "git config " ++ key ++ " " ++ value
		]
		`assume` MadeChange
		`describe` desc
  where
	alreadyconfigured = do
		vs <- getRepoConfig repo key
		return $ value `elem` vs
	desc = "git repo at " ++ repo  ++ " config setting " ++ key ++ " set to " ++ value

-- | Gets the value that a key is set to in a git repo's configuration.
getRepoConfig :: FilePath -> String -> IO [String]
getRepoConfig repo key = catchDefaultIO [] $
	lines <$> readProcess "git" ["-C", repo, "config", key]

-- | Whether a repo accepts non-fast-forward pushes.
repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike
repoAcceptsNonFFs repo = accepts <!> refuses
  where
	accepts = repoConfigured repo ("receive.denyNonFastForwards", "false")
		`describe` desc "accepts"
	refuses = repoConfigured repo ("receive.denyNonFastForwards", "true")
		`describe` desc "rejects"
	desc s = "git repo " ++ repo ++ " " ++ s ++ " non-fast-forward pushes"

-- | Sets a bare repository's default branch, which will be checked out
-- when cloning it.
bareRepoDefaultBranch :: FilePath -> String -> Property UnixLike
bareRepoDefaultBranch repo branch =
	userScriptProperty (User "root")
		[ "cd " ++ repo
		, "git symbolic-ref HEAD refs/heads/" ++ branch
		]
	`changesFileContent` (repo </> "HEAD")
	`describe` ("git repo at " ++ repo ++ " has default branch " ++ branch)