hapistrano 0.4.6.0 → 0.4.7.0

raw patch · 10 files changed

+211/−140 lines, 10 filesdep +exceptionsdep ~aesonPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: exceptions

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• README.md +2/−2
• app/Main.hs +17/−64
• hapistrano.cabal +5/−6
• spec/System/HapistranoConfigSpec.hs +23/−5
• spec/System/HapistranoSpec.hs +42/−31
• src/System/Hapistrano.hs +76/−10
• src/System/Hapistrano/Config.hs +18/−19
• src/System/Hapistrano/Core.hs +2/−1
• src/System/Hapistrano/Types.hs +22/−2

@@ -1,3 +1,7 @@+## 0.4.7.0+### Modified+* Fix issue #210 which cuased concurrent deploys to pick only the first target.+ ## 0.4.6.0 ### Modified * It sets the origin repository (`git remote set-url origin <repo>`) on every pushed release.

@@ -1,4 +1,4 @@-[![Build](https://github.com/stackbuilders/hapistrano/actions/workflows/build.yml/badge.svg)](https://github.com/stackbuilders/hapistrano/actions/workflows/build.yml)+[![Build](https://github.com/stackbuilders/hapistrano/actions/workflows/build.yml/badge.svg?branch=master)](https://github.com/stackbuilders/hapistrano/actions/workflows/build.yml) [![Draft](https://github.com/stackbuilders/hapistrano/actions/workflows/draft.yml/badge.svg)](https://github.com/stackbuilders/hapistrano/actions/workflows/draft.yml) [![Release](https://github.com/stackbuilders/hapistrano/actions/workflows/release.yml/badge.svg)](https://github.com/stackbuilders/hapistrano/actions/workflows/release.yml) @@ -284,5 +284,5 @@ Do you want to contribute to this project? Please take a look at our [contributing guideline](/docs/CONTRIBUTING.md) to know how you can help us build it.  ----<img src="https://www.stackbuilders.com/media/images/Sb-supports.original.png" alt="Stack Builders" width="50%"></img>+<img src="https://cdn.stackbuilders.com/media/images/Sb-supports.original.png" alt="Stack Builders" width="50%"></img> [Check out our libraries](https://github.com/stackbuilders/) | [Join our team](https://www.stackbuilders.com/join-us/)

@@ -1,7 +1,7 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE CPP               #-}  module Main (main) where @@ -9,26 +9,20 @@ import           Control.Concurrent.STM import           Control.Monad #if !MIN_VERSION_base(4,13,0)-import           Data.Monoid                ((<>))+import           Data.Monoid                   ((<>)) #endif-import           Data.Version               (showVersion)-import qualified Data.Yaml.Config           as Yaml+import           Data.Version                  (showVersion)+import qualified Data.Yaml.Config              as Yaml import           Development.GitRev-import           Formatting                 (formatToString, string, (%))-import           Options.Applicative        hiding (str)-import           Path-import           Path.IO-import           Paths_hapistrano           (version)+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.Commands as Hap-import qualified System.Hapistrano.Config   as C-import qualified System.Hapistrano.Core     as Hap+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-import           System.Hapistrano (createHapistranoDeployState)-import           Control.Monad.Error.Class (throwError, catchError)  ---------------------------------------------------------------------------- @@ -127,62 +121,21 @@ main :: IO () main = do   Opts{..} <- execParser parserInfo-  C.Config{..} <- Yaml.loadYamlSettings [optsConfigFile] [] Yaml.useEnv+  hapConfig@C.Config{..} <- Yaml.loadYamlSettings [optsConfigFile] [] Yaml.useEnv   chan <- newTChanIO-  let task rf = Task { taskDeployPath    = configDeployPath-                     , taskSource        = configSource-                     , taskReleaseFormat = rf }   let printFnc dest str = atomically $         writeTChan chan (PrintMsg dest str)       hap shell sshOpts = do         r <- Hap.runHapistrano sshOpts shell printFnc $           case optsCommand of             Deploy cliReleaseFormat cliKeepReleases cliKeepOneFailed ->-              let releaseFormat = fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat-                  keepReleases = fromMaybeKeepReleases cliKeepReleases configKeepReleases-                  keepOneFailed = cliKeepOneFailed || configKeepOneFailed-                  -- We define the handler for when an exception happens inside a deployment-                  failStateAndThrow e@(_, maybeRelease) = do-                    case maybeRelease of-                      (Just release) -> do-                        createHapistranoDeployState configDeployPath release Fail-                        Hap.dropOldReleases configDeployPath keepReleases keepOneFailed-                        throwError e-                      Nothing -> do-                        throwError e-              in do-                forM_ configRunLocally Hap.playScriptLocally-                release <- if configVcAction-                            then Hap.pushRelease (task releaseFormat)-                            else Hap.pushReleaseWithoutVc (task releaseFormat)-                rpath <- Hap.releasePath configDeployPath release configWorkingDir-                forM_ (toMaybePath configSource) $ \src ->-                  Hap.scpDir src rpath (Just release)-                forM_ configCopyFiles $ \(C.CopyThing src dest) -> do-                  srcPath  <- resolveFile' src-                  destPath <- parseRelFile dest-                  let dpath = rpath </> destPath-                  (flip Hap.exec (Just release) . Hap.MkDir . parent) dpath-                  Hap.scpFile srcPath dpath (Just release)-                forM_ configCopyDirs $ \(C.CopyThing src dest) -> do-                  srcPath  <- resolveDir' src-                  destPath <- parseRelDir dest-                  let dpath = rpath </> destPath-                  (flip Hap.exec (Just release) . Hap.MkDir . parent) dpath-                  Hap.scpDir srcPath dpath (Just release)-                forM_ configLinkedFiles-                  $ flip (Hap.linkToShared configTargetSystem rpath configDeployPath) (Just release)-                forM_ configLinkedDirs-                  $ flip (Hap.linkToShared configTargetSystem rpath configDeployPath) (Just release)-                forM_ configBuildScript (Hap.playScript configDeployPath release configWorkingDir)-                Hap.activateRelease configTargetSystem configDeployPath release-                forM_ configRestartCommand (flip Hap.exec $ Just release)-                Hap.createHapistranoDeployState configDeployPath release System.Hapistrano.Types.Success-                Hap.dropOldReleases configDeployPath keepReleases keepOneFailed-              `catchError` failStateAndThrow-            Rollback n -> do-              Hap.rollback configTargetSystem configDeployPath n-              forM_ configRestartCommand (flip Hap.exec Nothing)+              Hap.deploy+                hapConfig+                (fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat)+                (fromMaybeKeepReleases cliKeepReleases configKeepReleases)+                (cliKeepOneFailed || configKeepOneFailed)+            Rollback n ->+              Hap.rollback configTargetSystem configDeployPath n configRestartCommand             Maintenance Enable-> do               Hap.writeMaintenanceFile configDeployPath configMaintenanceDirectory configMaintenanceFileName             Maintenance _ -> do

@@ -1,6 +1,6 @@ cabal-version:       1.18 name:                hapistrano-version:             0.4.6.0+version:             0.4.7.0 synopsis:            A deployment library for Haskell applications description:   .@@ -59,10 +59,12 @@                      , mtl                >= 2.0 && < 3.0                      , stm                >= 2.0 && < 2.6                      , path               >= 0.5 && < 0.9+                     , path-io            >= 1.2 && < 1.7                      , process            >= 1.4 && < 1.7                      , typed-process      >= 0.2 && < 0.3                      , time               >= 1.5 && < 1.11                      , transformers       >= 0.4 && < 0.6+                     , exceptions         >= 0.10 && < 0.11                      , yaml               >= 0.11.7 && < 0.12   if flag(dev)     ghc-options:       -Wall -Werror@@ -74,16 +76,12 @@   hs-source-dirs:      app   main-is:             Main.hs   other-modules:       Paths_hapistrano-  build-depends:       aeson              >= 2.0 && < 3.0-                     , async              >= 2.0.1.6 && < 2.4+  build-depends:       async              >= 2.0.1.6 && < 2.4                      , base               >= 4.9 && < 5.0                      , formatting         >= 6.2 && < 8.0                      , gitrev             >= 1.2 && < 1.4                      , hapistrano-                     , mtl                >= 2.0 && < 3.0                      , optparse-applicative >= 0.11 && < 0.17-                     , path               >= 0.5 && < 0.9-                     , path-io            >= 1.2 && < 1.7                      , stm                >= 2.4 && < 2.6                      , yaml               >= 0.11.7 && < 0.12   if flag(dev)@@ -103,6 +101,7 @@                      , System.HapistranoConfigSpec                      , System.HapistranoPropsSpec   build-depends:       base               >= 4.9 && < 5.0+                     , aeson                      , directory          >= 1.2.5 && < 1.4                      , filepath           >= 1.2 && < 1.5                      , hapistrano

@@ -1,19 +1,22 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}  module System.HapistranoConfigSpec   ( spec   ) where +import qualified Data.Aeson               as A import           System.Hapistrano.Config (Config (..), Target (..))-import           System.Hapistrano.Types  (Shell (..),-                                           Source (..), TargetSystem (..))+import           System.Hapistrano.Types  (Shell (..), Source (..),+                                           TargetSystem (..))  import qualified Data.Yaml.Config         as Yaml #if MIN_VERSION_base(4,15,0) import           Path                     (mkAbsDir, mkRelDir, mkRelFile) #else-import           Path                     (mkAbsDir, mkRelDir, mkRelFile, Abs, Rel, Dir, File)+import           Path                     (Abs, Dir, File, Rel, mkAbsDir,+                                           mkRelDir, mkRelFile) #endif import           Test.Hspec @@ -35,6 +38,21 @@       it "loads GitRepository as the configuration's source" $         Yaml.loadYamlSettings ["fixtures/git_repository_config.yaml"] [] Yaml.useEnv           >>= (`shouldBe` defaultConfiguration)++    describe "Config From JSON instances" $ do+      context "when contains unique targets" $+        it "parses all unique targets" $+          let eiHosts = fmap targetHost <$> configHosts <$> A.eitherDecode content+              content =+                "{\"targets\":[{\"host\":\"user@app1.com\"},{\"host\":\"user@app2.com\"}],\"deploy_path\":\"/tmp\",\"local_directory\":\"/\"}"+          in eiHosts `shouldBe` Right ["user@app1.com", "user@app2.com"]++      context "when contains duplicated targets" $+        it "parses all only unique targets" $+          let eiHosts = fmap targetHost <$> configHosts <$> A.eitherDecode content+              content =+                "{\"targets\":[{\"host\":\"user@app1.com\"},{\"host\":\"user@app1.com\"}],\"deploy_path\":\"/tmp\",\"local_directory\":\"/\"}"+          in eiHosts `shouldBe` Right ["user@app1.com"]   defaultConfiguration :: Config

@@ -1,38 +1,40 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}  module System.HapistranoSpec   ( spec   ) where -import Control.Monad-import Control.Monad.Reader-import Data.List (isPrefixOf)-import Data.Maybe (mapMaybe)-import Numeric.Natural-import Path+import           Control.Monad+import           Control.Monad.Reader+import           Data.List                     (isPrefixOf)+import           Data.Maybe                    (mapMaybe)+import           Numeric.Natural+import           Path    -import Path.IO-import System.Directory-    ( doesFileExist, getCurrentDirectory, listDirectory )-import qualified System.Hapistrano as Hap-import qualified System.Hapistrano.Commands as Hap-import qualified System.Hapistrano.Core as Hap-import System.Hapistrano.Types-import System.IO-import System.IO.Silently (capture_)-import System.Info (os)-import Test.Hspec hiding (shouldBe, shouldContain, shouldReturn)-import qualified Test.Hspec as Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck hiding (Success)-import System.Hapistrano (releasePath)-import System.Hapistrano.Config (deployStateFilename)-import System.Hapistrano.Maintenance+import           Path.IO+import           System.Directory              (doesFileExist,+                                                getCurrentDirectory,+                                                listDirectory)+import           System.Hapistrano             (releasePath)+import qualified System.Hapistrano             as Hap+import qualified System.Hapistrano.Commands    as Hap+import           System.Hapistrano.Config      (deployStateFilename)+import qualified System.Hapistrano.Core        as Hap+import           System.Hapistrano.Maintenance+import           System.Hapistrano.Types+import           System.Info                   (os)+import           System.IO+import           System.IO.Silently            (capture_)+import           Test.Hspec                    hiding (shouldBe, shouldContain,+                                                shouldReturn)+import qualified Test.Hspec                    as Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck               hiding (Success)  testBranchName :: String testBranchName = "another_branch"@@ -175,9 +177,8 @@         -- This fails if there are unstaged changes           justExec rpath "git diff --exit-code"       it "updates the origin url when it's changed" $ \(deployPath, repoPath) ->-        runHap $ do-          let tempDirPrefix = "hap-test-repotwo"-          withSystemTempDir tempDirPrefix $ \repoPathTwo -> do+         withSystemTempDir "hap-test-repotwo" $ \repoPathTwo -> do+          runHap $ do             let task1 = mkTask deployPath repoPath                 task2 = mkTask deployPath repoPathTwo                 repoConfigFile = deployPath </> $(mkRelDir "repo") </> $(mkRelFile "config")@@ -185,8 +186,9 @@             void $ Hap.pushRelease task1             void $ Hap.pushRelease task2 -            repoFile <- (liftIO . readFile . fromAbsFile) repoConfigFile -            repoFile `shouldContain` tempDirPrefix+            repoFile <- (liftIO . readFile . fromAbsFile) repoConfigFile+            repoFile `shouldContain` "hap-test-repotwo"+     describe "createHapistranoDeployState" $ do       it ("creates the " <> deployStateFilename <> " file correctly") $ \(deployPath, repoPath) ->         runHap $ do@@ -245,14 +247,23 @@       it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) ->         runHap $ do           let task = mkTask deployPath repoPath+              noCmd = Nothing           rs <- replicateM 5 (Hap.pushRelease task)-          Hap.rollback currentSystem deployPath 2+          Hap.rollback currentSystem deployPath 2 noCmd           rpath <- Hap.releasePath deployPath (rs !! 2) Nothing           let rc :: Hap.Readlink Dir               rc =                 Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath)           Hap.exec rc Nothing `shouldReturn` rpath           Path.IO.doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False+    describe "rollback to non-exist release" $ do+      it "trying to rollback to a non-exist release, should throw exception" $ \(deployPath, repoPath) ->+        (runHap $ do+           let task = mkTask deployPath repoPath+               noCmd = Nothing+           replicateM_ 5 (Hap.pushRelease task)+           Hap.rollback currentSystem deployPath 6 noCmd) `shouldThrow`+        anyException     describe "dropOldReleases" $ do       it "works" $ \(deployPath, repoPath) ->         runHap $ do

