hapistrano 0.3.0.1 → 0.3.1.0

raw patch · 10 files changed

+190/−68 lines, 10 filesdep +asyncdep +stmPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async, stm

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−3
• README.md +33/−0
• app/Config.hs +14/−6
• app/Main.hs +70/−31
• hapistrano.cabal +3/−1
• spec/System/HapistranoSpec.hs +25/−3
• src/System/Hapistrano.hs +6/−2
• src/System/Hapistrano/Commands.hs +2/−1
• src/System/Hapistrano/Core.hs +16/−18
• src/System/Hapistrano/Types.hs +13/−3

@@ -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.

@@ -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).

@@ -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") >>=

@@ -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."

@@ -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

@@ -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. 

@@ -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. 

@@ -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.

@@ -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) '*'

@@ -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.