propellor/src/Propellor/CmdLine.hs

424 lines
14 KiB
Haskell

module Propellor.CmdLine where
import System.Environment (getArgs)
import Data.List
import System.Exit
import System.Log.Logger
import System.Log.Formatter
import System.Log.Handler (setFormatter, LogHandler)
import System.Log.Handler.Simple
import System.PosixCompat
import Control.Exception (bracket)
import System.Posix.IO
import Data.Time.Clock.POSIX
import Control.Concurrent.Async
import qualified Data.ByteString as B
import System.Process (std_in, std_out)
import Propellor
import Propellor.Protocol
import Propellor.PrivData.Paths
import Propellor.Gpg
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Docker.Shim as DockerShim
import Utility.FileMode
import Utility.SafeCommand
import Utility.UserInfo
usage :: IO a
usage = do
putStrLn $ unlines
[ "Usage:"
, " propellor"
, " propellor hostname"
, " propellor --spin hostname"
, " propellor --add-key keyid"
, " propellor --set field context"
, " propellor --dump field context"
, " propellor --edit field context"
, " propellor --list-fields"
]
exitFailure
processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
where
go ("--help":_) = usage
go ("--spin":h:[]) = return $ Spin h
go ("--boot":h:[]) = return $ Boot h
go ("--run":h:[]) = return $ Run h
go ("--add-key":k:[]) = return $ AddKey k
go ("--set":f:c:[]) = withprivfield f c Set
go ("--dump":f:c:[]) = withprivfield f c Dump
go ("--edit":f:c:[]) = withprivfield f c Edit
go ("--list-fields":[]) = return ListFields
go ("--continue":s:[]) = case readish s of
Just cmdline -> return $ Continue cmdline
Nothing -> errorMessage "--continue serialization failure"
go ("--chain":h:[]) = return $ Chain h False
go ("--chain":h:b:[]) = return $ Chain h (Prelude.read b)
go ("--docker":h:[]) = return $ Docker h
go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
go (h:[])
| "--" `isPrefixOf` h = usage
| otherwise = return $ Run h
go [] = do
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
if null s
then errorMessage "Cannot determine hostname! Pass it on the command line."
else return $ Run s
go _ = usage
withprivfield s c f = case readish s of
Just pf -> return $ f pf (Context c)
Nothing -> errorMessage $ "Unknown privdata field " ++ s
defaultMain :: [Host] -> IO ()
defaultMain hostlist = do
DockerShim.cleanEnv
checkDebugMode
cmdline <- processCmdLine
debug ["command line: ", show cmdline]
go True cmdline
where
go _ (Continue cmdline) = go False cmdline
go _ (Set field context) = setPrivData field context
go _ (Dump field context) = dumpPrivData field context
go _ (Edit field context) = editPrivData field context
go _ ListFields = listPrivDataFields hostlist
go _ (AddKey keyid) = addKey keyid
go _ (Chain hn isconsole) = withhost hn $ \h -> do
when isconsole forceConsole
r <- runPropellor h $ ensureProperties $ hostProperties h
putStrLn $ "\n" ++ show r
go _ (Docker hn) = Docker.chain hn
go _ (GitPush fin fout) = gitPush fin fout
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin hn) = withhost hn $ spin hn
go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
( onlyProcess $ withhost hn mainProperties
, go True (Spin hn)
)
go False (Boot _) = onlyProcess boot
withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
onlyProcess :: IO a -> IO a
onlyProcess a = bracket lock unlock (const a)
where
lock = do
l <- createFile lockfile stdFileMode
setLock l (WriteLock, AbsoluteSeek, 0, 0)
`catchIO` const alreadyrunning
return l
unlock = closeFd
alreadyrunning = error "Propellor is already running on this host!"
lockfile = localdir </> ".lock"
unknownhost :: HostName -> [Host] -> IO a
unknownhost h hosts = errorMessage $ unlines
[ "Propellor does not know about host: " ++ h
, "(Perhaps you should specify the real hostname on the command line?)"
, "(Or, edit propellor's config.hs to configure this host)"
, "Known hosts: " ++ unwords (map hostName hosts)
]
buildFirst :: CmdLine -> IO () -> IO ()
buildFirst cmdline next = do
oldtime <- getmtime
ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
( do
newtime <- getmtime
if newtime == oldtime
then next
else void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
, errorMessage "Propellor build failed!"
)
where
getmtime = catchMaybeIO $ getModificationTime "propellor"
getCurrentBranch :: IO String
getCurrentBranch = takeWhile (/= '\n')
<$> readProcess "git" ["symbolic-ref", "--short", "HEAD"]
updateFirst :: CmdLine -> IO () -> IO ()
updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)
updateFirst' :: CmdLine -> IO () -> IO ()
updateFirst' cmdline next = do
branchref <- getCurrentBranch
let originbranch = "origin" </> branchref
void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
oldsha <- getCurrentGitSha1 branchref
whenM (doesFileExist keyring) $ do
{- 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! -}
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"
if s == "U\n" || s == "G\n"
then do
putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging"
hFlush stdout
void $ boolSystem "git" [Param "merge", Param originbranch]
else warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)"
newsha <- getCurrentGitSha1 branchref
if oldsha == newsha
then next
else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
, errorMessage "Propellor build failed!"
)
getCurrentGitSha1 :: String -> IO String
getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref]
-- spin handles deploying propellor to a remote host, if it's not already
-- installed there, or updating it if it is. Once the remote propellor is
-- updated, it's run.
spin :: HostName -> Host -> IO ()
spin hn hst = do
void $ actionMessage "git commit (signed)" $
gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
-- 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 "pushing to central git repository" $
boolSystem "git" [Param "push"]
cacheparams <- toCommand <$> sshCachingParams hn
comm cacheparams =<< hostprivdata
unlessM (boolSystem "ssh" (map Param (cacheparams ++ ["-t", user, runcmd]))) $
error $ "remote propellor failed (running: " ++ runcmd ++")"
where
hostprivdata = show . filterPrivData hst <$> decryptPrivData
comm cacheparams privdata =
withBothHandles createProcessSuccess
(proc "ssh" $ cacheparams ++ ["-t", user, bootstrapcmd])
(comm' cacheparams privdata)
comm' cacheparams privdata (toh, fromh) = loop
where
loop = dispatch =<< (maybe Nothing readish <$> getMarked fromh statusMarker)
dispatch (Just NeedRepoUrl) = do
sendMarked toh repoUrlMarker
=<< (fromMaybe "" <$> getRepoUrl)
loop
dispatch (Just NeedPrivData) = do
sendprivdata toh privdata
loop
dispatch (Just NeedGitPush) = do
void $ actionMessage ("Sending git update to " ++ hn) $ do
sendMarked toh gitPushMarker ""
let p = (proc "git" ["upload-pack", "."])
{ std_in = UseHandle fromh
, std_out = UseHandle toh
}
(Nothing, Nothing, Nothing, h) <- createProcess p
r <- waitForProcess h
-- no more protocol possible after git push
hClose fromh
hClose toh
return (r == ExitSuccess)
dispatch (Just NeedGitClone) = do
hClose toh
hClose fromh
sendGitClone hn
comm cacheparams privdata
-- Ready is only sent by old versions of
-- propellor. They expect to get privdata,
-- and then no more protocol communication.
dispatch (Just Ready) = do
sendprivdata toh privdata
hClose toh
-- Display remaining output.
void $ tryIO $ forever $
showremote =<< hGetLine fromh
hClose fromh
dispatch Nothing = return ()
user = "root@"++hn
mkcmd = shellWrap . intercalate " ; "
bootstrapcmd = mkcmd
[ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && "
[ "apt-get update"
, "apt-get --no-install-recommends --no-upgrade -y install git make"
, "echo " ++ toMarked statusMarker (show NeedGitClone)
]
, "else " ++ intercalate " && "
[ "cd " ++ localdir
, "if ! test -x ./propellor; then make deps build; fi"
, "./propellor --boot " ++ hn
]
, "fi"
]
runcmd = mkcmd
[ "cd " ++ localdir ++ " && ./propellor --run " ++ hn ]
showremote s = putStrLn s
sendprivdata toh privdata = void $
actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do
sendMarked toh privDataMarker privdata
return True
-- Initial git clone, used for bootstrapping.
sendGitClone :: HostName -> IO ()
sendGitClone hn = void $ actionMessage ("Cloning 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"]
, 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
]
-- Called "boot" for historical reasons, but what this really does is
-- update the privdata, repo url, and git repo over the ssh connection from the
-- client that ran propellor --spin.
boot :: IO ()
boot = do
req NeedRepoUrl repoUrlMarker setRepoUrl
makePrivDataDir
req NeedPrivData privDataMarker $
writeFileProtected privDataLocal
req NeedGitPush gitPushMarker $ \_ -> do
hin <- dup stdInput
hout <- dup stdOutput
hClose stdin
hClose stdout
unlessM (boolSystem "git" [Param "pull", Param "--progress", Param "--upload-pack", Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout, Param "."]) $
errorMessage "git pull from client failed"
-- 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.
gitPush :: Fd -> Fd -> IO ()
gitPush 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
hasOrigin :: IO Bool
hasOrigin = do
rs <- lines <$> readProcess "git" ["remote"]
return $ "origin" `elem` rs
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
checkDebugMode :: IO ()
checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
where
go (Just "1") = do
f <- setFormatter
<$> streamHandler stderr DEBUG
<*> pure (simpleLogFormatter "[$time] $msg")
updateGlobalLogger rootLoggerName $
setLevel DEBUG . setHandlers [f]
go _ = noop
-- Parameters can be passed to both ssh and scp, to enable a ssh connection
-- caching socket.
--
-- If the socket already exists, check if its mtime is older than 10
-- minutes, and if so stop that ssh process, in order to not try to
-- use an old stale connection. (atime would be nicer, but there's
-- a good chance a laptop uses noatime)
sshCachingParams :: HostName -> IO [CommandParam]
sshCachingParams hn = do
home <- myHomeDir
let cachedir = home </> ".ssh" </> "propellor"
createDirectoryIfMissing False cachedir
let socketfile = cachedir </> hn ++ ".sock"
let ps =
[ Param "-o", Param ("ControlPath=" ++ socketfile)
, Params "-o ControlMaster=auto -o ControlPersist=yes"
]
maybe noop (expireold ps socketfile)
=<< catchMaybeIO (getFileStatus socketfile)
return ps
where
expireold ps f s = do
now <- truncate <$> getPOSIXTime :: IO Integer
if modificationTime s > fromIntegral now - tenminutes
then touchFile f
else do
void $ boolSystem "ssh" $
[ Params "-O stop" ] ++ ps ++
[ Param "localhost" ]
nukeFile f
tenminutes = 600