From f86804fa27a2cf5b1972b14ab41e81edb85ad661 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 3 Jan 2016 16:56:00 -0400 Subject: refactor into smaller modules to untangle git and gpg modules --- src/Propellor/CmdLine.hs | 1 + src/Propellor/Git.hs | 81 ++------------------------------- src/Propellor/Git/Config.hs | 47 +++++++++++++++++++ src/Propellor/Git/VerifiedBranch.hs | 51 +++++++++++++++++++++ src/Propellor/Gpg.hs | 15 ++---- src/Propellor/Property/PropellorRepo.hs | 2 +- src/Propellor/Spin.hs | 1 + 7 files changed, 108 insertions(+), 90 deletions(-) create mode 100644 src/Propellor/Git/Config.hs create mode 100644 src/Propellor/Git/VerifiedBranch.hs (limited to 'src/Propellor') diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index 1e61adc8..6d9db8bf 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -12,6 +12,7 @@ import Network.Socket import Propellor.Base import Propellor.Gpg import Propellor.Git +import Propellor.Git.VerifiedBranch import Propellor.Bootstrap import Propellor.Spin import Propellor.Types.CmdLine diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs index 3ad8e0f4..5a16b3db 100644 --- a/src/Propellor/Git.hs +++ b/src/Propellor/Git.hs @@ -1,9 +1,9 @@ module Propellor.Git where -import Propellor.Base -import Propellor.PrivData.Paths -import Propellor.Gpg -import Utility.FileMode +import Utility.Process +import Utility.Exception + +import System.Directory getCurrentBranch :: IO String getCurrentBranch = takeWhile (/= '\n') @@ -17,35 +17,6 @@ getCurrentGitSha1 :: String -> IO String getCurrentGitSha1 branchref = takeWhile (/= '\n') <$> readProcess "git" ["show-ref", "--hash", branchref] -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] - --- `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 - -getRepoUrl :: IO (Maybe String) -getRepoUrl = getM getGitConfigValue urls - where - urls = ["remote.deploy.url", "remote.origin.url"] - hasOrigin :: IO Bool hasOrigin = catchDefaultIO False $ do rs <- lines <$> readProcess "git" ["remote"] @@ -53,47 +24,3 @@ hasOrigin = catchDefaultIO False $ do hasGitRepo :: IO Bool hasGitRepo = doesFileExist ".git/HEAD" - -{- 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 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 diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs index 0fd8c9ce..d3550e88 100644 --- a/src/Propellor/Gpg.hs +++ b/src/Propellor/Gpg.hs @@ -13,7 +13,7 @@ import Prelude import Propellor.PrivData.Paths import Propellor.Message -import Utility.Exception +import Propellor.Git.Config import Utility.SafeCommand import Utility.Process import Utility.Monad @@ -22,6 +22,8 @@ import Utility.Tmp import Utility.FileSystemEncoding import Utility.Env +type KeyId = String + getGpgBin :: IO String getGpgBin = do gitGpgBin <- getGitConfigValue "gpg.program" @@ -29,8 +31,6 @@ getGpgBin = do Nothing -> getEnvDefault "GNUPGBIN" "gpg" Just b -> return b -type KeyId = String - keyring :: FilePath keyring = privDataDir "keyring.gpg" @@ -118,15 +118,6 @@ reencryptPrivData = ifM (doesFileExist privDataFile) , return True ) -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 - gitAdd :: FilePath -> IO Bool gitAdd f = boolSystem "git" [ Param "add" diff --git a/src/Propellor/Property/PropellorRepo.hs b/src/Propellor/Property/PropellorRepo.hs index d4c4abe5..d4fc089a 100644 --- a/src/Propellor/Property/PropellorRepo.hs +++ b/src/Propellor/Property/PropellorRepo.hs @@ -1,7 +1,7 @@ module Propellor.Property.PropellorRepo where import Propellor.Base -import Propellor.Git +import Propellor.Git.Config -- | Sets the url to use as the origin of propellor's git repository. -- diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index bda146cc..6246b04f 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -21,6 +21,7 @@ import Propellor.Base import Propellor.Protocol import Propellor.PrivData.Paths import Propellor.Git +import Propellor.Git.Config import Propellor.Ssh import Propellor.Gpg import Propellor.Bootstrap -- cgit v1.2.3