summaryrefslogtreecommitdiff
path: root/src/Propellor/Git.hs
diff options
context:
space:
mode:
authorJoey Hess2016-01-03 16:56:00 -0400
committerJoey Hess2016-01-03 16:56:00 -0400
commitf86804fa27a2cf5b1972b14ab41e81edb85ad661 (patch)
tree11753dde33d0e6dd85feae84a727846fb6a3d088 /src/Propellor/Git.hs
parentb13e3f8d55c1b74123186c3178922b0809367f76 (diff)
refactor into smaller modules to untangle git and gpg modules
Diffstat (limited to 'src/Propellor/Git.hs')
-rw-r--r--src/Propellor/Git.hs81
1 files changed, 4 insertions, 77 deletions
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