propellor/src/Propellor/CmdLine.hs

172 lines
5.1 KiB
Haskell

module Propellor.CmdLine (
defaultMain,
processCmdLine,
) where
import System.Environment (getArgs)
import Data.List
import System.Exit
import System.PosixCompat
import qualified Network.BSD
import Propellor
import Propellor.Gpg
import Propellor.Git
import Propellor.Bootstrap
import Propellor.Spin
import Propellor.Types.CmdLine
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 targethost [--via relayhost]"
, " propellor --add-key keyid"
, " propellor --set field context"
, " propellor --dump field context"
, " propellor --edit field context"
, " propellor --list-fields"
, " propellor --merge"
, " propellor --build"
]
usageError :: [String] -> IO a
usageError ps = do
usage stderr
error ("(Unexpected: " ++ show ps)
processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
where
go ("--spin":ps) = case reverse ps of
(r:"--via":hs) -> Spin
<$> mapM hostname (reverse hs)
<*> pure (Just r)
_ -> Spin <$> mapM hostname ps <*> pure Nothing
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 ("--merge":[]) = return Merge
go ("--help":_) = do
usage stdout
exitFailure
go ("--boot":_:[]) = return $ Update Nothing -- for back-compat
go ("--serialized":s:[]) = serialized Serialized s
go ("--continue":s:[]) = serialized Continue s
go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
go ("--run":h:[]) = go [h]
go (h:[])
| "--" `isPrefixOf` h = usageError [h]
| otherwise = Run <$> hostname 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
serialized mk s = case readish s of
Just cmdline -> return $ mk cmdline
Nothing -> errorMessage $ "serialization failure (" ++ 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 _ (Serialized cmdline) = go True cmdline
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 _ c@(ChrootChain _ _ _ _) = Chroot.chain hostlist c
go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
go _ (DockerInit hn) = Docker.init hn
go _ (GitPush fin fout) = gitPushHelper fin fout
go _ (Relay h) = forceConsole >> updateFirst (Update (Just h)) (update (Just h))
go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing))
go _ (Update (Just h)) = update (Just h)
go _ Merge = mergeSpin
go True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin hs r) = do
commitSpin
forM_ hs $ \hn -> withhost hn $ spin hn r
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] Nothing)
)
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
buildPropellor
newtime <- getmtime
if newtime == oldtime
then next
else void $ boolSystem "./propellor"
[ Param "--continue"
, Param (show cmdline)
]
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
( do
buildPropellor
void $ boolSystem "./propellor"
[ Param "--continue"
, Param (show cmdline)
]
, next
)
hostname :: String -> IO HostName
hostname s
| "." `isInfixOf` s = pure s
| otherwise = do
h <- Network.BSD.getHostByName s
return (Network.BSD.hostName h)