2017-12-27 05:46:44 +03:00
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
2021-10-18 17:25:58 +03:00
|
|
|
|
{-# LANGUAGE CPP #-}
|
2015-09-24 23:57:44 +03:00
|
|
|
|
|
|
|
|
|
module Main (main) where
|
2014-06-04 01:15:39 +04:00
|
|
|
|
|
2017-12-27 20:44:53 +03:00
|
|
|
|
import Control.Concurrent.Async
|
|
|
|
|
import Control.Concurrent.STM
|
|
|
|
|
import Control.Monad
|
2021-10-18 17:25:58 +03:00
|
|
|
|
|
2022-01-19 16:16:15 +03:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2017-12-27 20:44:53 +03:00
|
|
|
|
import Data.Version (showVersion)
|
2018-09-21 16:32:23 +03:00
|
|
|
|
import qualified Data.Yaml.Config as Yaml
|
2017-12-27 05:46:44 +03:00
|
|
|
|
import Development.GitRev
|
2021-03-22 05:29:18 +03:00
|
|
|
|
import Formatting (formatToString, string, (%))
|
2017-12-27 20:44:53 +03:00
|
|
|
|
import Numeric.Natural
|
|
|
|
|
import Options.Applicative hiding (str)
|
|
|
|
|
import Path
|
|
|
|
|
import Path.IO
|
|
|
|
|
import Paths_hapistrano (version)
|
|
|
|
|
import System.Exit
|
2017-02-21 19:45:56 +03:00
|
|
|
|
import qualified System.Hapistrano as Hap
|
|
|
|
|
import qualified System.Hapistrano.Commands as Hap
|
2020-03-30 03:54:39 +03:00
|
|
|
|
import qualified System.Hapistrano.Config as C
|
2017-02-21 19:45:56 +03:00
|
|
|
|
import qualified System.Hapistrano.Core as Hap
|
2017-12-27 20:44:53 +03:00
|
|
|
|
import System.Hapistrano.Types
|
|
|
|
|
import System.IO
|
2017-01-28 16:43:45 +03:00
|
|
|
|
|
2017-02-06 18:04:00 +03:00
|
|
|
|
----------------------------------------------------------------------------
|
|
|
|
|
-- Command line options
|
|
|
|
|
|
|
|
|
|
-- | Command line options.
|
|
|
|
|
|
|
|
|
|
data Opts = Opts
|
2017-12-27 20:44:53 +03:00
|
|
|
|
{ optsCommand :: Command
|
2017-02-20 17:33:12 +03:00
|
|
|
|
, optsConfigFile :: FilePath
|
2017-02-06 18:04:00 +03:00
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
-- | Command to execute and command-specific options.
|
|
|
|
|
|
|
|
|
|
data Command
|
2022-01-19 16:16:15 +03:00
|
|
|
|
= Deploy (Maybe ReleaseFormat) (Maybe Natural) Bool -- ^ Deploy a new release (with timestamp
|
2017-02-06 18:04:00 +03:00
|
|
|
|
-- format and how many releases to keep)
|
|
|
|
|
| Rollback Natural -- ^ Rollback to Nth previous release
|
|
|
|
|
|
|
|
|
|
parserInfo :: ParserInfo Opts
|
2017-03-30 13:56:54 +03:00
|
|
|
|
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)
|
2017-12-27 05:46:44 +03:00
|
|
|
|
versionOption = infoOption
|
|
|
|
|
(formatToString
|
|
|
|
|
("Hapistrano: "% string
|
|
|
|
|
% "\nbranch: " % string
|
|
|
|
|
% "\nrevision: " % string)
|
2017-03-30 13:56:54 +03:00
|
|
|
|
(showVersion version)
|
2017-12-27 05:46:44 +03:00
|
|
|
|
$(gitBranch)
|
|
|
|
|
$(gitHash))
|
|
|
|
|
(long "version" <> short 'v' <> help "Show version information")
|
2017-02-06 18:04:00 +03:00
|
|
|
|
|
|
|
|
|
optionParser :: Parser Opts
|
|
|
|
|
optionParser = Opts
|
2017-05-16 05:38:22 +03:00
|
|
|
|
<$> hsubparser
|
2017-02-06 18:04:00 +03:00
|
|
|
|
( command "deploy"
|
|
|
|
|
(info deployParser (progDesc "Deploy a new release")) <>
|
|
|
|
|
command "rollback"
|
|
|
|
|
(info rollbackParser (progDesc "Roll back to Nth previous release")) )
|
2017-02-20 17:33:12 +03:00
|
|
|
|
<*> strOption
|
|
|
|
|
( long "config"
|
|
|
|
|
<> short 'c'
|
|
|
|
|
<> value "hap.yaml"
|
|
|
|
|
<> metavar "PATH"
|
|
|
|
|
<> showDefault
|
|
|
|
|
<> help "Configuration file to use" )
|
2017-02-06 18:04:00 +03:00
|
|
|
|
|
|
|
|
|
deployParser :: Parser Command
|
|
|
|
|
deployParser = Deploy
|
2018-10-19 22:01:28 +03:00
|
|
|
|
<$> 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'"
|
|
|
|
|
)
|
|
|
|
|
)
|
2022-01-19 16:16:15 +03:00
|
|
|
|
<*> switch
|
|
|
|
|
( long "keep-one-failed"
|
|
|
|
|
<> short 'f'
|
|
|
|
|
<> help "Keep all failed releases or just one -the latest-, default (without using this flag) is to keep all failed releases."
|
|
|
|
|
)
|
2017-02-06 18:04:00 +03:00
|
|
|
|
|
|
|
|
|
rollbackParser :: Parser Command
|
|
|
|
|
rollbackParser = Rollback
|
|
|
|
|
<$> option auto
|
|
|
|
|
( long "use-nth"
|
|
|
|
|
<> short 'n'
|
|
|
|
|
<> value 1
|
2017-02-20 17:33:12 +03:00
|
|
|
|
<> showDefault
|
|
|
|
|
<> help "How many deployments back to go?" )
|
2017-02-06 18:04:00 +03:00
|
|
|
|
|
|
|
|
|
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
|
|
|
|
|
2017-03-01 23:40:08 +03: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 ()
|
2017-02-06 18:04:00 +03:00
|
|
|
|
main = do
|
|
|
|
|
Opts {..} <- execParser parserInfo
|
2018-09-21 16:32:23 +03:00
|
|
|
|
C.Config{..} <- Yaml.loadYamlSettings [optsConfigFile] [] Yaml.useEnv
|
|
|
|
|
chan <- newTChanIO
|
|
|
|
|
let task rf = Task { taskDeployPath = configDeployPath
|
2020-03-30 03:54:39 +03:00
|
|
|
|
, taskSource = configSource
|
2018-09-21 16:32:23 +03:00
|
|
|
|
, taskReleaseFormat = rf }
|
|
|
|
|
let printFnc dest str = atomically $
|
|
|
|
|
writeTChan chan (PrintMsg dest str)
|
2019-01-09 21:49:43 +03:00
|
|
|
|
hap shell sshOpts = do
|
|
|
|
|
r <- Hap.runHapistrano sshOpts shell printFnc $
|
2018-09-21 16:32:23 +03:00
|
|
|
|
case optsCommand of
|
2022-01-19 16:16:15 +03:00
|
|
|
|
Deploy cliReleaseFormat cliKeepReleases cliKeepOneFailed -> do
|
2018-10-19 22:01:28 +03:00
|
|
|
|
let releaseFormat = fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat
|
|
|
|
|
keepReleases = fromMaybeKeepReleases cliKeepReleases configKeepReleases
|
2022-01-19 16:16:15 +03:00
|
|
|
|
keepOneFailed = cliKeepOneFailed || configKeepOneFailed
|
2018-09-21 16:32:23 +03:00
|
|
|
|
forM_ configRunLocally Hap.playScriptLocally
|
2019-01-09 20:05:37 +03:00
|
|
|
|
release <- if configVcAction
|
|
|
|
|
then Hap.pushRelease (task releaseFormat)
|
|
|
|
|
else Hap.pushReleaseWithoutVc (task releaseFormat)
|
2021-01-22 18:08:05 +03:00
|
|
|
|
rpath <- Hap.releasePath configDeployPath release configWorkingDir
|
2020-03-30 03:54:39 +03:00
|
|
|
|
forM_ (toMaybePath configSource) $ \src ->
|
|
|
|
|
Hap.scpDir src rpath
|
2018-09-21 16:32:23 +03:00
|
|
|
|
forM_ configCopyFiles $ \(C.CopyThing src dest) -> do
|
|
|
|
|
srcPath <- resolveFile' src
|
|
|
|
|
destPath <- parseRelFile dest
|
|
|
|
|
let dpath = rpath </> destPath
|
|
|
|
|
(Hap.exec . Hap.MkDir . parent) dpath
|
|
|
|
|
Hap.scpFile srcPath dpath
|
|
|
|
|
forM_ configCopyDirs $ \(C.CopyThing src dest) -> do
|
|
|
|
|
srcPath <- resolveDir' src
|
|
|
|
|
destPath <- parseRelDir dest
|
|
|
|
|
let dpath = rpath </> destPath
|
|
|
|
|
(Hap.exec . Hap.MkDir . parent) dpath
|
|
|
|
|
Hap.scpDir srcPath dpath
|
2019-01-09 20:05:37 +03:00
|
|
|
|
forM_ configLinkedFiles
|
|
|
|
|
(Hap.linkToShared configTargetSystem rpath configDeployPath)
|
|
|
|
|
forM_ configLinkedDirs
|
|
|
|
|
(Hap.linkToShared configTargetSystem rpath configDeployPath)
|
2021-01-22 18:08:05 +03:00
|
|
|
|
forM_ configBuildScript (Hap.playScript configDeployPath release configWorkingDir)
|
2018-09-21 16:32:23 +03:00
|
|
|
|
Hap.registerReleaseAsComplete configDeployPath release
|
|
|
|
|
Hap.activateRelease configTargetSystem configDeployPath release
|
2018-10-19 22:01:28 +03:00
|
|
|
|
Hap.dropOldReleases configDeployPath keepReleases
|
2018-09-21 16:32:23 +03:00
|
|
|
|
forM_ configRestartCommand Hap.exec
|
|
|
|
|
Rollback n -> do
|
|
|
|
|
Hap.rollback configTargetSystem configDeployPath n
|
|
|
|
|
forM_ configRestartCommand Hap.exec
|
|
|
|
|
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
|
2019-01-09 21:49:43 +03:00
|
|
|
|
[] -> [hap Bash Nothing] -- localhost, no SSH
|
2018-09-21 16:32:23 +03:00
|
|
|
|
xs ->
|
2022-01-19 16:16:15 +03:00
|
|
|
|
let runHap C.Target{..} =
|
2019-10-29 00:23:01 +03:00
|
|
|
|
hap targetShell (Just $ SshOptions targetHost targetPort targetSshArgs)
|
2019-01-09 21:49:43 +03:00
|
|
|
|
in runHap <$> xs
|
2018-09-21 16:32:23 +03:00
|
|
|
|
results <- (runConcurrently . traverse Concurrently)
|
|
|
|
|
((Right () <$ printer (length haps)) : haps)
|
|
|
|
|
case sequence_ results of
|
|
|
|
|
Left n -> exitWith (ExitFailure n)
|
|
|
|
|
Right () -> putStrLn "Success."
|