module Propellor.CmdLine where import System.Environment (getArgs) import Data.List import System.Exit import System.Log.Logger import System.Log.Formatter import System.Log.Handler (setFormatter, LogHandler) import System.Log.Handler.Simple import System.PosixCompat import Control.Exception (bracket) import System.Posix.IO import Data.Time.Clock.POSIX import Control.Concurrent.Async import qualified Data.ByteString as B import Propellor import Propellor.Protocol import Propellor.PrivData.Paths import Propellor.Gpg import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Docker.Shim as DockerShim import Utility.FileMode import Utility.SafeCommand import Utility.UserInfo usage :: IO a usage = do putStrLn $ 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" ] exitFailure processCmdLine :: IO CmdLine processCmdLine = go =<< getArgs where go ("--help":_) = usage go ("--spin":h:[]) = return $ Spin h go ("--boot":h:[]) = return $ Boot h go ("--run":h:[]) = return $ Run 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 ("--continue":s:[]) = case readish s of Just cmdline -> return $ Continue cmdline Nothing -> errorMessage "--continue serialization failure" go ("--chain":h:[]) = return $ Chain h go ("--docker":h:[]) = return $ Docker h go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout) go (h:[]) | "--" `isPrefixOf` h = usage | 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 _ = usage withprivfield s c f = case readish s of Just pf -> return $ f pf (Context c) Nothing -> errorMessage $ "Unknown privdata field " ++ s defaultMain :: [Host] -> IO () defaultMain hostlist = do DockerShim.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 _ (Chain hn) = withhost hn $ \h -> do r <- runPropellor h $ ensureProperties $ hostProperties h putStrLn $ "\n" ++ show r go _ (Docker hn) = Docker.chain hn go _ (GitPush fin fout) = gitPush fin fout 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 (Run hn) = ifM ((==) 0 <$> getRealUserID) ( onlyProcess $ withhost hn mainProperties , go True (Spin hn) ) go False (Boot _) = onlyProcess boot withhost :: HostName -> (Host -> IO ()) -> IO () withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn) onlyProcess :: IO a -> IO a onlyProcess a = bracket lock unlock (const a) where lock = do l <- createFile lockfile stdFileMode setLock l (WriteLock, AbsoluteSeek, 0, 0) `catchIO` const alreadyrunning return l unlock = closeFd alreadyrunning = error "Propellor is already running on this host!" lockfile = 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" getCurrentBranch :: IO String getCurrentBranch = takeWhile (/= '\n') <$> readProcess "git" ["symbolic-ref", "--short", "HEAD"] updateFirst :: CmdLine -> IO () -> IO () updateFirst cmdline next = do branchref <- getCurrentBranch let originbranch = "origin" branchref void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"] oldsha <- getCurrentGitSha1 branchref whenM (doesFileExist keyring) $ do {- To verify origin branch commit's signature, have to - convince gpg to use our keyring. While running git log. - Which has no way to pass options to gpg. - Argh! -} let gpgconf = privDataDir "gpg.conf" writeFile gpgconf $ unlines [ " keyring " ++ keyring , "no-auto-check-trustdb" ] -- gpg is picky about perms modifyFileMode privDataDir (removeModes otherGroupModes) s <- readProcessEnv "git" ["log", "-n", "1", "--format=%G?", originbranch] (Just [("GNUPGHOME", privDataDir)]) nukeFile $ privDataDir "trustdb.gpg" nukeFile $ privDataDir "pubring.gpg" nukeFile $ privDataDir "gpg.conf" if s == "U\n" || s == "G\n" then do putStrLn $ "git branch " ++ originbranch ++ " gpg signature verified; merging" hFlush stdout void $ boolSystem "git" [Param "merge", Param originbranch] else warningMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it! (Running with previous configuration instead.)" newsha <- getCurrentGitSha1 branchref if oldsha == newsha then next else ifM (actionMessage "Propellor build" $ boolSystem "make" [Param "build"]) ( void $ boolSystem "./propellor" [Param "--continue", Param (show cmdline)] , errorMessage "Propellor build failed!" ) getCurrentGitSha1 :: String -> IO String getCurrentGitSha1 branchref = readProcess "git" ["show-ref", "--hash", branchref] -- spin handles deploying propellor to a remote host, if it's not already -- installed there, or updating it if it is. Once the remote propellor is -- updated, it's run. spin :: HostName -> Host -> IO () spin hn hst = do void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"] void $ boolSystem "git" [Param "push"] cacheparams <- toCommand <$> sshCachingParams hn go cacheparams =<< hostprivdata unlessM (boolSystem "ssh" (map Param (cacheparams ++ ["-t", user, runcmd]))) $ error $ "remote propellor failed (running: " ++ runcmd ++")" where hostprivdata = show . filterPrivData hst <$> decryptPrivData go cacheparams privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do let loop = do status <- getMarked fromh statusMarker case readish =<< status of Just NeedRepoUrl -> do sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl) loop Just NeedPrivData -> do sendprivdata toh privdata loop Just NeedGitPush -> do sendMarked toh gitPushMarker "" unlessM (boolSystem "git" [Param "send-pack", Param "--thin", Param "."]) $ warningMessage "git send-pack failed" -- no more protocol possible after -- git push Just NeedGitClone -> do hClose toh hClose fromh sendGitClone hn go cacheparams privdata -- Ready is only sent by old versions of -- propellor. They expect to get privdata, -- and then no more protocol communication. Just Ready -> do sendprivdata toh privdata hClose toh -- Display remaining output. void $ tryIO $ forever $ showremote =<< hGetLine fromh hClose fromh Nothing -> return () loop user = "root@"++hn mkcmd = shellWrap . intercalate " ; " bootstrapcmd = 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 --run " ++ hn ] showremote s = putStrLn s sendprivdata toh privdata = void $ actionMessage ("Sending privdata (" ++ show (length privdata) ++ " bytes) to " ++ hn) $ do sendMarked toh privDataMarker privdata return True -- Initial git clone, used for bootstrapping. sendGitClone :: HostName -> IO () sendGitClone hn = void $ actionMessage ("Pushing git repository to " ++ hn) $ do branch <- getCurrentBranch cacheparams <- sshCachingParams hn withTmpFile "propellor.git" $ \tmp _ -> allM id [ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"] , boolSystem "scp" $ cacheparams ++ [File tmp, Param ("root@"++hn++":"++remotebundle)] , boolSystem "ssh" $ cacheparams ++ [Param ("root@"++hn), Param $ unpackcmd branch] ] where remotebundle = "/usr/local/propellor.git" unpackcmd branch = shellWrap $ intercalate " && " [ "git clone " ++ remotebundle ++ " " ++ localdir , "cd " ++ localdir , "git checkout -b " ++ branch , "git remote rm origin" , "rm -f " ++ remotebundle ] -- Called "boot" for historical reasons, but what this really does is -- update the privdata, repo url, and git repo over the ssh connection from the -- client that ran propellor --spin. boot :: IO () boot = do req NeedRepoUrl repoUrlMarker setRepoUrl makePrivDataDir req NeedPrivData privDataMarker $ writeFileProtected privDataLocal req NeedGitPush gitPushMarker $ \_ -> do hin <- dup stdInput hClose stdin hout <- dup stdOutput hClose stdout unlessM (boolSystem "git" [Param "pull", Param $ "--upload=pack=./propellor gitpush " ++ show hin ++ " " ++ show hout, Param "."]) $ warningMessage "git pull from client failed" -- Shim for git push over the propellor ssh channel. -- Reads from stdin and sends it to the first fd; -- reads from the second fd and sends it to stdout. gitPush :: Fd -> Fd -> IO () gitPush hin hout = do print ("gitPush", hin, hout) void $ fromstdin `concurrently` tostdout where fromstdin = do h <- fdToHandle hin B.getContents >>= B.hPut h tostdout = do h <- fdToHandle hout B.hGetContents h >>= B.putStr setRepoUrl :: String -> IO () setRepoUrl "" = return () setRepoUrl url = do rs <- lines <$> readProcess "git" ["remote"] let subcmd = if "origin" `elem` rs then "set-url" else "add" void $ boolSystem "git" [Param "remote", Param subcmd, Param "origin", Param url] -- same as --set-upstream-to, except origin branch -- may not have been pulled yet branch <- getCurrentBranch let branchval s = "branch." ++ branch ++ "." ++ s void $ boolSystem "git" [Param "config", Param (branchval "remote"), Param "origin"] void $ boolSystem "git" [Param "config", Param (branchval "merge"), Param $ "refs/heads/"++branch] getRepoUrl :: IO (Maybe String) getRepoUrl = getM get urls where urls = ["remote.deploy.url", "remote.origin.url"] get u = do v <- catchMaybeIO $ takeWhile (/= '\n') <$> readProcess "git" ["config", u] return $ case v of Just url | not (null url) -> Just url _ -> Nothing checkDebugMode :: IO () checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" where go (Just s) | s == "1" = do f <- setFormatter <$> streamHandler stderr DEBUG <*> pure (simpleLogFormatter "[$time] $msg") updateGlobalLogger rootLoggerName $ setLevel DEBUG . setHandlers [f] go _ = noop -- Parameters can be passed to both ssh and scp, to enable a ssh connection -- caching socket. -- -- If the socket already exists, check if its mtime is older than 10 -- minutes, and if so stop that ssh process, in order to not try to -- use an old stale connection. (atime would be nicer, but there's -- a good chance a laptop uses noatime) sshCachingParams :: HostName -> IO [CommandParam] sshCachingParams hn = do home <- myHomeDir let cachedir = home ".ssh" "propellor" createDirectoryIfMissing False cachedir let socketfile = cachedir hn ++ ".sock" let ps = [ Param "-o", Param ("ControlPath=" ++ socketfile) , Params "-o ControlMaster=auto -o ControlPersist=yes" ] maybe noop (expireold ps socketfile) =<< catchMaybeIO (getFileStatus socketfile) return ps where expireold ps f s = do now <- truncate <$> getPOSIXTime :: IO Integer if modificationTime s > fromIntegral now - tenminutes then touchFile f else do void $ boolSystem "ssh" $ [ Params "-O stop" ] ++ ps ++ [ Param "localhost" ] nukeFile f tenminutes = 600