@@ -12,6 +12,7 @@ {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}  module System.Hapistrano   ( runHapistrano@@ -20,6 +21,7 @@   , activateRelease   , linkToShared   , createHapistranoDeployState+  , deploy   , rollback   , dropOldReleases   , playScript@@ -32,17 +34,22 @@   , deployState ) where +import           Control.Exception          (try) import           Control.Monad+import           Control.Monad.Catch        (catch, throwM) import           Control.Monad.Except-import           Control.Monad.Reader       (local, runReaderT)+import           Control.Monad.Reader       (local) import           Data.List                  (dropWhileEnd, genericDrop, sortOn) import           Data.Maybe                 (fromMaybe, mapMaybe) import           Data.Ord                   (Down (..)) import           Data.Time import           Numeric.Natural import           Path+import           Path.IO import           System.Hapistrano.Commands-import           System.Hapistrano.Config   (deployStateFilename)+import           System.Hapistrano.Config   (CopyThing (..),+                                             deployStateFilename)+import qualified System.Hapistrano.Config   as HC import           System.Hapistrano.Core import           System.Hapistrano.Types import           Text.Read                  (readMaybe)@@ -66,9 +73,9 @@             , configShellOptions = shell'             , configPrint = printFnc             }-    r <- runReaderT (runExceptT m) config+    r <- try @HapistranoException $ unHapistrano m config     case r of-      Left (Failure n msg, _) -> do+      Left (HapistranoException (Failure n msg, _)) -> do         forM_ msg (printFnc StderrDest)         return (Left n)       Right x -> return (Right x)@@ -113,10 +120,14 @@   -> Hapistrano () activateRelease ts deployPath release = do   rpath <- releasePath deployPath release Nothing-  let tpath = tempSymlinkPath deployPath-      cpath = currentSymlinkPath deployPath-  exec (Ln ts rpath tpath) (Just release) -- create a symlink for the new candidate-  exec (Mv ts tpath cpath) (Just release) -- atomically replace the symlink+  isRpathExist <- doesDirExist rpath+  if isRpathExist then do+    let tpath = tempSymlinkPath deployPath+        cpath = currentSymlinkPath deployPath+    exec (Ln ts rpath tpath) (Just release) -- create a symlink for the new candidate+    exec (Mv ts tpath cpath) (Just release) -- atomically replace the symlink+  else+    failWith 1 (Just $ "The release path '" <> show rpath <> "' cannot be activated.") (Just release)  -- | Creates the file @.hapistrano__state@ containing -- @fail@ or @success@ depending on how the deployment ended.@@ -133,18 +144,73 @@   exec (Touch stateFilePath) (Just release) -- creates '.hapistrano_deploy_state'   exec (BasicWrite stateFilePath $ show state) (Just release) -- writes the deploy state to '.hapistrano_deploy_state' +-- | Deploys a new release+deploy+  :: HC.Config -- ^ Deploy configuration+  -> ReleaseFormat -- ^ Long or Short format+  -> Natural -- ^ Number of releases to keep+  -> Bool -- ^ Wheter we should keep one failed release or not+  -> Hapistrano ()+deploy HC.Config{..} releaseFormat keepReleases keepOneFailed = do+  forM_ configRunLocally playScriptLocally+  release <- if configVcAction+              then pushRelease task+              else pushReleaseWithoutVc task+  rpath <- releasePath configDeployPath release configWorkingDir+  forM_ (toMaybePath configSource) $ \src ->+    scpDir src rpath (Just release)+  forM_ configCopyFiles $ \(CopyThing src dest) -> do+    srcPath  <- resolveFile' src+    destPath <- parseRelFile dest+    let dpath = rpath </> destPath+    (flip exec (Just release) . MkDir . parent) dpath+    scpFile srcPath dpath (Just release)+  forM_ configCopyDirs $ \(CopyThing src dest) -> do+    srcPath  <- resolveDir' src+    destPath <- parseRelDir dest+    let dpath = rpath </> destPath+    (flip exec (Just release) . MkDir . parent) dpath+    scpDir srcPath dpath (Just release)+  forM_ configLinkedFiles+    $ flip (linkToShared configTargetSystem rpath configDeployPath) (Just release)+  forM_ configLinkedDirs+    $ flip (linkToShared configTargetSystem rpath configDeployPath) (Just release)+  forM_ configBuildScript (playScript configDeployPath release configWorkingDir)+  activateRelease configTargetSystem configDeployPath release+  forM_ configRestartCommand (flip exec $ Just release)+  createHapistranoDeployState configDeployPath release Success+  dropOldReleases configDeployPath keepReleases keepOneFailed+  `catch` failStateAndThrow+    where+    failStateAndThrow e@(HapistranoException (_, maybeRelease)) = do+      case maybeRelease of+        (Just release) -> do+          createHapistranoDeployState configDeployPath release Fail+          dropOldReleases configDeployPath keepReleases keepOneFailed+          throwM e+        Nothing -> do+          throwM e+    task =+      Task+      { taskDeployPath    = configDeployPath+      , taskSource        = configSource+      , taskReleaseFormat = releaseFormat+      }+ -- | Activates one of already deployed releases.  rollback   :: TargetSystem   -> Path Abs Dir      -- ^ Deploy path   -> Natural           -- ^ How many releases back to go, 0 re-activates current+  -> Maybe GenericCommand -- ^ Restart command   -> Hapistrano ()-rollback ts deployPath n = do+rollback ts deployPath n mbRestartCommand = do   releases <- releasesWithState Success deployPath   case genericDrop n releases of     [] -> failWith 1 (Just "Could not find the requested release to rollback to.") Nothing     (x:_) -> activateRelease ts deployPath x+  forM_ mbRestartCommand (`exec` Nothing)  -- | Remove older releases to avoid filling up the target host filesystem. @@ -213,7 +279,7 @@   let cpath = cacheRepoPath deployPath       refs  = cpath </> $(mkRelDir "refs")   exists <- (exec (Ls refs) Nothing >> return True)-    `catchError` const (return False)+    `catch` (\(_ :: HapistranoException)  -> return False)   unless exists $     exec (GitClone True (Left repo) cpath) maybeRelease   exec (Cd cpath (GitSetOrigin repo)) maybeRelease

