summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--propellor.cabal2
-rw-r--r--src/Propellor/CmdLine.hs1
-rw-r--r--src/Propellor/Git.hs81
-rw-r--r--src/Propellor/Git/Config.hs47
-rw-r--r--src/Propellor/Git/VerifiedBranch.hs51
-rw-r--r--src/Propellor/Gpg.hs15
-rw-r--r--src/Propellor/Property/PropellorRepo.hs2
-rw-r--r--src/Propellor/Spin.hs1
8 files changed, 110 insertions, 90 deletions
diff --git a/propellor.cabal b/propellor.cabal
index 14821441..fbdfb86d 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -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 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