hapistrano/app/Main.hs

184 lines
6.4 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Main (main) where
2014-06-04 01:15:39 +04:00
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Data.Monoid ((<>))
#endif
import Data.Version (showVersion)
import qualified Data.Yaml.Config as Yaml
import Development.GitRev
import Formatting (formatToString, string, (%))
import Options.Applicative hiding (str)
import Paths_hapistrano (version)
import System.Exit
import qualified System.Hapistrano as Hap
import qualified System.Hapistrano.Config as C
import qualified System.Hapistrano.Maintenance as Hap
import System.Hapistrano.Types
import System.IO
2017-01-28 16:43:45 +03:00
----------------------------------------------------------------------------
parserInfo :: ParserInfo Opts
parserInfo =
info
(helper <*> versionOption <*> optionParser)
(fullDesc <> progDesc "Deploy tool for Haskell applications" <>
header "Hapistrano - A deployment library for Haskell applications")
where
versionOption :: Parser (a -> a)
versionOption = infoOption
(formatToString
("Hapistrano: "% string
% "\nbranch: " % string
% "\nrevision: " % string)
(showVersion version)
$(gitBranch)
$(gitHash))
(long "version" <> short 'v' <> help "Show version information")
optionParser :: Parser Opts
optionParser = Opts
2017-05-16 05:38:22 +03:00
<$> hsubparser
( command "deploy"
(info deployParser (progDesc "Deploy a new release")) <>
command "rollback"
(info rollbackParser (progDesc "Roll back to Nth previous release")) <>
command "maintenance"
(info maintenanceParser (progDesc "Enable/Disable maintenance mode")) <>
command "init"
(info initParser (progDesc "Initialize hapistrano file"))
)
<*> strOption
( long "config"
<> short 'c'
<> value "hap.yaml"
<> metavar "PATH"
<> showDefault
<> help "Configuration file to use" )
deployParser :: Parser Command
deployParser = Deploy
<$> optional
( option pReleaseFormat
( long "release-format"
<> short 'r'
<> help "Which format release timestamp format to use: long or short, default is short."
)
)
<*> optional
( option auto
( long "keep-releases"
<> short 'k'
<> help "How many releases to keep, default is '5'"
)
)
<*> switch
( long "keep-one-failed"
<> help "Keep all failed releases or just one -the latest-, default (without using this flag) is to keep all failed releases."
)
rollbackParser :: Parser Command
rollbackParser = Rollback
<$> option auto
( long "use-nth"
<> short 'n'
<> value 1
<> showDefault
<> help "How many deployments back to go?" )
initParser :: Parser Command
initParser = pure InitConfig
maintenanceParser :: Parser Command
maintenanceParser =
Maintenance
<$> hsubparser
( command "enable" (info (pure Enable) (progDesc "Enables maintenance mode"))
<> command "disable" (info (pure Disable) (progDesc "Disables maintenance mode"))
)
pReleaseFormat :: ReadM ReleaseFormat
pReleaseFormat = eitherReader $ \s ->
case s of
"long" -> Right ReleaseLong
"short" -> Right ReleaseShort
_ -> Left ("Unknown format: " ++ s ++ ", try long or short.")
----------------------------------------------------------------------------
-- Main
2014-06-04 01:15:39 +04:00
-- | Message that is used for communication between worker threads and the
-- printer thread.
data Message
= PrintMsg OutputDest String -- ^ Print a message to specified 'OutputDest'
| FinishMsg -- ^ The worker has finished
deriving (Eq, Ord, Show, Read)
2014-06-04 01:15:39 +04:00
main :: IO ()
main = do
opts@Opts{..} <- execParser parserInfo
case optsCommand of
Deploy cliReleaseFormat cliKeepReleases cliKeepOneFailed ->
runHapCmd opts $ \hapConfig@C.Config{..} executionMode ->
Hap.deploy
hapConfig
(fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat)
(fromMaybeKeepReleases cliKeepReleases configKeepReleases)
(cliKeepOneFailed || configKeepOneFailed)
executionMode
Rollback n ->
runHapCmd opts $ \C.Config{..} _ ->
Hap.rollback configTargetSystem configDeployPath n configRestartCommand
Maintenance Enable ->
runHapCmd opts $ \C.Config{..} _ ->
Hap.writeMaintenanceFile configDeployPath configMaintenanceDirectory configMaintenanceFileName
Maintenance _ ->
runHapCmd opts $ \C.Config{..} _ ->
Hap.deleteMaintenanceFile configDeployPath configMaintenanceDirectory configMaintenanceFileName
InitConfig -> Hap.initConfig getLine
runHapCmd :: Opts -> (C.Config -> C.ExecutionMode -> Hapistrano ()) -> IO ()
runHapCmd Opts{..} hapCmd = do
hapConfig@C.Config{..} <- Yaml.loadYamlSettings [optsConfigFile] [] Yaml.useEnv
chan <- newTChanIO
let printFnc dest str = atomically $
writeTChan chan (PrintMsg dest str)
hap shell sshOpts executionMode = do
r <- Hap.runHapistrano sshOpts shell printFnc $ hapCmd hapConfig executionMode
atomically (writeTChan chan FinishMsg)
return r
printer :: Int -> IO ()
printer n = when (n > 0) $ do
msg <- atomically (readTChan chan)
case msg of
PrintMsg StdoutDest str ->
putStr str >> printer n
PrintMsg StderrDest str ->
hPutStr stderr str >> printer n
FinishMsg ->
printer (n - 1)
haps :: [IO (Either Int ())]
haps =
case configHosts of
[] -> [hap Bash Nothing C.LeadTarget] -- localhost, no SSH
targets@(leadTarget : _) ->
let runHap currentTarget@C.Target{..} =
hap targetShell (Just $ SshOptions targetHost targetPort targetSshArgs)
(if leadTarget == currentTarget then C.LeadTarget else C.AllTargets)
in runHap <$> targets
results <- (runConcurrently . traverse Concurrently)
((Right () <$ printer (length haps)) : haps)
case sequence_ results of
Left n -> exitWith (ExitFailure n)
Right () -> putStrLn "Success."