refactor into smaller modules to untangle git and gpg modules

2 files changed, 98 insertions, 0 deletions

diff --git a/src/Propellor/Git/Config.hs b/src/Propellor/Git/Config.hs
new file mode 100644
index 00000000..97835231
--- /dev/null
+++ b/src/Propellor/Git/Config.hs
@@ -0,0 +1,47 @@
+module Propellor.Git.Config where
+
+import Propellor.Git
+import Utility.Process
+import Utility.Exception
+import Utility.SafeCommand
+import Utility.Monad
+
+import Control.Monad
+
+getGitConfigValue :: String -> IO (Maybe String)
+getGitConfigValue key = do
+	value <- catchMaybeIO $
+		takeWhile (/= '\n')
+			<$> readProcess "git" ["config", key]
+	return $ case value of
+		Just v | not (null v) -> Just v
+		_ -> Nothing
+
+-- `git config --bool propellor.blah` outputs "false" if propellor.blah is unset
+-- i.e. the git convention is that the default value of any git-config setting
+-- is "false".  So we don't need a Maybe Bool here.
+getGitConfigBool :: String -> IO Bool
+getGitConfigBool key = do
+	value <- catchMaybeIO $
+		takeWhile (/= '\n')
+			<$> readProcess "git" ["config", "--bool", key]
+	return $ case value of
+		Just "true" -> True
+		_ -> False
+
+setRepoUrl :: String -> IO ()
+setRepoUrl "" = return ()
+setRepoUrl url = do
+	subcmd <- ifM hasOrigin (pure "set-url", pure "add")
+	void $ boolSystem "git" [Param "remote", Param subcmd, Param "origin", Param url]
+	-- same as --set-upstream-to, except origin branch
+	-- may not have been pulled yet
+	branch <- getCurrentBranch
+	let branchval s = "branch." ++ branch ++ "." ++ s
+	void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"]
+	void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch]
+
+getRepoUrl :: IO (Maybe String)
+getRepoUrl = getM getGitConfigValue urls
+  where
+	urls = ["remote.deploy.url", "remote.origin.url"]
diff --git a/src/Propellor/Git/VerifiedBranch.hs b/src/Propellor/Git/VerifiedBranch.hs
new file mode 100644
index 00000000..a39bc7e9
--- /dev/null
+++ b/src/Propellor/Git/VerifiedBranch.hs
@@ -0,0 +1,51 @@
+module Propellor.Git.VerifiedBranch where
+
+import Propellor.Base
+import Propellor.Git
+import Propellor.Gpg
+import Propellor.PrivData.Paths
+import Utility.FileMode
+
+{- To verify origin branch commit's signature, have to convince gpg
+ - to use our keyring.
+ - While running git log. Which has no way to pass options to gpg.
+ - Argh!
+ -}
+verifyOriginBranch :: String -> IO Bool
+verifyOriginBranch originbranch = do
+	let gpgconf = privDataDir </> "gpg.conf"
+	writeFile gpgconf $ unlines
+		[ " keyring " ++ keyring
+		, "no-auto-check-trustdb"
+		]
+	-- gpg is picky about perms
+	modifyFileMode privDataDir (removeModes otherGroupModes)
+	s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch]
+		(Just [("GNUPGHOME", privDataDir)])
+	nukeFile $ privDataDir </> "trustdb.gpg"
+	nukeFile $ privDataDir </> "pubring.gpg"
+	nukeFile $ privDataDir </> "gpg.conf"
+	return (s == "U\n" || s == "G\n")
+
+-- Returns True if HEAD is changed by fetching and merging from origin.
+fetchOrigin :: IO Bool
+fetchOrigin = do
+	branchref <- getCurrentBranch
+	let originbranch = "origin" </> branchref
+
+	void $ actionMessage "Pull from central git repository" $
+		boolSystem "git" [Param "fetch"]
+
+	oldsha <- getCurrentGitSha1 branchref
+
+	whenM (doesFileExist keyring) $
+		ifM (verifyOriginBranch originbranch)
+			( do
+				putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
+				hFlush stdout
+				void $ boolSystem "git" [Param "merge", Param originbranch]
+			, warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
+			)
+
+	newsha <- getCurrentGitSha1 branchref
+	return $ oldsha /= newsha