2014-11-18 22:39:10 +00:00
module Propellor.Git where
import Propellor
2014-11-18 23:43:53 +00:00
import Propellor.PrivData.Paths
import Propellor.Gpg
2014-11-18 22:39:10 +00:00
import Utility.SafeCommand
2014-11-18 23:43:53 +00:00
import Utility.FileMode
2014-11-18 22:39:10 +00:00
getCurrentBranch :: IO String
getCurrentBranch = takeWhile ( /= '\ n' )
<$> readProcess " git " [ " symbolic-ref " , " --short " , " HEAD " ]
getCurrentGitSha1 :: String -> IO String
getCurrentGitSha1 branchref = 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 ]
getRepoUrl :: IO ( Maybe String )
getRepoUrl = getM get urls
where
urls = [ " remote.deploy.url " , " remote.origin.url " ]
get u = do
v <- catchMaybeIO $
takeWhile ( /= '\ n' )
<$> readProcess " git " [ " config " , u ]
return $ case v of
Just url | not ( null url ) -> Just url
_ -> Nothing
hasOrigin :: IO Bool
2014-11-22 04:22:19 +00:00
hasOrigin = catchDefaultIO False $ do
2014-11-18 22:39:10 +00:00
rs <- lines <$> readProcess " git " [ " remote " ]
return $ " origin " ` elem ` rs
2014-11-18 23:43:53 +00:00
{- 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 " )
2014-11-20 01:00:14 +00:00
-- Returns True if HEAD is changed by fetching and merging from origin.
fetchOrigin :: IO Bool
fetchOrigin = do
branchref <- getCurrentBranch
let originbranch = " origin " </> branchref
2014-11-20 01:48:48 +00:00
void $ actionMessage " Pull from central git repository " $
boolSystem " git " [ Param " fetch " ]
2014-11-20 01:00:14 +00:00
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