diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,13 @@ +## 0.3.1.0 + +* Fixed a bug with repos not being fetched properly. +* Implemented concurrent deployment to multiple hosts. +* Now completion tokens are dropped automatically like old releases. + ## 0.3.0.1 * Reduced verbosity of some commands to make reading logs easier. -* Restart command is now invoked after activation of new release (is it +* Restart command is now invoked after activation of new release (as it should). * Fix a typo in flag that specifies SSH port for `scp`. * Ensure that containing directories for files and directories to copy @@ -11,8 +17,7 @@ * Add proper set of dependency version constraints. * Use `optparse-applicative` to parse arguments. -* Add support for comments and empty lines to scripts. -* Parse ssh port from `PORT` environment variable. +* Allow to specify non-standard SSH port. * Drop support for GHCs older than 7.10 (because Chris Done's `path` does not compile with them, see: https://github.com/chrisdone/path/issues/46). * Now Hapistrano uses `hap.yaml` file for all its configuration. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -99,6 +99,39 @@ Directories and files with clashing names will be overwritten. Directories are copied recursively. +## Deploying to multiple machines concurrently + +Beginning with Hapistrano 0.3.1.0 it's possible to deploy to several +machines concurrently. The only things you need to do is to adjust your +configuration file and use `targets` parameter instead of `host` and `port`, +like this: + +```haskell +targets: + - host: myserver-a.com + port: 2222 + - host: myserver-b.cmo +# the rest is the same… +``` + +A few things to note here: + +* `host` item is required for every target, but `port` may be omitted and + then it defaults to `22`. + +* The deployment will run concurrently and finish when interactions with all + targets have finished either successfully or not. If at least one + interaction was unsuccessful, the `hap` tool will exit with non-zero exit + code. + +* The log is printed is such a way that messages from several machines get + intermixed, but it's guaranteed that they won't overlap (printing itself + is sequential) and the headers will tell you exactly which machine was + executing which command. + +If you don't specify `host` and `targets`, `hap` will assume `localhost` as +usually, which is mainly useful for testing. + ## License MIT, see [the LICENSE file](LICENSE). diff --git a/app/Config.hs b/app/Config.hs --- a/app/Config.hs +++ b/app/Config.hs @@ -7,6 +7,9 @@ where import Data.Aeson +import Data.Function (on) +import Data.List (nubBy) +import Data.Maybe (maybeToList) import Data.Yaml import Path import System.Hapistrano.Commands @@ -16,10 +19,8 @@ data Config = Config { configDeployPath :: !(Path Abs Dir) -- ^ Top-level deploy directory on target machine - , configHost :: !(Maybe String) - -- ^ Host to deploy to. If missing, localhost will be assumed. - , configPort :: !Word - -- ^ SSH port number to use, may be omitted + , configHosts :: ![(String, Word)] + -- ^ Hosts\/ports to deploy to. If empty, localhost will be assumed. , configRepo :: !String -- ^ Location of repository that contains the source code to deploy , configRevision :: !String @@ -44,8 +45,15 @@ instance FromJSON Config where parseJSON = withObject "Hapistrano configuration" $ \o -> do configDeployPath <- o .: "deploy_path" - configHost <- o .:? "host" - configPort <- o .:? "port" .!= 22 + let grabPort m = m .:? "port" .!= 22 + host <- o .:? "host" + port <- grabPort o + hs <- (o .:? "targets" .!= []) >>= mapM (\m -> do + host' <- m .: "host" + port' <- grabPort m + return (host', port')) + let configHosts = nubBy ((==) `on` fst) + (maybeToList ((,) <$> host <*> pure port) ++ hs) configRepo <- o .: "repo" configRevision <- o .: "revision" configRestartCommand <- (o .:? "restart_command") >>= diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -3,16 +3,19 @@ module Main (main) where +import Control.Concurrent.Async +import Control.Concurrent.STM import Control.Monad import Data.Monoid ((<>)) import Data.Version (showVersion) import Numeric.Natural -import Options.Applicative +import Options.Applicative hiding (str) import Path import Path.IO import Paths_hapistrano (version) import System.Exit import System.Hapistrano.Types +import System.IO import qualified Config as C import qualified Data.Yaml as Yaml import qualified System.Hapistrano as Hap @@ -99,44 +102,80 @@ ---------------------------------------------------------------------------- -- Main +-- | 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) + main :: IO () main = do Opts {..} <- execParser parserInfo when optsVersion $ do putStrLn $ "Hapistrano " ++ showVersion version exitSuccess - econfig <- Yaml.decodeFileEither optsConfigFile case econfig of Left err -> do putStrLn (Yaml.prettyPrintParseException err) exitFailure - Right C.Config {..} -> - Hap.runHapistrano (SshOptions <$> configHost <*> pure configPort) $ case optsCommand of - Deploy releaseFormat n -> do - release <- Hap.pushRelease Task - { taskDeployPath = configDeployPath - , taskRepository = configRepo - , taskRevision = configRevision - , taskReleaseFormat = releaseFormat } - rpath <- Hap.releasePath configDeployPath release - 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 - forM_ configBuildScript (Hap.playScript configDeployPath release) - Hap.registerReleaseAsComplete configDeployPath release - Hap.activateRelease configDeployPath release - Hap.dropOldReleases configDeployPath n - forM_ configRestartCommand Hap.exec - Rollback n -> do - Hap.rollback configDeployPath n - forM_ configRestartCommand Hap.exec + Right C.Config {..} -> do + chan <- newTChanIO + let printFnc dest str = atomically $ + writeTChan chan (PrintMsg dest str) + hap sshOpts = do + r <- Hap.runHapistrano sshOpts printFnc $ + case optsCommand of + Deploy releaseFormat n -> do + release <- Hap.pushRelease Task + { taskDeployPath = configDeployPath + , taskRepository = configRepo + , taskRevision = configRevision + , taskReleaseFormat = releaseFormat } + rpath <- Hap.releasePath configDeployPath release + 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 + forM_ configBuildScript (Hap.playScript configDeployPath release) + Hap.registerReleaseAsComplete configDeployPath release + Hap.activateRelease configDeployPath release + Hap.dropOldReleases configDeployPath n + forM_ configRestartCommand Hap.exec + Rollback n -> do + Hap.rollback 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 + [] -> [hap Nothing] -- localhost, no SSH + xs -> + let f (host, port) = SshOptions host port + in hap . Just . f <$> xs + results <- (runConcurrently . sequenceA . fmap Concurrently) + ((Right () <$ printer (length haps)) : haps) + case sequence_ results of + Left n -> exitWith (ExitFailure n) + Right () -> putStrLn "Success." diff --git a/hapistrano.cabal b/hapistrano.cabal --- a/hapistrano.cabal +++ b/hapistrano.cabal @@ -1,5 +1,5 @@ name: hapistrano -version: 0.3.0.1 +version: 0.3.1.0 synopsis: A deployment library for Haskell applications description: . @@ -61,11 +61,13 @@ main-is: Main.hs other-modules: Config build-depends: aeson >= 0.11 && < 1.2 + , async >= 2.0.1.6 && < 2.2 , base >= 4.6 && < 5.0 , hapistrano , optparse-applicative >= 0.11 && < 0.14 , path >= 0.5.8 && < 6.0 , path-io >= 1.2 && < 1.3 + , stm >= 2.4 && < 2.5 , yaml >= 0.8 && < 0.9 if flag(dev) ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror diff --git a/spec/System/HapistranoSpec.hs b/spec/System/HapistranoSpec.hs --- a/spec/System/HapistranoSpec.hs +++ b/spec/System/HapistranoSpec.hs @@ -9,6 +9,7 @@ import Path import Path.IO import System.Hapistrano.Types +import System.IO import Test.Hspec hiding (shouldBe, shouldReturn) import qualified System.Hapistrano as Hap import qualified System.Hapistrano.Commands as Hap @@ -83,8 +84,10 @@ describe "dropOldReleases" $ it "works" $ \(deployPath, repoPath) -> runHap $ do - let task = mkTask deployPath repoPath - rs <- replicateM 7 (Hap.pushRelease task) + rs <- replicateM 7 $ do + r <- Hap.pushRelease (mkTask deployPath repoPath) + Hap.registerReleaseAsComplete deployPath r + return r Hap.dropOldReleases deployPath 5 -- two oldest releases should not survive: forM_ (take 2 rs) $ \r -> @@ -94,6 +97,14 @@ forM_ (drop 2 rs) $ \r -> (Hap.releasePath deployPath r >>= doesDirExist) `shouldReturn` True + -- two oldest completion tokens should not survive: + forM_ (take 2 rs) $ \r -> + (Hap.ctokenPath deployPath r >>= doesFileExist) + `shouldReturn` False + -- 5 most recent completion tokens should stay alive: + forM_ (drop 2 rs) $ \r -> + (Hap.ctokenPath deployPath r >>= doesFileExist) + `shouldReturn` True ---------------------------------------------------------------------------- -- Helpers @@ -146,7 +157,18 @@ -- | Run 'Hapistrano' monad locally. runHap :: Hapistrano a -> IO a -runHap = Hap.runHapistrano Nothing +runHap m = do + let printFnc dest str = + case dest of + StdoutDest -> putStr str + StderrDest -> hPutStr stderr str + r <- Hap.runHapistrano Nothing printFnc m + case r of + Left n -> do + expectationFailure ("Failed with status code: " ++ show n) + return undefined + -- ↑ because expectationFailure from Hspec has wrong type :-( + Right x -> return x -- | Make a 'Task' given deploy path and path to the repo. diff --git a/src/System/Hapistrano.hs b/src/System/Hapistrano.hs --- a/src/System/Hapistrano.hs +++ b/src/System/Hapistrano.hs @@ -105,10 +105,14 @@ -> Natural -- ^ How many releases to keep -> Hapistrano () -- ^ Deleted Releases dropOldReleases deployPath n = do - releases <- deployedReleases deployPath - forM_ (genericDrop n releases) $ \release -> do + dreleases <- deployedReleases deployPath + forM_ (genericDrop n dreleases) $ \release -> do rpath <- releasePath deployPath release exec (Rm rpath) + creleases <- completedReleases deployPath + forM_ (genericDrop n creleases) $ \release -> do + cpath <- ctokenPath deployPath release + exec (Rm cpath) -- | Play the given script switching to diroctory of given release. diff --git a/src/System/Hapistrano/Commands.hs b/src/System/Hapistrano/Commands.hs --- a/src/System/Hapistrano/Commands.hs +++ b/src/System/Hapistrano/Commands.hs @@ -226,7 +226,8 @@ type Result GitFetch = () renderCommand (GitFetch remote) = formatCmd "git" [ Just "fetch" - , Just remote ] + , Just remote + , Just "+refs/heads/*:refs/heads/*" ] parseResult Proxy _ = () -- | Git reset. diff --git a/src/System/Hapistrano/Core.hs b/src/System/Hapistrano/Core.hs --- a/src/System/Hapistrano/Core.hs +++ b/src/System/Hapistrano/Core.hs @@ -30,28 +30,28 @@ import System.Exit import System.Hapistrano.Commands import System.Hapistrano.Types -import System.IO import System.Process -- | Run the 'Hapistrano' monad. The monad hosts 'exec' actions. runHapistrano :: MonadIO m => Maybe SshOptions -- ^ SSH options to use or 'Nothing' if we run locally + -> (OutputDest -> String -> IO ()) -- ^ How to print messages -> Hapistrano a -- ^ The computation to run - -> m a -- ^ IO-enabled monad that hosts the computation -runHapistrano sshOptions m = liftIO $ do + -> m (Either Int a) -- ^ Status code in 'Left' on failure, result in + -- 'Right' on success +runHapistrano sshOptions printFnc m = liftIO $ do let config = Config - { configSshOptions = sshOptions } + { configSshOptions = sshOptions + , configPrint = printFnc } r <- runReaderT (runExceptT m) config case r of Left (Failure n msg) -> do - forM_ msg (hPutStrLn stderr) - exitWith (ExitFailure n) - Right x -> - x <$ putStrLn "Success." + forM_ msg (printFnc StderrDest) + return (Left n) + Right x -> return (Right x) --- | Fail returning the following status code and printing given message to --- 'stderr'. +-- | Fail returning the following status code and message. failWith :: Int -> Maybe String -> Hapistrano a failWith n msg = throwError (Failure n msg) @@ -126,24 +126,22 @@ case configSshOptions of Nothing -> "localhost" Just SshOptions {..} -> sshHost ++ ":" ++ show sshPort - liftIO $ do - printLine hostLabel - putStrLn ("$ " ++ cmd) + liftIO $ configPrint StdoutDest (putLine hostLabel ++ "$ " ++ cmd ++ "\n") (exitCode, stdout', stderr') <- liftIO (readProcessWithExitCode prog args "") unless (null stdout') . liftIO $ - putStrLn stdout' + configPrint StdoutDest stdout' unless (null stderr') . liftIO $ - hPutStrLn stderr stderr' + configPrint StderrDest stderr' case exitCode of ExitSuccess -> return stdout' ExitFailure n -> failWith n Nothing --- | Print something “inside” a line, sort-of beautifully. +-- | Put something “inside” a line, sort-of beautifully. -printLine :: String -> IO () -printLine str = putStrLn ("*** " ++ str ++ padding) +putLine :: String -> String +putLine str = "*** " ++ str ++ padding ++ "\n" where padding = ' ' : replicate (75 - length str) '*' diff --git a/src/System/Hapistrano/Types.hs b/src/System/Hapistrano/Types.hs --- a/src/System/Hapistrano/Types.hs +++ b/src/System/Hapistrano/Types.hs @@ -16,6 +16,7 @@ , Task (..) , ReleaseFormat(..) , SshOptions (..) + , OutputDest (..) , Release , mkRelease , releaseTime @@ -40,8 +41,10 @@ -- | Hapistrano configuration options. data Config = Config - { configSshOptions :: Maybe SshOptions + { configSshOptions :: !(Maybe SshOptions) -- ^ 'Nothing' if we are running locally, or SSH options to use. + , configPrint :: !(OutputDest -> String -> IO ()) + -- ^ How to print messages } -- | The records describes deployment task. @@ -55,7 +58,7 @@ -- ^ A SHA1 or branch to release , taskReleaseFormat :: ReleaseFormat -- ^ The 'ReleaseFormat' to use - } deriving (Show, Eq) + } deriving (Show, Eq, Ord) -- | Release format mode. @@ -69,7 +72,14 @@ data SshOptions = SshOptions { sshHost :: String -- ^ Host to use , sshPort :: Word -- ^ Port to use - } deriving (Show, Eq, Ord) + } deriving (Show, Read, Eq, Ord) + +-- | Output destination. + +data OutputDest + = StdoutDest + | StderrDest + deriving (Eq, Show, Read, Ord, Bounded, Enum) -- | Release indentifier.