summaryrefslogtreecommitdiff
path: root/src/Propellor/CmdLine.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/CmdLine.hs')
-rw-r--r--src/Propellor/CmdLine.hs392
1 files changed, 392 insertions, 0 deletions
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
new file mode 100644
index 00000000..ab1d7f9e
--- /dev/null
+++ b/src/Propellor/CmdLine.hs
@@ -0,0 +1,392 @@
+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 Propellor
+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 --set hostname field"
+ , " propellor --add-key keyid"
+ ]
+ exitFailure
+
+processCmdLine :: IO CmdLine
+processCmdLine = go =<< getArgs
+ where
+ go ("--help":_) = usage
+ go ("--spin":h:[]) = return $ Spin h
+ go ("--boot":h:[]) = return $ Boot h
+ go ("--add-key":k:[]) = return $ AddKey k
+ go ("--set":h:f:[]) = case readish f of
+ Just pf -> return $ Set h pf
+ Nothing -> errorMessage $ "Unknown privdata field " ++ f
+ 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 (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
+
+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 hn field) = setPrivData hn field
+ go _ (AddKey keyid) = addKey keyid
+ go _ (Chain hn) = withprops hn $ \attr ps -> do
+ r <- runPropellor attr $ ensureProperties ps
+ putStrLn $ "\n" ++ show r
+ go _ (Docker hn) = Docker.chain hn
+ go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
+ go True cmdline = updateFirst cmdline $ go False cmdline
+ go False (Spin hn) = withprops hn $ const . const $ spin hn
+ go False (Run hn) = ifM ((==) 0 <$> getRealUserID)
+ ( onlyProcess $ withprops hn mainProperties
+ , go True (Spin hn)
+ )
+ go False (Boot hn) = onlyProcess $ withprops hn boot
+
+ withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO ()
+ withprops hn a = maybe
+ (unknownhost hn)
+ (\h -> a (hostAttr h) (hostProperties h))
+ (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 -> IO a
+unknownhost h = 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)"
+ ]
+
+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"]
+
+ 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
+ else errorMessage $ "git branch " ++ originbranch ++ " is not signed with a trusted gpg key; refusing to deploy it!"
+
+ oldsha <- getCurrentGitSha1 branchref
+ void $ boolSystem "git" [Param "merge", Param originbranch]
+ 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 :: HostName -> IO ()
+spin hn = do
+ url <- getUrl
+ void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
+ void $ boolSystem "git" [Param "push"]
+ cacheparams <- toCommand <$> sshCachingParams hn
+ go cacheparams url =<< gpgDecrypt (privDataFile hn)
+ where
+ go cacheparams url privdata = withBothHandles createProcessSuccess (proc "ssh" $ cacheparams ++ [user, bootstrapcmd]) $ \(toh, fromh) -> do
+ let finish = do
+ senddata toh (privDataFile hn) privDataMarker privdata
+ hClose toh
+
+ -- Display remaining output.
+ void $ tryIO $ forever $
+ showremote =<< hGetLine fromh
+ hClose fromh
+ status <- getstatus fromh `catchIO` (const $ errorMessage "protocol error (perhaps the remote propellor failed to run?)")
+ case status of
+ Ready -> finish
+ NeedGitClone -> do
+ hClose toh
+ hClose fromh
+ sendGitClone hn url
+ go cacheparams url privdata
+
+ user = "root@"++hn
+
+ bootstrapcmd = shellWrap $ intercalate " ; "
+ [ "if [ ! -d " ++ localdir ++ " ]"
+ , "then " ++ intercalate " && "
+ [ "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"
+ ]
+
+ getstatus :: Handle -> IO BootStrapStatus
+ getstatus h = do
+ l <- hGetLine h
+ case readish =<< fromMarked statusMarker l of
+ Nothing -> do
+ showremote l
+ getstatus h
+ Just status -> return status
+
+ showremote s = putStrLn s
+ senddata toh f marker s = void $
+ actionMessage ("Sending " ++ f ++ " (" ++ show (length s) ++ " bytes) to " ++ hn) $ do
+ sendMarked toh marker s
+ return True
+
+sendGitClone :: HostName -> String -> IO ()
+sendGitClone hn url = 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
+ , "git remote add origin " ++ url
+ -- same as --set-upstream-to, except origin branch
+ -- has not been pulled yet
+ , "git config branch."++branch++".remote origin"
+ , "git config branch."++branch++".merge refs/heads/"++branch
+ ]
+
+data BootStrapStatus = Ready | NeedGitClone
+ deriving (Read, Show, Eq)
+
+type Marker = String
+type Marked = String
+
+statusMarker :: Marker
+statusMarker = "STATUS"
+
+privDataMarker :: String
+privDataMarker = "PRIVDATA "
+
+toMarked :: Marker -> String -> String
+toMarked marker = intercalate "\n" . map (marker ++) . lines
+
+sendMarked :: Handle -> Marker -> String -> IO ()
+sendMarked h marker s = do
+ -- Prefix string with newline because sometimes a
+ -- incomplete line is output.
+ hPutStrLn h ("\n" ++ toMarked marker s)
+ hFlush h
+
+fromMarked :: Marker -> Marked -> Maybe String
+fromMarked marker s
+ | null matches = Nothing
+ | otherwise = Just $ intercalate "\n" $
+ map (drop len) matches
+ where
+ len = length marker
+ matches = filter (marker `isPrefixOf`) $ lines s
+
+boot :: Attr -> [Property] -> IO ()
+boot attr ps = do
+ sendMarked stdout statusMarker $ show Ready
+ reply <- hGetContentsStrict stdin
+
+ makePrivDataDir
+ maybe noop (writeFileProtected privDataLocal) $
+ fromMarked privDataMarker reply
+ mainProperties attr ps
+
+addKey :: String -> IO ()
+addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ]
+ where
+ gpg = do
+ createDirectoryIfMissing True privDataDir
+ boolSystem "sh"
+ [ Param "-c"
+ , Param $ "gpg --export " ++ keyid ++ " | gpg " ++
+ unwords (gpgopts ++ ["--import"])
+ ]
+ gitadd = boolSystem "git"
+ [ Param "add"
+ , File keyring
+ ]
+
+ gitconfig = boolSystem "git"
+ [ Param "config"
+ , Param "user.signingkey"
+ , Param keyid
+ ]
+
+ gitcommit = gitCommit
+ [ File keyring
+ , Param "-m"
+ , Param "propellor addkey"
+ ]
+
+{- Automatically sign the commit if there'a a keyring. -}
+gitCommit :: [CommandParam] -> IO Bool
+gitCommit ps = do
+ k <- doesFileExist keyring
+ boolSystem "git" $ catMaybes $
+ [ Just (Param "commit")
+ , if k then Just (Param "--gpg-sign") else Nothing
+ ] ++ map Just ps
+
+keyring :: FilePath
+keyring = privDataDir </> "keyring.gpg"
+
+gpgopts :: [String]
+gpgopts = ["--options", "/dev/null", "--no-default-keyring", "--keyring", keyring]
+
+getUrl :: IO String
+getUrl = maybe nourl return =<< getM get urls
+ where
+ urls = ["remote.deploy.url", "remote.origin.url"]
+ nourl = errorMessage $ "Cannot find deploy url in " ++ show urls
+ 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