@@ -37,50 +37,50 @@ -- | Hapistrano configuration typically loaded from @hap.yaml@ file.  data Config = Config-  { configDeployPath     :: !(Path Abs Dir)+  { configDeployPath           :: !(Path Abs Dir)     -- ^ Top-level deploy directory on target machine-  , configHosts          :: ![Target]+  , configHosts                :: ![Target]     -- ^ Hosts\/ports\/shell\/ssh args to deploy to. If empty, localhost will be assumed.-  , configSource         :: !Source+  , configSource               :: !Source     -- ^ Location of the 'Source' that contains the code to deploy-  , configRestartCommand :: !(Maybe GenericCommand)+  , configRestartCommand       :: !(Maybe GenericCommand)     -- ^ The command to execute when switching to a different release     -- (usually after a deploy or rollback).-  , configBuildScript    :: !(Maybe [GenericCommand])+  , configBuildScript          :: !(Maybe [GenericCommand])     -- ^ Build script to execute to build the project-  , configCopyFiles      :: ![CopyThing]+  , configCopyFiles            :: ![CopyThing]     -- ^ Collection of files to copy over to target machine before building-  , configCopyDirs       :: ![CopyThing]+  , configCopyDirs             :: ![CopyThing]     -- ^ Collection of directories to copy over to target machine before building-  , configLinkedFiles    :: ![FilePath]+  , configLinkedFiles          :: ![FilePath]     -- ^ Collection of files to link from each release to _shared_-  , configLinkedDirs     :: ![FilePath]+  , configLinkedDirs           :: ![FilePath]     -- ^ Collection of directories to link from each release to _shared_-  , configVcAction       :: !Bool+  , configVcAction             :: !Bool   -- ^ Perform version control related actions. By default, it's assumed to be `True`.-  , configRunLocally     :: !(Maybe [GenericCommand])+  , configRunLocally           :: !(Maybe [GenericCommand])   -- ^ Perform a series of commands on the local machine before communication   -- with target server starts-  , configTargetSystem   :: !TargetSystem+  , configTargetSystem         :: !TargetSystem   -- ^ Optional parameter to specify the target system. It's GNU/Linux by   -- default-  , configReleaseFormat  :: !(Maybe ReleaseFormat)+  , configReleaseFormat        :: !(Maybe ReleaseFormat)   -- ^ The release timestamp format, the @--release-format@ argument passed via   -- the CLI takes precedence over this value. If neither CLI or configuration   -- file value is specified, it defaults to short-  , configKeepReleases   :: !(Maybe Natural)+  , configKeepReleases         :: !(Maybe Natural)   -- ^ The number of releases to keep, the @--keep-releases@ argument passed via   -- the CLI takes precedence over this value. If neither CLI or configuration   -- file value is specified, it defaults to 5-  , configKeepOneFailed  :: !Bool+  , configKeepOneFailed        :: !Bool   -- ^ Specifies whether to keep all failed releases along with the successful releases   -- or just the latest failed (at least this one should be kept for debugging purposes).   -- The @--keep-one-failed@ argument passed via the CLI takes precedence over this value.   -- If neither CLI or configuration file value is specified, it defaults to `False`   -- (i.e. keep all failed releases).-  , configWorkingDir :: !(Maybe (Path Rel Dir))+  , configWorkingDir           :: !(Maybe (Path Rel Dir))   , configMaintenanceDirectory :: !(Path Rel Dir)-  , configMaintenanceFileName :: !(Path Rel File)+  , configMaintenanceFileName  :: !(Path Rel File)   } deriving (Eq, Ord, Show)  -- | Information about source and destination locations of a file\/directory@@ -115,8 +115,7 @@         <*> grabPort m         <*> grabShell m         <*> grabSshArgs m)-    let first Target{} = host-        configHosts = nubBy ((==) `on` first)+    let configHosts = nubBy ((==) `on` targetHost)           (maybeToList (Target <$> host <*> pure port <*> pure shell <*> pure sshArgs) ++ hs)         source m =               GitRepository <$> m .: "repo" <*> m .: "revision"

