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 :: FilePath -> RevertableProperty DebianLike DebianLike
daemonRunning FilePath
exportdir = Property DebianLike
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property DebianLike
unsetup
  where
	setup :: CombinedType
  (CombinedType
     (CombinedType (Property UnixLike) (Property UnixLike))
     (Property DebianLike))
  (Property DebianLike)
setup = FilePath -> FilePath -> Property UnixLike
containsLine FilePath
conf (FilePath -> FilePath
mkl FilePath
"tcp4")
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
		FilePath -> FilePath -> Property UnixLike
containsLine FilePath
conf (FilePath -> FilePath
mkl FilePath
"tcp6")
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
		FilePath -> Property UnixLike
dirExists FilePath
exportdir
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
		FilePath -> Property DebianLike
Apt.serviceInstalledRunning FilePath
"openbsd-inetd"
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange`
		FilePath -> Property DebianLike
Service.reloaded FilePath
"openbsd-inetd"
		forall p. IsProp p => p -> FilePath -> p
`describe` (FilePath
"git-daemon exporting " forall a. [a] -> [a] -> [a]
++ FilePath
exportdir)
	unsetup :: CombinedType (Property UnixLike) (Property DebianLike)
unsetup = FilePath -> FilePath -> Property UnixLike
lacksLine FilePath
conf (FilePath -> FilePath
mkl FilePath
"tcp4")
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires`
		FilePath -> FilePath -> Property UnixLike
