{-# Language ScopedTypeVariables #-}
module Propellor.Spin (
commitSpin,
spin,
spin',
update,
gitPushHelper,
mergeSpin,
) where
import Data.List
import System.Exit
import System.PosixCompat
import System.Posix.IO
import System.Posix.Directory
import Control.Concurrent.Async
import qualified Data.ByteString as B
import qualified Data.Set as S
import Network.Socket (getAddrInfo, defaultHints, AddrInfo(..), AddrInfoFlag(..), SockAddr)
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
import Propellor.Types.CmdLine
import Propellor.Types.Info
import Propellor.Property.PropellorRepo (OriginUrl(..))
import qualified Propellor.Shim as Shim
import Utility.FileMode
import Utility.SafeCommand
import Utility.Process.NonConcurrent
commitSpin :: IO ()
commitSpin = do
spinBranch <- getGitConfigValue "propellor.spin-branch"
case spinBranch of
Nothing -> return ()
Just b -> do
currentBranch <- getCurrentBranch
when (b /= currentBranch) $
error ("spin aborted: check out "
++ b ++ " branch first")
noDirtySpin <- getGitConfigBool "propellor.forbid-dirty-spin"
when noDirtySpin $ do
status <- takeWhile (/= '\n')
<$> readProcess "git" ["status", "--porcelain"]
when (not . null $ status) $
error "spin aborted: commit changes first"
void $ actionMessage "Git commit" $
gitCommit (Just spinCommitMessage)
[Param "--allow-empty", Param "-a"]
whenM hasOrigin $
void $ actionMessage "Push to central git repository" $
boolSystemNonConcurrent "git" [Param "push"]
spin :: Maybe HostName -> HostName -> Host -> IO ()
spin = spin' Nothing
spin' :: Maybe PrivMap -> Maybe HostName -> HostName -> Host -> IO ()
spin' mprivdata relay target hst = do
cacheparams <- if viarelay
then pure ["-A"]
else toCommand <$> sshCachingParams hn
when viarelay $
void $ boolSystem "ssh-add" []
sshtarget <- ("root@" ++) <$> case relay of
Just r -> pure r
Nothing -> getSshTarget target hst
updateServer target relay hst
(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd])
(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd])
=<< getprivdata
unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
giveup "remote propellor failed"
where
hn = fromMaybe target relay
sys = case fromInfo (hostInfo hst) of
InfoVal o -> Just o
NoInfoVal -> Nothing
bootstrapper = case fromInfo (hostInfo hst) of
NoInfoVal -> defaultBootstrapper
InfoVal bs -> bs
relaying = relay == Just target
viarelay = isJust relay && not relaying
probecmd = intercalate " ; "
[ "if [ ! -d " ++ localdir ++ "/.git ]"
, "then (" ++ intercalate " && "
[ installGitCommand sys
, "echo " ++ toMarked statusMarker (show NeedGitClone)
] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled)
, "else " ++ updatecmd
, "fi"
]
updatecmd = intercalate " && "
[ "cd " ++ localdir
, bootstrapPropellorCommand bootstrapper sys
, if viarelay
then "./propellor --continue " ++
shellEscape (show (Relay target))
else "./propellor --boot " ++ target
]
runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd
cmd = "--serialized " ++ shellEscape (show cmdline)
cmdline
| viarelay = Spin [target] (Just target)
| otherwise = SimpleRun target
getprivdata = case mprivdata of
Nothing
| relaying -> do
let f = privDataRelay hn
d <- readPrivDataFile f
nukeFile f
return d
| otherwise ->
filterPrivData hst <$> decryptPrivData
Just pd -> pure pd
getSshTarget :: HostName -> Host -> IO String
getSshTarget target hst
| null configips = return target
| otherwise = go =<< tryIO (dnslookup target)
where
go (Left e) = useip (show e)
go (Right addrinfos) = do
configaddrinfos <- catMaybes <$> mapM iptoaddr configips
if any (`elem` configaddrinfos) (map addrAddress addrinfos)
then return target
else useip ("DNS lookup did not return any of the expected addresses " ++ show configips)
dnslookup h = getAddrInfo (Just $ defaultHints { addrFlags = [AI_CANONNAME] }) (Just h) Nothing
iptoaddr :: String -> IO (Maybe SockAddr)
iptoaddr ip = catchDefaultIO Nothing $ headMaybe . map addrAddress
<$> getAddrInfo (Just $ defaultHints { addrFlags = [AI_NUMERICHOST] }) (Just ip) Nothing
useip why = case headMaybe configips of
Nothing -> return target
Just ip -> do
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
if s == target
then return target
else do
warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead."
return ip
configips = map val $ mapMaybe getIPAddr $
S.toList $ getDnsInfo $ hostInfo hst
update :: Maybe HostName -> IO ()
update forhost = do
whenM hasGitRepo $
req NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
createDirectoryIfMissing True (takeDirectory privfile)
req NeedPrivData privDataMarker $
writeFileProtected privfile
whenM hasGitRepo $
gitPullFromUpdateServer
where
privfile = maybe privDataLocal privDataRelay forhost
updateServer
:: HostName
-> Maybe HostName
-> Host
-> CreateProcess
-> CreateProcess
-> PrivMap
-> IO ()
updateServer target relay hst connect haveprecompiled privdata = do
(Just toh, Just fromh, _, pid) <- createProcessNonConcurrent $ connect
{ std_in = CreatePipe
, std_out = CreatePipe
}
go (toh, fromh)
forceSuccessProcess' connect =<< waitForProcessNonConcurrent pid
where
hn = fromMaybe target relay
go (toh, fromh) = do
let loop = go (toh, fromh)
let restart = updateServer hn relay hst connect haveprecompiled privdata
let done = return ()
v <- maybe Nothing readish <$> getMarked fromh statusMarker
case v of
(Just NeedRepoUrl) -> do
sendRepoUrl hst toh
loop
(Just NeedPrivData) -> do
sendPrivData hn toh privdata
loop
(Just NeedGitClone) -> do
hClose toh
hClose fromh
sendGitClone hn
restart
(Just NeedPrecompiled) -> do
hClose toh
hClose fromh
sendPrecompiled hn
updateServer hn relay hst haveprecompiled (error "loop") privdata
(Just NeedGitPush) -> do
sendGitUpdate hn fromh toh
hClose fromh
hClose toh
done
Nothing -> done
sendRepoUrl :: Host -> Handle -> IO ()
sendRepoUrl hst toh = sendMarked toh repoUrlMarker =<< geturl
where
geturl = case fromInfoVal (fromInfo (hostInfo hst)) of
Nothing -> fromMaybe "" <$> getRepoUrl
Just (OriginUrl u) -> return u
sendPrivData :: HostName -> Handle -> PrivMap -> IO ()
sendPrivData hn toh privdata = void $ actionMessage msg $ do
sendMarked toh privDataMarker d
return True
where
msg = "Sending privdata (" ++ show (length d) ++ " bytes) to " ++ hn
d = show privdata
sendGitUpdate :: HostName -> Handle -> Handle -> IO ()
sendGitUpdate hn fromh toh =
void $ actionMessage ("Sending git update to " ++ hn) $ do
sendMarked toh gitPushMarker ""
(Nothing, Nothing, Nothing, h) <- createProcess p
(==) ExitSuccess <$> waitForProcess h
where
p = (proc "git" ["upload-pack", "."])
{ std_in = UseHandle fromh
, std_out = UseHandle toh
}
sendGitClone :: HostName -> IO ()
sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
branch <- getCurrentBranch
cacheparams <- sshCachingParams hn
withTmpFile "propellor.git" $ \tmp _ -> allM id
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
, boolSystemNonConcurrent "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
, boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch]
]
where
remotebundle = "/usr/local/propellor.git"
unpackcmd branch = shellWrap $ intercalate " && "
[ "git clone " ++ remotebundle ++ " " ++ localdir
, "cd " ++ localdir
, "git checkout -b " ++ branch
, "git remote rm origin"
, "rm -f " ++ remotebundle
]
sendPrecompiled :: HostName -> IO ()
sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor as a last resort" $
bracket getWorkingDirectory changeWorkingDirectory $ \_ ->
withTmpDir "propellor" go
where
go tmpdir = do
cacheparams <- sshCachingParams hn
let shimdir = takeFileName localdir
createDirectoryIfMissing True (tmpdir </> shimdir)
changeWorkingDirectory (tmpdir </> shimdir)
me <- readSymbolicLink "/proc/self/exe"
createDirectoryIfMissing True "bin"
unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $
errorMessage "failed copying in propellor"
let bin = "bin/propellor"
let binpath = Just $ localdir </> bin
void $ Shim.setup bin binpath "."
changeWorkingDirectory tmpdir
withTmpFile "propellor.tar." $ \tarball _ -> allM id
[ boolSystem "strip" [File me]
, boolSystem "tar" [Param "czf", File tarball, File shimdir]
, boolSystemNonConcurrent "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
, boolSystemNonConcurrent "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]
]
remotetarball = "/usr/local/propellor.tar"
unpackcmd = shellWrap $ intercalate " && "
[ "cd " ++ takeDirectory remotetarball
, "tar xzf " ++ remotetarball
, "rm -f " ++ remotetarball
]
mergeSpin :: IO ()
mergeSpin = do
branch <- getCurrentBranch
branchref <- getCurrentBranchRef
old_head <- getCurrentGitSha1 branch
old_commit <- findLastNonSpinCommit
rungit "reset" [Param old_commit]
unlessM (gitCommit Nothing [Param "-a", Param "--allow-empty"]) $
error "git commit failed"
rungit "merge" =<< gpgSignParams [Param "-s", Param "ours", Param old_head, Param "--no-edit"]
current_commit <- getCurrentGitSha1 branch
rungit "update-ref" [Param branchref, Param current_commit]
rungit "checkout" [Param branch]
where
rungit cmd ps = unlessM (boolSystem "git" (Param cmd:ps)) $
error ("git " ++ cmd ++ " failed")
findLastNonSpinCommit :: IO String
findLastNonSpinCommit = do
commits <- map (separate (== ' ')) . lines
<$> readProcess "git" ["log", "--oneline", "--no-abbrev-commit"]
case dropWhile (\(_, msg) -> msg == spinCommitMessage) commits of
((sha, _):_) -> return sha
_ -> error $ "Did not find any previous commit that was not a " ++ show spinCommitMessage
spinCommitMessage :: String
spinCommitMessage = "propellor spin"
gitPullFromUpdateServer :: IO ()
gitPullFromUpdateServer = req NeedGitPush gitPushMarker $ \_ -> do
(pread, pwrite) <- System.Posix.IO.createPipe
setFdOption pwrite CloseOnExec True
hwrite <- fdToHandle pwrite
forwarder <- async $ stdin *>* hwrite
let hin = pread
hout <- dup stdOutput
hClose stdout
unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $
errorMessage "git fetch from client failed"
wait forwarder
unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
errorMessage "git merge from client failed"
where
fetchparams hin hout =
[ Param "fetch"
, Param "--progress"
, Param "--upload-pack"
, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
, Param "."
]
gitPushHelper :: Fd -> Fd -> IO ()
gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
where
fromstdin = do
h <- fdToHandle hout
stdin *>* h
tostdout = do
h <- fdToHandle hin
h *>* stdout
(*>*) :: Handle -> Handle -> IO ()
fromh *>* toh = do
b <- B.hGetSome fromh 40960
if B.null b
then do
hClose fromh
hClose toh
else do
B.hPut toh b
hFlush toh
fromh *>* toh