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