propellor/src/Propellor/CmdLine.hs

172 lines
5.1 KiB
Haskell
Raw Normal View History

2014-11-19 03:50:38 +00:00
module Propellor.CmdLine (
defaultMain,
processCmdLine,
) where
2014-03-30 23:10:32 +00:00
2014-04-01 15:59:48 +00:00
import System.Environment (getArgs)
2014-03-30 23:10:32 +00:00
import Data.List
import System.Exit
2014-04-03 17:49:26 +00:00
import System.PosixCompat
import qualified Network.BSD
2014-03-30 23:10:32 +00:00
2014-03-31 03:55:59 +00:00
import Propellor
2014-11-11 16:58:53 +00:00
import Propellor.Gpg
2014-11-18 22:39:10 +00:00
import Propellor.Git
import Propellor.Bootstrap
2014-11-23 00:17:46 +00:00
import Propellor.Spin
import Propellor.Types.CmdLine
import qualified Propellor.Property.Docker as Docker
2014-11-20 19:15:28 +00:00
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Shim as Shim
2014-03-31 03:55:59 +00:00
import Utility.SafeCommand
2014-03-30 23:10:32 +00:00
2014-11-19 00:33:25 +00:00
usage :: Handle -> IO ()
usage h = hPutStrLn h $ unlines
[ "Usage:"
, " propellor"
, " propellor hostname"
2014-11-22 16:57:07 +00:00
, " propellor --spin targethost [--via relayhost]"
2014-11-19 00:33:25 +00:00
, " propellor --add-key keyid"
, " propellor --set field context"
, " propellor --dump field context"
, " propellor --edit field context"
, " propellor --list-fields"
2014-11-23 22:48:52 +00:00
, " propellor --merge"
, " propellor --build"
2014-11-19 00:33:25 +00:00
]
usageError :: [String] -> IO a
usageError ps = do
usage stderr
error ("(Unexpected: " ++ show ps)
2014-03-30 23:10:32 +00:00
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
2014-03-31 16:06:04 +00:00
go ("--add-key":k:[]) = return $ AddKey k
2014-07-06 19:56:56 +00:00
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
2014-11-23 22:48:52 +00:00
go ("--merge":[]) = return Merge
2014-11-19 00:33:25 +00:00
go ("--help":_) = do
usage stdout
exitFailure
2014-11-22 16:57:07 +00:00
go ("--boot":_:[]) = return $ Update Nothing -- for back-compat
2014-11-22 19:54:31 +00:00
go ("--serialized":s:[]) = serialized Serialized s
go ("--continue":s:[]) = serialized Continue s
2014-11-19 00:38:11 +00:00
go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout)
go ("--run":h:[]) = go [h]
2014-04-01 15:59:48 +00:00
go (h:[])
2014-11-19 00:33:25 +00:00
| "--" `isPrefixOf` h = usageError [h]
| otherwise = Run <$> hostname h
2014-03-30 23:10:32 +00:00
go [] = do
s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"]
if null s
2014-03-31 22:31:08 +00:00
then errorMessage "Cannot determine hostname! Pass it on the command line."
2014-03-30 23:10:32 +00:00
else return $ Run s
2014-11-19 00:33:25 +00:00
go v = usageError v
2014-03-30 23:10:32 +00:00
2014-07-06 19:56:56 +00:00
withprivfield s c f = case readish s of
Just pf -> return $ f pf (Context c)
Nothing -> errorMessage $ "Unknown privdata field " ++ s
2014-11-22 19:54:31 +00:00
serialized mk s = case readish s of
Just cmdline -> return $ mk cmdline
Nothing -> errorMessage $ "serialization failure (" ++ s ++ ")"
2014-11-19 03:50:38 +00:00
-- | Runs propellor on hosts, as controlled by command-line options.
2014-04-11 01:09:20 +00:00
defaultMain :: [Host] -> IO ()
defaultMain hostlist = do
2014-11-20 19:15:28 +00:00
Shim.cleanEnv
2014-04-01 15:59:48 +00:00
checkDebugMode
cmdline <- processCmdLine
debug ["command line: ", show cmdline]
go True cmdline
2014-03-30 23:10:32 +00:00
where
2014-11-22 19:54:31 +00:00
go _ (Serialized cmdline) = go True cmdline
2014-03-31 20:37:19 +00:00
go _ (Continue cmdline) = go False cmdline
2014-07-06 19:56:56 +00:00
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
2014-03-31 20:37:19 +00:00
go _ (AddKey keyid) = addKey keyid
2014-11-21 21:11:26 +00:00
go _ c@(ChrootChain _ _ _ _) = Chroot.chain hostlist c
go _ (DockerChain hn cid) = Docker.chain hostlist hn cid
go _ (DockerInit hn) = Docker.init hn
2014-11-19 02:10:50 +00:00
go _ (GitPush fin fout) = gitPushHelper fin fout
go _ (Relay h) = forceConsole >> updateFirst (Update (Just h)) (update (Just h))
2014-11-22 16:57:07 +00:00
go _ (Update Nothing) = forceConsole >> fetchFirst (onlyprocess (update Nothing))
go _ (Update (Just h)) = update (Just h)
2014-11-23 22:48:52 +00:00
go _ Merge = mergeSpin
2014-11-22 16:57:07 +00:00
go True cmdline@(Spin _ _) = buildFirst cmdline $ go False cmdline
2014-03-31 21:57:12 +00:00
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)
2014-04-11 01:09:20 +00:00
go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
( onlyprocess $ withhost hn mainProperties
, go True (Spin [hn] Nothing)
2014-04-03 17:58:21 +00:00
)
2014-03-31 20:37:19 +00:00
withhost :: HostName -> (Host -> IO ()) -> IO ()
2014-07-07 05:57:59 +00:00
withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn)
onlyprocess = onlyProcess (localdir </> ".lock")
2014-04-04 20:20:20 +00:00
2014-07-07 05:57:59 +00:00
unknownhost :: HostName -> [Host] -> IO a
unknownhost h hosts = errorMessage $ unlines
2014-04-08 22:42:54 +00:00
[ "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)"
2014-07-07 05:57:59 +00:00
, "Known hosts: " ++ unwords (map hostName hosts)
2014-03-31 03:02:10 +00:00
]
2014-03-31 22:53:27 +00:00
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)
]
2014-03-31 22:53:27 +00:00
where
getmtime = catchMaybeIO $ getModificationTime "propellor"
fetchFirst :: IO () -> IO ()
fetchFirst next = do
whenM hasOrigin $
void fetchOrigin
next
2014-03-31 21:57:12 +00:00
updateFirst :: CmdLine -> IO () -> IO ()
2014-11-18 19:43:00 +00:00
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
)
2014-03-31 20:20:38 +00:00
hostname :: String -> IO HostName
hostname s
| "." `isInfixOf` s = pure s
| otherwise = do
h <- Network.BSD.getHostByName s
return (Network.BSD.hostName h)