lacksLine FilePath
conf (FilePath -> FilePath
mkl FilePath
"tcp6")
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange`
		FilePath -> Property DebianLike
Service.reloaded FilePath
"openbsd-inetd"

	conf :: FilePath
conf = FilePath
"/etc/inetd.conf"

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

installed :: Property DebianLike
installed :: Property DebianLike
installed = [FilePath] -> Property DebianLike
Apt.installed [FilePath
"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 :: User
-> FilePath -> FilePath -> Maybe FilePath -> Property DebianLike
cloned User
owner FilePath
url FilePath
dir Maybe FilePath
mbranch = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check IO Bool
originurl Property DebianLike
go
	forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
  where
	desc :: FilePath
desc = FilePath
"git cloned " forall a. [a] -> [a] -> [a]
++ FilePath
url forall a. [a] -> [a] -> [a]
++ FilePath
" to " forall a. [a] -> [a] -> [a]
++ FilePath
dir
	gitconfig :: FilePath
gitconfig = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
".git/config"
	originurl :: IO Bool
originurl = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
doesFileExist FilePath
gitconfig)
		( do
			Maybe FilePath
v <- forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
headMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
				FilePath -> [FilePath] -> IO FilePath
readProcess FilePath
"git" [FilePath
"config", FilePath
"--file", FilePath
gitconfig, FilePath
"remote.origin.url"]
			forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath
v forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just FilePath
url)
		, forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
		)
	go :: Property DebianLike
	go :: Property DebianLike
go = forall {k} (metatypes :: k).
SingI metatypes =>
FilePath
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' FilePath
desc forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
			forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
doesDirectoryExist FilePath
dir) forall a b. (a -> b) -> a -> b
$
				FilePath -> IO ()
removeDirectoryRecursive FilePath
dir
			Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
dir)
		forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$ User -> [FilePath] -> UncheckedProperty UnixLike
userScriptProperty User
owner (forall a. [Maybe a] -> [a]
catMaybes [Maybe FilePath]
checkoutcmds)
			forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	checkoutcmds :: [Maybe FilePath]
checkoutcmds = 
		-- The </dev/null fixes an intermittent
		-- "fatal: read error: Bad file descriptor"
		-- when run across ssh with propellor --spin
		[ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FilePath
"git clone " forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
shellEscape FilePath
url forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
shellEscape FilePath
dir forall a. [a] -> [a] -> [a]
++ FilePath
" < /dev/null"
		, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FilePath
"cd " forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
shellEscape FilePath
dir
		, (FilePath
"git checkout " forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
mbranch
		-- In case this repo is exposted via the web,
		-- although the hook to do this ongoing is not
		-- installed here.
		, forall a. a -> Maybe a
Just FilePath
"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 :: User
-> FilePath -> FilePath -> Maybe FilePath -> Property DebianLike
pulled User
owner FilePath
url FilePath
dir Maybe FilePath
mbranch = Property UnixLike
go
	forall x y. Combines x y => x -> y -> CombinedType x y
`requires` User
-> FilePath -> FilePath -> Maybe FilePath -> Property DebianLike
cloned User
owner FilePath
url FilePath
dir Maybe FilePath
mbranch
	forall p. IsProp p => p -> FilePath -> p
`describe` FilePath
desc
  where
	desc :: FilePath
desc = FilePath
"git pulled " forall a. [a] -> [a] -> [a]
++ FilePath
url forall a. [a] -> [a] -> [a]
++ FilePath
" to " forall a. [a] -> [a] -> [a]
++ FilePath
dir
	go :: Property UnixLike
go = User -> [FilePath] -> UncheckedProperty UnixLike
userScriptProperty User
owner
		[ FilePath
"cd " forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
shellEscape FilePath
dir
		, FilePath
"git pull"
		]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> FilePath -> Property i
`changesFileContent` (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
".git" FilePath -> FilePath -> FilePath
</> FilePath
"FETCH_HEAD")

isGitDir :: FilePath -> IO Bool
isGitDir :: FilePath -> IO Bool
isGitDir FilePath
dir = forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (FilePath -> [FilePath] -> IO FilePath
readProcess FilePath
"git" [FilePath
"rev-parse", FilePath
"--resolve-git-dir", FilePath
dir])

data GitShared = Shared Group | SharedAll | NotShared

-- | Sets up a new, empty bare git repository.
bareRepo :: FilePath -> User -> GitShared -> Property UnixLike
bareRepo :: FilePath -> User -> GitShared -> Property UnixLike
bareRepo FilePath
repo User
user GitShared
gitshared = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (FilePath -> IO Bool
isRepo FilePath
repo) forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
SingI metatypes =>
FilePath
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
propertyList (FilePath
"git repo: " forall a. [a] -> [a] -> [a]
++ FilePath
repo) forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
[Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
toProps forall a b. (a -> b) -> a -> b
$
	FilePath -> Property UnixLike
dirExists FilePath
repo forall a. a -> [a] -> [a]
: case GitShared
gitshared of
		GitShared
NotShared ->
			[ FilePath -> User -> Group -> Property UnixLike
ownerGroup FilePath
repo User
user (User -> Group
userGroup User
user)
			, User -> [FilePath] -> UncheckedProperty UnixLike
userScriptProperty User
user [FilePath
"git init --bare --shared=false " forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
shellEscape FilePath
repo]
				forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
			]
		GitShared
SharedAll ->
			[ FilePath -> User -> Group -> Property UnixLike
ownerGroup FilePath
repo User
user (User -> Group
userGroup User
user)
			, User -> [FilePath] -> UncheckedProperty UnixLike
userScriptProperty User
user [FilePath
"git init --bare --shared=all " forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
shellEscape FilePath
repo]
				forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
			]
		Shared Group
group' ->
			[ FilePath -> User -> Group -> Property UnixLike
ownerGroup FilePath
repo User
user Group
group'
			, User -> [FilePath] -> UncheckedProperty UnixLike
userScriptProperty User
user [FilePath
"git init --bare --shared=group " forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
shellEscape FilePath
repo]
				forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
			]
  where
	isRepo :: FilePath -> IO Bool
isRepo FilePath
repo' = forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (FilePath -> [FilePath] -> IO FilePath
readProcess FilePath
"git" [FilePath
"rev-parse", FilePath
"--resolve-git-dir", FilePath
repo'])

-- | Set a key value pair in a git repo's configuration.
repoConfigured :: FilePath -> (String, String) -> Property UnixLike
FilePath
repo repoConfigured :: FilePath -> (FilePath, FilePath) -> Property UnixLike
`repoConfigured` (FilePath
key, FilePath
value) = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
alreadyconfigured) forall a b. (a -> b) -> a -> b
$
	User -> [FilePath] -> UncheckedProperty UnixLike
userScriptProperty (FilePath -> User
User FilePath
"root")
		[ FilePath
"cd " forall a. [a] -> [a] -> [a]
++ FilePath
repo
		, FilePath
"git config " forall a. [a] -> [a] -> [a]
++ FilePath
key forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ FilePath
value
		]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
		forall p. IsProp p => p -> FilePath -> p
`describe` FilePath
desc
  where
	alreadyconfigured :: IO Bool
alreadyconfigured = do
		[FilePath]
vs <- FilePath -> FilePath -> IO [FilePath]
getRepoConfig FilePath
repo FilePath
key
		forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath
value forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
vs
	desc :: FilePath
desc = FilePath
"git repo at " forall a. [a] -> [a] -> [a]
++ FilePath
repo  forall a. [a] -> [a] -> [a]
++ FilePath
" config setting " forall a. [a] -> [a] -> [a]
++ FilePath
key forall a. [a] -> [a] -> [a]
++ FilePath
" set to " forall a. [a] -> [a] -> [a]
++ FilePath
value

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

-- | Whether a repo accepts non-fast-forward pushes.
repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike
repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike
repoAcceptsNonFFs FilePath
repo = Property UnixLike
accepts forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property UnixLike
refuses
  where
	accepts :: Property UnixLike
accepts = FilePath -> (FilePath, FilePath) -> Property UnixLike
repoConfigured FilePath
repo (FilePath
"receive.denyNonFastForwards", FilePath
"false")
		forall p. IsProp p => p -> FilePath -> p
`describe` FilePath -> FilePath
desc FilePath
"accepts"
	refuses :: Property UnixLike
refuses = FilePath -> (FilePath, FilePath) -> Property UnixLike
repoConfigured FilePath
repo (FilePath
"receive.denyNonFastForwards", FilePath
"true")
		forall p. IsProp p => p -> FilePath -> p
`describe` FilePath -> FilePath
desc FilePath
"rejects"
	desc :: FilePath -> FilePath
desc FilePath
s = FilePath
"git repo " forall a. [a] -> [a] -> [a]
++ FilePath
repo forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ FilePath
s forall a. [a] -> [a] -> [a]
++ FilePath
" 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 :: FilePath -> FilePath -> Property UnixLike
bareRepoDefaultBranch FilePath
repo FilePath
branch =
	User -> [FilePath] -> UncheckedProperty UnixLike
userScriptProperty (FilePath -> User
User FilePath
"root")
		[ FilePath
"cd " forall a. [a] -> [a] -> [a]
++ FilePath
repo
		, FilePath
"git symbolic-ref HEAD refs/heads/" forall a. [a] -> [a] -> [a]
++ FilePath
branch
		]
	forall (p :: * -> *) i.
Checkable p i =>
p i -> FilePath -> Property i
`changesFileContent` (FilePath
repo FilePath -> FilePath -> FilePath
</> FilePath
"HEAD")
	forall p. IsProp p => p -> FilePath -> p
`describe` (FilePath
"git repo at " forall a. [a] -> [a] -> [a]
++ FilePath
repo forall a. [a] -> [a] -> [a]
++ FilePath
" has default branch " forall a. [a] -> [a] -> [a]
++ FilePath
branch)