module Propellor.CmdLine (
defaultMain,
processCmdLine,
) where
import System.Environment (getArgs)
import Data.List
import System.Exit
import System.PosixCompat
import Network.Socket
import Propellor.Base
import Propellor.Gpg
import Propellor.Git
import Propellor.Git.VerifiedBranch
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
usage :: Handle -> IO ()
usage h = hPutStrLn h $ unlines
[ "Usage:"
, " propellor --init"
, " propellor"
, " propellor hostname"
, " propellor --spin targethost [--via relayhost]"
, " propellor --add-key keyid"
, " propellor --rm-key keyid"
, " propellor --list-fields"
, " propellor --dump field context"
, " propellor --edit field context"
, " propellor --set field context"
, " propellor --unset field context"
, " propellor --unset-unused"
, " propellor --merge"
, " propellor --build"
, " propellor --check"
]
usageError :: [String] -> IO a
usageError ps = do
usage stderr
error ("(Unexpected: " ++ show ps)
processCmdLine :: IO CmdLine
processCmdLine = go =<< getArgs
where
go ("--check":_) = return Check
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 ("--rm-key":k:[]) = return $ RmKey k
go ("--set":f:c:[]) = withprivfield f c Set
go ("--unset":f:c:[]) = withprivfield f c Unset
go ("--unset-unused":[]) = return UnsetUnused
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
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 ++ ")"
data CanRebuild = CanRebuild | NoRebuild
defaultMain :: [Host] -> IO ()
defaultMain hostlist = withConcurrentOutput $ do
Shim.cleanEnv
checkDebugMode
cmdline <- processCmdLine
debug ["command line: ", show cmdline]
go CanRebuild cmdline
where
go cr (Serialized cmdline) = go cr cmdline
go _ Check = return ()
go _ (Set field context) = setPrivData field context
go _ (Unset field context) = unsetPrivData field context
go _ (UnsetUnused) = unsetPrivDataUnused hostlist
go _ (Dump field context) = dumpPrivData field context
go _ (Edit field context) = editPrivData field context
go _ ListFields = listPrivDataFields hostlist
go _ (AddKey keyid) = addKey keyid
go _ (RmKey keyid) = rmKey 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 cr (Relay h) = forceConsole >>
updateFirst Nothing cr (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 cr cmdline@(Spin hs mrelay) = buildFirst Nothing cr cmdline $ do
unless (isJust mrelay) commitSpin
forM_ hs $ \hn -> withhost hn $ spin mrelay hn
go cr cmdline@(Run hn) = ifM ((==) 0 <$> getRealUserID)
( updateFirst (findHost hostlist hn) cr cmdline $ runhost hn
, fetchFirst $ go cr (Spin [hn] Nothing)
)
go cr cmdline@(SimpleRun hn) = forceConsole >>
fetchFirst (buildFirst (findHost hostlist hn) cr cmdline (runhost hn))
go _ (Continue cmdline) = go NoRebuild cmdline
withhost :: HostName -> (Host -> IO ()) -> IO ()
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
runhost hn = onlyprocess $ withhost hn mainProperties
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 :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
buildFirst h CanRebuild cmdline next = do
oldtime <- getmtime
buildPropellor h
newtime <- getmtime
if newtime == oldtime
then next
else continueAfterBuild cmdline
where
getmtime = catchMaybeIO $ getModificationTime "propellor"
buildFirst _ NoRebuild _ next = next
continueAfterBuild :: CmdLine -> IO a
continueAfterBuild cmdline = go =<< boolSystem "./propellor"
[ Param "--continue"
, Param (show cmdline)
]
where
go True = exitSuccess
go False = exitWith (ExitFailure 1)
fetchFirst :: IO () -> IO ()
fetchFirst next = do
whenM hasOrigin $
void fetchOrigin
next
updateFirst :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst h canrebuild cmdline next = ifM hasOrigin
( updateFirst' h canrebuild cmdline next
, next
)
updateFirst' :: Maybe Host -> CanRebuild -> CmdLine -> IO () -> IO ()
updateFirst' h CanRebuild cmdline next = ifM fetchOrigin
( do
buildPropellor h
continueAfterBuild cmdline
, next
)
updateFirst' _ NoRebuild _ next = next
hostname :: String -> IO HostName
hostname s = go =<< catchDefaultIO [] dnslookup
where
dnslookup = getAddrInfo (Just canonname) (Just s) Nothing
canonname = defaultHints { addrFlags = [AI_CANONNAME] }
go (AddrInfo { addrCanonName = Just v } : _) = pure v
go _
| "." `isInfixOf` s = pure s
| otherwise =
error $ "cannot find host " ++ s ++ " in the DNS"