Git.hs

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 qualified Propellor.Property.Systemd as Systemd

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"
		-- safe.directory configuration is needed by git for
		-- git-daemon to serve repositories owned by any other user.
		-- But since git-daemon is explicitly configured which
		-- repositories to operate on, it adds no security.
		, "-c", "safe.directory=*"
		, "daemon"
		, "--inetd"
		, "--export-all"
		, "--base-path=" ++ exportdir
		, exportdir
		]

-- | Exports all git repos in a directory (that user nobody can read)
-- using git-daemon, run as a systemd service.
daemonService :: FilePath -> Property Linux
daemonService exportdir = 
	servicefile `onChange` 
		Systemd.running "git-daemon"
  where
	servicefile = "/etc/systemd/system/git-daemon.service" `hasContent`
		[ "[Unit]"
		, "Description=Git Daemon"
		, "Documentation=man:git-daemon(1)"
		, ""
		, " [Service]"
		-- safe.directory configuration is needed by git for
		-- git-daemon to serve repositories owned by any other user.
		-- But since git-daemon is explicitly configured which
		-- repositories to operate on, it adds no security.
		, "Environment=GIT_CONFIG_COUNT='1' GIT_CONFIG_KEY_0='safe.directory' GIT_CONFIG_VALUE_0=\"*\""
		, "ExecStart=/usr/bin/git daemon --export-all --base-path=" ++ exportdir ++ " " ++ exportdir
		, "DynamicUser=yes"
		, ""
		, "[Install]"
		, "WantedBy=multi-user.target"
		]
		`describe` "git-daemon systemd service file"

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)