@@ -22,6 +22,7 @@  import           Control.Concurrent.STM     (atomically) import           Control.Monad+import           Control.Monad.Catch        (throwM) import           Control.Monad.Except import           Control.Monad.Reader import           Data.Proxy@@ -37,7 +38,7 @@  -- | Fail returning the following status code and message. failWith :: Int -> Maybe String -> Maybe Release -> Hapistrano a-failWith n msg maybeRelease = throwError (Failure n msg, maybeRelease)+failWith n msg maybeRelease = throwM $ HapistranoException (Failure n msg, maybeRelease)  -- | Run the given sequence of command. Whether to use SSH or not is -- determined from settings contained in the 'Hapistrano' monad

@@ -7,11 +7,13 @@ -- Portability :  portable -- -- Type definitions for the Hapistrano tool.+{-# LANGUAGE DerivingVia       #-} {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}  module System.Hapistrano.Types-  ( Hapistrano+  ( Hapistrano(..)+  , HapistranoException(..)   , Failure(..)   , Config(..)   , Source(..)@@ -37,6 +39,7 @@   ) where  import           Control.Applicative+import           Control.Monad.Catch import           Control.Monad.Except import           Control.Monad.Reader import           Data.Aeson@@ -46,11 +49,28 @@ import           Path  -- | Hapistrano monad.-type Hapistrano a = ExceptT (Failure, Maybe Release) (ReaderT Config IO) a+newtype Hapistrano a =+  Hapistrano { unHapistrano :: Config -> IO a }+    deriving+      ( Functor+      , Applicative+      , Monad+      , MonadIO+      , MonadThrow+      , MonadCatch+      , MonadReader Config+      ) via (ReaderT Config IO) +-- | Hapistrano exception+newtype HapistranoException = HapistranoException (Failure, Maybe Release)+  deriving (Show)++instance Exception HapistranoException+ -- | Failure with status code and a message. data Failure =   Failure Int (Maybe String)+  deriving Show  -- | Hapistrano configuration options. data Config =