summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog8
-rw-r--r--propellor.cabal4
-rw-r--r--src/Propellor/CmdLine.hs1
-rw-r--r--src/Propellor/Git.hs94
-rw-r--r--src/Propellor/Git/Config.hs47
-rw-r--r--src/Propellor/Git/VerifiedBranch.hs51
-rw-r--r--src/Propellor/Gpg.hs11
-rw-r--r--src/Propellor/Property/PropellorRepo.hs2
-rw-r--r--src/Propellor/Spin.hs1
9 files changed, 122 insertions, 97 deletions
diff --git a/debian/changelog b/debian/changelog
index 314ba037..997c3df3 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,14 +1,14 @@
-propellor (2.15.2) UNRELEASED; urgency=medium
+propellor (2.15.2) unstable; urgency=medium
- * Added GNUPGBIN environment variable to control the command run for gpg.
- Allows eg, GNUPGBIN=gpg2
+ * Added GNUPGBIN environment variable or git.program git config
+ to control the command run for gpg. Allows eg, GNUPGBIN=gpg2
Thanks, FĂ©lix Sipma.
* Bootstrap apt-get installs run with deconf noninteractive frontend.
* spin --via: Avoid committing on relay host.
* Postfix: Add service property to enable/disable services in master.cf.
* Added Munin module, contributed by Jelmer Vernooij.
- -- Joey Hess <id@joeyh.name> Wed, 30 Dec 2015 15:01:19 -0400
+ -- Joey Hess <id@joeyh.name> Sun, 03 Jan 2016 16:56:26 -0400
propellor (2.15.1) unstable; urgency=medium
diff --git a/propellor.cabal b/propellor.cabal
index 14821441..42270819 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 2.15.1
+Version: 2.15.2
Cabal-Version: >= 1.8
License: BSD3
Maintainer: Joey Hess <id@joeyh.name>
@@ -148,6 +148,8 @@ Library
Other-Modules:
Propellor.Bootstrap
Propellor.Git
+ Propellor.Git.Config
+ Propellor.Git.VerifiedBranch
Propellor.Gpg
Propellor.Spin
Propellor.Ssh
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 a2f5aef2..5a16b3db 100644
--- a/src/Propellor/Git.hs
+++ b/src/Propellor/Git.hs
@@ -1,60 +1,22 @@
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')
+getCurrentBranch = takeWhile (/= '\n')
<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
getCurrentBranchRef :: IO String
-getCurrentBranchRef = takeWhile (/= '\n')
+getCurrentBranchRef = takeWhile (/= '\n')
<$> readProcess "git" ["symbolic-ref", "HEAD"]
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]
-
-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
-
-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"]
@@ -62,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 4c7ccc9c..d3550e88 100644
--- a/src/Propellor/Gpg.hs
+++ b/src/Propellor/Gpg.hs
@@ -13,6 +13,7 @@ import Prelude
import Propellor.PrivData.Paths
import Propellor.Message
+import Propellor.Git.Config
import Utility.SafeCommand
import Utility.Process
import Utility.Monad
@@ -21,11 +22,15 @@ import Utility.Tmp
import Utility.FileSystemEncoding
import Utility.Env
-getGpgBin :: IO String
-getGpgBin = getEnvDefault "GNUPGBIN" "gpg"
-
type KeyId = String
+getGpgBin :: IO String
+getGpgBin = do
+ gitGpgBin <- getGitConfigValue "gpg.program"
+ case gitGpgBin of
+ Nothing -> getEnvDefault "GNUPGBIN" "gpg"
+ Just b -> return b
+
keyring :: FilePath
keyring = privDataDir </> "keyring.gpg"
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