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.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" , " 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 -- 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 = withConcurrentOutput $ 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 _ 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 _ (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 mrelay) = do commitSpin forM_ hs $ \hn -> withhost hn $ spin mrelay hn go False cmdline@(SimpleRun hn) = do forceConsole 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 ) -- Gets the fully qualified domain name, given a string that might be -- a short name to look up in the DNS. 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 -- assume it's a fqdn | otherwise = error $ "cannot find host " ++ s ++ " in the DNS"