Implement concurrent multihost deployment (#60)

* Implement concurrent multi-host deployment
* Fix a couple of typos/obsolete info in ‘CHANGELOG.md’

CHANGELOG.md

@@ -2,10 +2,12 @@
 
 * Fixed a bug with repos not being fetched properly.
 
+* Implemented concurrent deployment to multiple hosts.
+
 ## 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
@@ -15,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.

README.md

@@ -99,6 +99,39 @@ repo) and specifies where to put the files/directories on target machine.
 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).

app/Config.hs

@@ -7,6 +7,9 @@ module Config
 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 @@ import System.Hapistrano.Commands
 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 @@ data CopyThing = CopyThing FilePath FilePath
 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") >>=

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 @@ pReleaseFormat = eitherReader $ \s ->
 ----------------------------------------------------------------------------
 -- 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 () -> putStr "Success."

hapistrano.cabal

@@ -61,11 +61,13 @@ executable hap
   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

spec/System/HapistranoSpec.hs

@@ -9,6 +9,7 @@ import Control.Monad.Reader
 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
@@ -146,7 +147,18 @@ justExec path cmd' =
 -- | 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.
 

src/System/Hapistrano/Core.hs

@@ -30,28 +30,28 @@ import Path
 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 @@ exec' prog args cmd = do
         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) '*'

src/System/Hapistrano/Types.hs

@@ -16,6 +16,7 @@ module System.Hapistrano.Types
   , Task (..)
   , ReleaseFormat(..)
   , SshOptions (..)
+  , OutputDest (..)
   , Release
   , mkRelease
   , releaseTime
@@ -40,8 +41,10 @@ data Failure = Failure Int (Maybe String)
 -- | 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 @@ data Task = Task
     -- ^ 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 ReleaseFormat
 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.