diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 `) on every pushed release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. --- -Stack Builders +Stack Builders [Check out our libraries](https://github.com/stackbuilders/) | [Join our team](https://www.stackbuilders.com/join-us/) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/hapistrano.cabal b/hapistrano.cabal --- a/hapistrano.cabal +++ b/hapistrano.cabal @@ -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 diff --git a/spec/System/HapistranoConfigSpec.hs b/spec/System/HapistranoConfigSpec.hs --- a/spec/System/HapistranoConfigSpec.hs +++ b/spec/System/HapistranoConfigSpec.hs @@ -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 diff --git a/spec/System/HapistranoSpec.hs b/spec/System/HapistranoSpec.hs --- a/spec/System/HapistranoSpec.hs +++ b/spec/System/HapistranoSpec.hs @@ -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 diff --git a/src/System/Hapistrano.hs b/src/System/Hapistrano.hs --- a/src/System/Hapistrano.hs +++ b/src/System/Hapistrano.hs @@ -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 diff --git a/src/System/Hapistrano/Config.hs b/src/System/Hapistrano/Config.hs --- a/src/System/Hapistrano/Config.hs +++ b/src/System/Hapistrano/Config.hs @@ -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" 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 @@ -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 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 @@ -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 =