propellor/src/Propellor/CmdLine.hs

module Propellor.CmdLine (
	defaultMain,
	processCmdLine,
) where

import System.Environment (getArgs)
import Data.List
import System.Exit
import System.PosixCompat

import Propellor
import Propellor.Protocol
import Propellor.Gpg
import Propellor.Git
import Propellor.Ssh
import Propellor.Server
import qualified Propellor.Property.Docker as Docker
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
import Utility.SafeCommand

usage :: Handle -> IO ()
usage h = hPutStrLn h $ 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"
	]

usageError :: [String] -> IO a
usageError ps = do
	usage stderr
	error ("(Unexpected: " ++ show ps)

processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
  where
	go ("--run":h:[]) = return $ Run h
	go ("--spin":h:[]) = return $ Spin 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 ("--help":_) = do	
		usage stdout
		exitFailure
	go ("--update":h:[]) = return $ Update h
	go ("--boot":h:[]) = return $ Update h -- for back-compat
	go ("--continue":s:[]) = case readish s of
		Just cmdline -> return $ Continue cmdline
		Nothing -> errorMessage $ "--continue serialization failure (" ++ s ++ ")"
	go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
	go (h:[])
		| "--" `isPrefixOf` h = usageError [h]
		| 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 v = usageError v

	withprivfield s c f = case readish s of
		Just pf -> return $ f pf (Context c)
		Nothing -> errorMessage $ "Unknown privdata field " ++ s

-- | Runs propellor on hosts, as controlled by command-line options.
defaultMain :: [Host] -> IO ()
defaultMain hostlist = do
	Shim.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 _ (DockerChain hn cid) = Docker.chain hostlist hn cid
	go _ (ChrootChain hn loc) = Chroot.chain hostlist hn loc
	go _ (DockerInit hn) = Docker.init hn
	go _ (GitPush fin fout) = gitPushHelper fin fout
	go _ (Update _) = forceConsole >> fetchFirst (onlyprocess update)
	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 cmdline@(SimpleRun hn) = buildFirst cmdline $
		go False (Run hn)
	go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
		( onlyprocess $ withhost hn mainProperties
		, go True (Spin hn)
		)

	withhost :: HostName -> (Host -> IO ()) -> IO ()
	withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
	
	onlyprocess = onlyProcess (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"

fetchFirst :: IO () -> IO ()
fetchFirst next = do
	whenM hasOrigin $
		void fetchOrigin
	next

updateFirst :: CmdLine -> IO () -> IO ()
updateFirst cmdline next = ifM hasOrigin (updateFirst' cmdline next, next)

updateFirst' :: CmdLine -> IO () -> IO ()
updateFirst' cmdline next = ifM fetchOrigin
	( ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"])
		( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)]
			, errorMessage "Propellor build failed!" 
		)
	, next
	)

spin :: HostName -> Host -> IO ()
spin hn hst = do
	void $ actionMessage "Git commit" $
		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 "Push to central git repository" $
			boolSystem "git" [Param "push"]
	
	cacheparams <- toCommand <$> sshCachingParams hn

	-- Install, or update the remote propellor.
	updateServer hn hst $ withBothHandles createProcessSuccess
		(proc "ssh" $ cacheparams ++ [user, updatecmd])

	-- And now we can run it.
	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", user, runcmd])) $
		error $ "remote propellor failed"
  where
	user = "root@"++hn

	mkcmd = shellWrap . intercalate " ; "

	updatecmd = 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 --continue " ++ shellEscape (show (SimpleRun hn)) ]