propellor/Propellor/CmdLine.hs

314 lines
9.3 KiB
Haskell

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 Propellor
import qualified Propellor.Property.Docker as Docker
import Utility.FileMode
import Utility.SafeCommand
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 :: [HostName -> Maybe [Property]] -> IO ()
defaultMain getprops = do
checkDebugMode
cmdline <- processCmdLine
debug ["command line: ", show cmdline]
go True cmdline
where
go _ (Continue cmdline) = go False cmdline
go _ (Set host field) = setPrivData host field
go _ (AddKey keyid) = addKey keyid
go _ (Chain host) = withprops host $ \ps -> do
r <- ensureProperties' ps
putStrLn $ "\n" ++ show r
go _ (Docker host) = Docker.chain host
go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline
go True cmdline = updateFirst cmdline $ go False cmdline
go False (Spin host) = withprops host $ const $ spin host
go False (Run host) = withprops host $ ensureProperties
go False (Boot host) = withprops host $ boot
withprops host a = maybe (unknownhost host) a $
headMaybe $ catMaybes $ map (\get -> get host) getprops
unknownhost :: HostName -> IO a
unknownhost h = errorMessage $ unwords
[ "Unknown host:", h
, "(perhaps you should specify the real hostname on the command line?)"
]
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"
updateFirst :: CmdLine -> IO () -> IO ()
updateFirst cmdline next = do
branchref <- takeWhile (/= '\n')
<$> readProcess "git" ["symbolic-ref", "HEAD"]
let originbranch = "origin" </> takeFileName branchref
void $ actionMessage "Git fetch" $ boolSystem "git" [Param "fetch"]
whenM (doesFileExist keyring) $ do
{- To verify origin/master 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 </> "trustring.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 host = do
url <- getUrl
void $ gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param "propellor spin"]
void $ boolSystem "git" [Param "push"]
go url =<< gpgDecrypt (privDataFile host)
where
go url privdata = withBothHandles createProcessSuccess (proc "ssh" [user, bootstrapcmd]) $ \(toh, fromh) -> do
let finish = do
senddata toh (privDataFile host) 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 host url
go url privdata
user = "root@"++host
bootstrapcmd = shellWrap $ intercalate " ; "
[ "if [ ! -d " ++ localdir ++ " ]"
, "then " ++ intercalate " && "
[ "apt-get -y install git"
, "echo " ++ toMarked statusMarker (show NeedGitClone)
]
, "else " ++ intercalate " && "
[ "cd " ++ localdir
, "if ! test -x ./propellor; then make build; fi"
, "./propellor --boot " ++ host
]
, "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 " ++ host) $ do
sendMarked toh marker s
return True
sendGitClone :: HostName -> String -> IO ()
sendGitClone host url = void $ actionMessage ("Pushing git repository to " ++ host) $
withTmpFile "propellor.git." $ \tmp _ -> allM id
-- TODO: ssh connection caching, or better push method
-- with less connections.
[ boolSystem "git" [Param "bundle", Param "create", File tmp, Param "HEAD"]
, boolSystem "scp" [File tmp, Param ("root@"++host++":"++remotebundle)]
, boolSystem "ssh" [Param ("root@"++host), Param unpackcmd]
]
where
remotebundle = "/usr/local/propellor.git"
unpackcmd = shellWrap $ intercalate " && "
[ "git clone " ++ remotebundle ++ " " ++ localdir
, "cd " ++ localdir
, "git checkout -b master"
, "git remote rm origin"
, "git remote add origin " ++ url
, "rm -f " ++ remotebundle
]
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 :: [Property] -> IO ()
boot props = do
sendMarked stdout statusMarker $ show Ready
reply <- hGetContentsStrict stdin
makePrivDataDir
maybe noop (writeFileProtected privDataLocal) $
fromMarked privDataMarker reply
ensureProperties props
addKey :: String -> IO ()
addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitcommit ]
where
gpg = boolSystem "sh"
[ Param "-c"
, Param $ "gpg --export " ++ keyid ++ " | gpg " ++
unwords (gpgopts ++ ["--import"])
]
gitadd = boolSystem "git"
[ Param "add"
, File keyring
]
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