propellor/src/Propellor/Spin.hs

334 lines
10 KiB
Haskell
Raw Normal View History

2014-11-23 00:17:46 +00:00
module Propellor.Spin (
commitSpin,
2014-11-23 00:17:46 +00:00
spin,
2014-11-19 02:10:50 +00:00
update,
2014-11-23 22:48:52 +00:00
gitPushHelper,
mergeSpin,
2014-11-19 02:10:50 +00:00
) where
import Data.List
import System.Exit
import System.PosixCompat
import System.Posix.IO
2014-11-22 04:25:00 +00:00
import System.Posix.Directory
2014-11-19 02:10:50 +00:00
import Control.Concurrent.Async
2014-11-22 04:25:00 +00:00
import Control.Exception (bracket)
2014-11-19 02:10:50 +00:00
import qualified Data.ByteString as B
import qualified Data.Set as S
import qualified Network.BSD as BSD
import Network.Socket (inet_ntoa)
2014-11-19 02:10:50 +00:00
import Propellor
import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Git
import Propellor.Ssh
2014-11-23 00:17:46 +00:00
import Propellor.Gpg
import qualified Propellor.Shim as Shim
2014-11-19 02:10:50 +00:00
import Utility.FileMode
import Utility.SafeCommand
commitSpin :: IO ()
commitSpin = do
void $ actionMessage "Git commit" $
2014-11-23 22:48:52 +00:00
gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param spinCommitMessage]
-- Push to central origin repo first, if possible.
-- The remote propellor will pull from there, which avoids
-- us needing to send stuff directly to the remote host.
whenM hasOrigin $
void $ actionMessage "Push to central git repository" $
boolSystem "git" [Param "push"]
2014-11-23 00:17:46 +00:00
spin :: HostName -> Maybe HostName -> Host -> IO ()
spin target relay 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
2014-11-23 00:17:46 +00:00
-- Install, or update the remote propellor.
updateServer target relay hst
(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd])
(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd])
2014-11-23 00:17:46 +00:00
-- And now we can run it.
unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
2014-11-23 00:17:46 +00:00
error $ "remote propellor failed"
where
hn = fromMaybe target relay
relaying = relay == Just target
viarelay = isJust relay && not relaying
probecmd = intercalate " ; "
2014-11-23 00:17:46 +00:00
[ "if [ ! -d " ++ localdir ++ "/.git ]"
, "then (" ++ intercalate " && "
[ "if ! git --version || ! make --version; then apt-get update && apt-get --no-install-recommends --no-upgrade -y install git make; fi"
, "echo " ++ toMarked statusMarker (show NeedGitClone)
] ++ ") || echo " ++ toMarked statusMarker (show NeedPrecompiled)
, "else " ++ updatecmd
2014-11-23 00:17:46 +00:00
, "fi"
]
updatecmd = intercalate " && "
[ "cd " ++ localdir
, "if ! test -x ./propellor; then make deps build; fi"
, if viarelay
then "./propellor --continue " ++
shellEscape (show (Relay target))
-- Still using --boot for back-compat...
else "./propellor --boot " ++ target
]
2014-11-23 00:17:46 +00:00
runcmd = "cd " ++ localdir ++ " && ./propellor " ++ cmd
2014-11-23 00:17:46 +00:00
cmd = if viarelay
then "--serialized " ++ shellEscape (show (Spin [target] (Just target)))
2014-11-23 00:17:46 +00:00
else "--continue " ++ shellEscape (show (SimpleRun target))
-- Check if the Host contains an IP address that matches one of the IPs
-- in the DNS for the HostName. If so, the HostName is used as-is,
-- but if the DNS is out of sync with the Host config, or doesn't have
-- the host in it at all, use one of the Host's IPs instead.
getSshTarget :: HostName -> Host -> IO String
getSshTarget target hst
2015-01-01 20:19:32 +00:00
| null configips = return target
| otherwise = go =<< tryIO (BSD.getHostByName target)
where
2015-01-01 17:34:02 +00:00
go (Left e) = useip (show e)
2015-01-01 17:42:34 +00:00
go (Right hostentry) = ifM (anyM matchingconfig (BSD.hostAddresses hostentry))
2015-01-01 20:19:32 +00:00
( return target
2015-01-01 17:36:51 +00:00
, do
ips <- mapM inet_ntoa (BSD.hostAddresses hostentry)
2015-01-01 17:42:34 +00:00
useip ("DNS " ++ show ips ++ " vs configured " ++ show configips)
2015-01-01 17:36:51 +00:00
)
2015-01-01 17:42:34 +00:00
matchingconfig a = flip elem configips <$> inet_ntoa a
2015-01-01 17:42:34 +00:00
useip why = case headMaybe configips of
2015-01-01 17:31:30 +00:00
Nothing -> return target
Just ip -> do
2015-01-01 17:36:51 +00:00
warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead."
2015-01-01 17:31:30 +00:00
return ip
2015-01-01 17:42:34 +00:00
configips = map fromIPAddr $ mapMaybe getIPAddr $
S.toList $ _dns $ hostInfo hst
2014-11-19 02:10:50 +00:00
-- Update the privdata, repo url, and git repo over the ssh
2014-11-20 01:48:48 +00:00
-- connection, talking to the user's local propellor instance which is
2014-11-19 02:10:50 +00:00
-- running the updateServer
2014-11-22 16:57:07 +00:00
update :: Maybe HostName -> IO ()
update forhost = do
2014-11-22 19:19:20 +00:00
whenM hasGitRepo $
2014-11-22 04:44:13 +00:00
req NeedRepoUrl repoUrlMarker setRepoUrl
2014-11-22 16:57:07 +00:00
2014-11-19 02:10:50 +00:00
makePrivDataDir
2014-11-22 16:57:07 +00:00
createDirectoryIfMissing True (takeDirectory privfile)
2014-11-19 02:10:50 +00:00
req NeedPrivData privDataMarker $
2014-11-22 16:57:07 +00:00
writeFileProtected privfile
whenM hasGitRepo $
2014-11-22 04:44:13 +00:00
req NeedGitPush gitPushMarker $ \_ -> do
hin <- dup stdInput
hout <- dup stdOutput
hClose stdin
hClose stdout
unlessM (boolSystem "git" (pullparams hin hout)) $
errorMessage "git pull from client failed"
2014-11-19 02:10:50 +00:00
where
pullparams hin hout =
[ Param "pull"
, Param "--progress"
, Param "--upload-pack"
, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
, Param "."
]
2014-11-22 16:57:07 +00:00
-- When --spin --relay is run, get a privdata file
-- to be relayed to the target host.
privfile = maybe privDataLocal privDataRelay forhost
2014-11-19 02:10:50 +00:00
updateServer
:: HostName
-> Maybe HostName
-> Host
-> CreateProcess
-> CreateProcess
-> IO ()
updateServer target relay hst connect haveprecompiled =
withBothHandles createProcessSuccess connect go
2014-11-19 02:10:50 +00:00
where
2014-11-22 16:57:07 +00:00
hn = fromMaybe target relay
2014-11-22 19:48:17 +00:00
relaying = relay == Just target
2014-11-19 02:10:50 +00:00
go (toh, fromh) = do
let loop = go (toh, fromh)
let restart = updateServer hn relay hst connect haveprecompiled
2014-11-22 19:48:17 +00:00
let done = return ()
2014-11-19 02:10:50 +00:00
v <- (maybe Nothing readish <$> getMarked fromh statusMarker)
case v of
(Just NeedRepoUrl) -> do
sendRepoUrl toh
loop
(Just NeedPrivData) -> do
2014-11-22 19:48:17 +00:00
sendPrivData hn hst toh relaying
2014-11-19 02:10:50 +00:00
loop
(Just NeedGitClone) -> do
hClose toh
hClose fromh
sendGitClone hn
2014-11-22 19:48:17 +00:00
restart
(Just NeedPrecompiled) -> do
hClose toh
hClose fromh
sendPrecompiled hn
updateServer hn relay hst haveprecompiled (error "loop")
2014-11-22 19:48:17 +00:00
(Just NeedGitPush) -> do
sendGitUpdate hn fromh toh
hClose fromh
hClose toh
done
Nothing -> done
2014-11-19 02:10:50 +00:00
sendRepoUrl :: Handle -> IO ()
sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl)
2014-11-22 19:48:17 +00:00
sendPrivData :: HostName -> Host -> Handle -> Bool -> IO ()
sendPrivData hn hst toh relaying = do
2014-11-22 19:01:08 +00:00
privdata <- getdata
2014-11-19 02:10:50 +00:00
void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
sendMarked toh privDataMarker privdata
return True
2014-11-22 19:01:08 +00:00
where
getdata
2014-11-22 19:48:17 +00:00
| relaying = do
2014-11-22 19:01:08 +00:00
let f = privDataRelay hn
d <- readFileStrictAnyEncoding f
nukeFile f
return d
2014-11-22 19:48:17 +00:00
| otherwise = show . filterPrivData hst <$> decryptPrivData
2014-11-19 02:10:50 +00:00
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
}
-- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> IO ()
sendGitClone hn = void $ actionMessage ("Clone git repository to " ++ hn) $ do
branch <- getCurrentBranch
2014-11-22 20:20:02 +00:00
cacheparams <- sshCachingParams hn
2014-11-19 02:10:50 +00:00
withTmpFile "propellor.git" $ \tmp _ -> allM id
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
, boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)]
, boolSystem "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
]
-- Send a tarball containing the precompiled propellor, and libraries.
-- This should be reasonably portable, as long as the remote host has the
-- same architecture as the build host.
sendPrecompiled :: HostName -> IO ()
2014-11-22 04:32:04 +00:00
sendPrecompiled hn = void $ actionMessage ("Uploading locally compiled propellor as a last resort") $ do
2014-11-22 04:50:56 +00:00
bracket getWorkingDirectory changeWorkingDirectory $ \_ ->
withTmpDir "propellor" go
where
2014-11-22 04:50:56 +00:00
go tmpdir = do
2014-11-22 20:20:02 +00:00
cacheparams <- sshCachingParams hn
let shimdir = takeFileName localdir
2014-11-22 04:50:56 +00:00
createDirectoryIfMissing True (tmpdir </> shimdir)
changeWorkingDirectory (tmpdir </> shimdir)
me <- readSymbolicLink "/proc/self/exe"
2014-11-22 21:22:11 +00:00
createDirectoryIfMissing True "bin"
unlessM (boolSystem "cp" [File me, File "bin/propellor"]) $
errorMessage "failed copying in propellor"
2014-11-23 02:11:36 +00:00
let bin = "bin/propellor"
let binpath = Just $ localdir </> bin
void $ Shim.setup bin binpath "."
2014-11-22 04:50:56 +00:00
changeWorkingDirectory tmpdir
withTmpFile "propellor.tar." $ \tarball _ -> allM id
[ boolSystem "strip" [File me]
2014-11-22 05:13:53 +00:00
, boolSystem "tar" [Param "czf", File tarball, File shimdir]
2014-11-22 04:50:56 +00:00
, boolSystem "scp" $ cacheparams ++ [File tarball, Param ("root@"++hn++":"++remotetarball)]
, boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param unpackcmd]
]
remotetarball = "/usr/local/propellor.tar"
2014-11-22 04:50:56 +00:00
2014-11-22 04:25:00 +00:00
unpackcmd = shellWrap $ intercalate " && "
[ "cd " ++ takeDirectory remotetarball
2014-11-22 05:13:53 +00:00
, "tar xzf " ++ remotetarball
, "rm -f " ++ remotetarball
]
2014-11-19 02:10:50 +00:00
-- Shim for git push over the propellor ssh channel.
-- Reads from stdin and sends it to hout;
-- reads from hin and sends it to stdout.
gitPushHelper :: Fd -> Fd -> IO ()
gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
where
fromstdin = do
h <- fdToHandle hout
connect stdin h
tostdout = do
h <- fdToHandle hin
connect h stdout
connect fromh toh = do
hSetBinaryMode fromh True
hSetBinaryMode toh True
b <- B.hGetSome fromh 40960
if B.null b
then do
hClose fromh
hClose toh
else do
B.hPut toh b
hFlush toh
connect fromh toh
2014-11-23 22:48:52 +00:00
mergeSpin :: IO ()
mergeSpin = do
branch <- getCurrentBranch
branchref <- getCurrentBranchRef
old_head <- getCurrentGitSha1 branch
old_commit <- findLastNonSpinCommit
rungit "reset" [Param old_commit]
2014-11-24 04:50:48 +00:00
rungit "commit" [Param "-a", Param "--allow-empty"]
2014-11-23 22:48:52 +00:00
rungit "merge" =<< gpgSignParams [Param "-s", Param "ours", Param old_head]
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"