hapistrano 0.4.3.0 → 0.4.4.0

raw patch · 16 files changed

+457/−375 lines, 16 filesdep ~aesondep ~yamlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, yaml

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• Dockerfile +0/−62
• README.md +23/−12
• app/Main.hs +51/−50
• fixtures/git_repository_config.yaml +0/−4
• fixtures/local_directory_config.yaml +0/−3
• hapistrano.cabal +10/−12
• script/clean-build.sh +0/−9
• spec/System/HapistranoConfigSpec.hs +1/−0
• spec/System/HapistranoSpec.hs +82/−61
• src/System/Hapistrano.hs +114/−78
• src/System/Hapistrano/Commands.hs +7/−5
• src/System/Hapistrano/Commands/Internal.hs +48/−8
• src/System/Hapistrano/Config.hs +35/−11
• src/System/Hapistrano/Core.hs +24/−42
• src/System/Hapistrano/Types.hs +49/−18

@@ -1,3 +1,16 @@+## 0.4.4.0+### Added+* Ability to keep all failed releases or just one ([issue #154](https://github.com/stackbuilders/hapistrano/issues/154))+  * Config Option: `keep_one_failed`+  * CLI Option: `--keep-one-failed`++### Modified+* Some types and functions were modified to support the new features (e.g. `Hapistrano`, `runHapistrano`, etc.)++## 0.4.3.1+### Added+* Add support for aeson 2.0+ ## 0.4.3.0 ### Added * Add support for GHC 9.0

@@ -1,62 +0,0 @@-# Build Hapistrano-FROM alpine:3.13 as build-env--MAINTAINER Nicolas Vivar <nvivar@stackbuilders.com>--RUN apk update \- && apk add \-        alpine-sdk \-        bash \-        ca-certificates \-        cabal \-        ghc-dev \-        ghc \-        git \-        gmp-dev \-        gnupg \-        libffi-dev \-        linux-headers \-        upx \-        zlib-dev--WORKDIR /hapistrano--COPY hapistrano.cabal .-COPY src/ src/-COPY app/ app/-COPY script/ script/-COPY LICENSE .-COPY Setup.hs .-# So Hapistrano is built with version information-COPY .git/ .git/-# Cabal has changed behaviour and it requires all modules listed-COPY spec/ spec/-COPY fixtures/ fixtures/-COPY CHANGELOG.md .-COPY README.md .-RUN touch Dockerfile--RUN cabal update-RUN cabal install --only-dependencies-RUN cabal configure -f static-RUN cabal build hap--# Compress the resulting binary-RUN mkdir bin-RUN cp /hapistrano/dist-newstyle/build/x86_64-linux/ghc-8.8.4/hapistrano-0.4.3.0/x/hap/build/hap/hap bin/-RUN upx /hapistrano/bin/hap--# Copy Hapistrano to a basic Alpine with SSH-FROM alpine:3.13--RUN apk update \- && apk add \-        openssh-client \-        ca-certificates \-        git--RUN mkdir ~/.ssh--COPY --from=build-env /hapistrano/bin/hap /bin/hap--ENTRYPOINT ["/bin/hap"]

@@ -1,10 +1,10 @@-[![Build and Test](https://github.com/stackbuilders/hapistrano/actions/workflows/build-and-test.yml/badge.svg?branch=master)](https://github.com/stackbuilders/hapistrano/actions/workflows/build-and-test.yml)+[![CI](https://github.com/stackbuilders/hapistrano/actions/workflows/ci.yml/badge.svg)](https://github.com/stackbuilders/hapistrano/actions/workflows/ci.yml)+[![Docker](https://github.com/stackbuilders/hapistrano/actions/workflows/docker.yml/badge.svg)](https://github.com/stackbuilders/hapistrano/actions/workflows/docker.yml) [![Hackage version](https://img.shields.io/hackage/v/hapistrano.svg)](http://hackage.haskell.org/package/hapistrano)-[![Docker Hub](https://img.shields.io/docker/build/stackbuilders/hapistrano.svg?style=flat)](https://hub.docker.com/r/stackbuilders/hapistrano) -# Table of Contents+# Hapistrano - * [Hapistrano](#hapistrano)+ * [Description](#description)  * [Purpose](#purpose)  * [How it Works](#how-it-works)  * [Usage](#usage)@@ -13,11 +13,12 @@  * [Deploying to multiple machines concurrently](#deploying-to-multiple-machines-concurrently)  * [Docker](#docker)  * [Nix](#nix)+ * [Notes](#notes)  * [License](#license)  * [Contributing](#contributing)  -# Hapistrano+# Description  Hapistrano is a deployment library for Haskell applications similar to Ruby's [Capistrano](http://capistranorb.com/).@@ -98,16 +99,20 @@   deploy to is a GNU/Linux or other UNIX (g.e. BSD, Mac). This is set to `true`   by default so unless the target system is not GNU/Linux, this should not be   necessary. The platform where Hapistrano is running won't affect the-  available options for commands (g.e. A Mac deploying to a Ubuntu machine,+  available options for commands (g.e. A Mac deploying to an Ubuntu machine,   doesn't need this flag) * `release_format` - 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+  value. If neither CLI nor configuration file value is specified, it defaults   to 'short' * `keep_releases` - 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+  value. If neither CLI nor configuration file value is specified, it defaults   to '5'+* `keep_one_failed` - A boolean specifying whether to keep all failed releases+  or just one (the latest failed release), the '--keep-one-failed' flag passed via+  the CLI takes precedence over this value. If neither CLI nor configuration file value is specified,+  it defaults to false (i.e. keep all failed releases). * `linked_files:`- Listed files that will be symlinked from the `{deploy_path}/shared` folder into each release directory during deployment. Can be used for configuration files that need to be persisted (e.g. dotenv files).  **NOTE:** The directory structure _must_@@ -129,8 +134,8 @@  Note how we are even able to execute a bash script named `deploy.sh` above. Be sure to use `set -e` in your bash script to avoid-headaches. Hapistrano will stop the execution on non zero exit-codes. Without the usage of `set -e`, there is a possiblity that your+headaches. Hapistrano will stop the execution on non-zero exit+codes. Without the usage of `set -e`, there is a possibility that your bash script may return a zero exit code even if your intermediate command resulted in an error. @@ -221,8 +226,10 @@  ## Docker -If you would like to use Docker, there is a lightweight image-available on [Docker Hub](https://hub.docker.com/r/stackbuilders/hapistrano/).+Docker images hosted on [Docker+Hub](https://hub.docker.com/r/stackbuilders/hapistrano) are **no longer up to+date**, newer versions are published to [GitHub's Docker+Registry](https://github.com/stackbuilders/hapistrano/pkgs/container/hapistrano).  ## Nix @@ -241,6 +248,10 @@ ```bash nix-build release.nix ```++## Notes++* Hapistrano is not supported on Windows. Please check: [Issue #96](https://github.com/stackbuilders/hapistrano/issues/96).   ## License

@@ -8,7 +8,6 @@ import           Control.Concurrent.Async import           Control.Concurrent.STM import           Control.Monad- #if !MIN_VERSION_base(4,13,0) import           Data.Monoid                ((<>)) #endif@@ -16,7 +15,6 @@ import qualified Data.Yaml.Config           as Yaml import           Development.GitRev import           Formatting                 (formatToString, string, (%))-import           Numeric.Natural import           Options.Applicative        hiding (str) import           Path import           Path.IO@@ -28,24 +26,11 @@ import qualified System.Hapistrano.Core     as Hap import           System.Hapistrano.Types import           System.IO+import           System.Hapistrano (createHapistranoDeployState)+import           Control.Monad.Error.Class (throwError, catchError)  ------------------------------------------------------------------------------- Command line options --- | Command line options.--data Opts = Opts-  { optsCommand    :: Command-  , optsConfigFile :: FilePath-  }---- | Command to execute and command-specific options.--data Command-  = Deploy (Maybe ReleaseFormat) (Maybe Natural) -- ^ Deploy a new release (with timestamp-    -- format and how many releases to keep)-  | Rollback Natural -- ^ Rollback to Nth previous release- parserInfo :: ParserInfo Opts parserInfo =   info@@ -95,6 +80,10 @@             <> help "How many releases to keep, default is '5'"             )         )+  <*> switch+        ( long "keep-one-failed"+            <> help "Keep all failed releases or just one -the latest-, default (without using this flag) is to keep all failed releases."+        )  rollbackParser :: Parser Command rollbackParser = Rollback@@ -125,7 +114,7 @@  main :: IO () main = do-  Opts {..} <- execParser parserInfo+  Opts{..} <- execParser parserInfo   C.Config{..} <- Yaml.loadYamlSettings [optsConfigFile] [] Yaml.useEnv   chan <- newTChanIO   let task rf = Task { taskDeployPath    = configDeployPath@@ -133,43 +122,55 @@                      , taskReleaseFormat = rf }   let printFnc dest str = atomically $         writeTChan chan (PrintMsg dest str)-      hap shell sshOpts =  do+      hap shell sshOpts = do         r <- Hap.runHapistrano sshOpts shell printFnc $           case optsCommand of-            Deploy cliReleaseFormat cliKeepReleases -> do+            Deploy cliReleaseFormat cliKeepReleases cliKeepOneFailed ->               let releaseFormat = fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat                   keepReleases = fromMaybeKeepReleases cliKeepReleases configKeepReleases-              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-              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_ configLinkedFiles-                (Hap.linkToShared configTargetSystem rpath configDeployPath)-              forM_ configLinkedDirs-                (Hap.linkToShared configTargetSystem rpath configDeployPath)-              forM_ configBuildScript (Hap.playScript configDeployPath release configWorkingDir)-              Hap.registerReleaseAsComplete configDeployPath release-              Hap.activateRelease configTargetSystem configDeployPath release-              Hap.dropOldReleases configDeployPath keepReleases-              forM_ configRestartCommand Hap.exec+                  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 Hap.exec+              forM_ configRestartCommand (flip Hap.exec Nothing)         atomically (writeTChan chan FinishMsg)         return r       printer :: Int -> IO ()@@ -187,7 +188,7 @@         case configHosts of           [] -> [hap Bash Nothing] -- localhost, no SSH           xs ->-            let runHap (C.Target{..}) =+            let runHap C.Target{..} =                   hap targetShell (Just $ SshOptions targetHost targetPort targetSshArgs)             in runHap <$> xs   results <- (runConcurrently . traverse Concurrently)

@@ -1,4 +0,0 @@-deploy_path: '/'-host: www.example.com-repo: 'my-repo'-revision: 'my-revision'

@@ -1,3 +0,0 @@-deploy_path: '/'-host: www.example.com-local_directory: '/'

@@ -1,5 +1,6 @@+cabal-version:       1.18 name:                hapistrano-version:             0.4.3.0+version:             0.4.4.0 synopsis:            A deployment library for Haskell applications description:   .@@ -21,19 +22,15 @@ license:             MIT license-file:        LICENSE author:              Justin Leitgeb-maintainer:          jpaucar@stackbuilders.com+maintainer:          hackage@stackbuilders.com copyright:           2015-Present Stack Builders Inc. category:            System homepage:            https://github.com/stackbuilders/hapistrano bug-reports:         https://github.com/stackbuilders/hapistrano/issues build-type:          Simple-cabal-version:       >=1.18-tested-with:         GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.0.1-extra-source-files:  CHANGELOG.md+tested-with:         GHC==8.10.17, GHC==9.0.2+extra-doc-files:     CHANGELOG.md                    , README.md-                   , Dockerfile-data-files:          script/clean-build.sh-                   , fixtures/*.yaml  flag dev   description:        Turn on development settings.@@ -53,7 +50,7 @@                      , System.Hapistrano.Core                      , System.Hapistrano.Types                      , System.Hapistrano.Commands.Internal-  build-depends:       aeson              >= 0.11 && < 1.6+  build-depends:       aeson              >= 2.0 && < 3.0                      , ansi-terminal      >= 0.9 && < 0.12                      , base               >= 4.9 && < 5.0                      , filepath           >= 1.2 && < 1.5@@ -65,7 +62,7 @@                      , typed-process      >= 0.2 && < 0.3                      , time               >= 1.5 && < 1.11                      , transformers       >= 0.4 && < 0.6-                     , yaml               >= 0.8.16 && < 0.12+                     , yaml               >= 0.11.7 && < 0.12   if flag(dev)     ghc-options:       -Wall -Werror   else@@ -76,17 +73,18 @@   hs-source-dirs:      app   main-is:             Main.hs   other-modules:       Paths_hapistrano-  build-depends:       aeson              >= 0.11 && < 1.6+  build-depends:       aeson              >= 2.0 && < 3.0                      , 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.8.16 && < 0.12+                     , yaml               >= 0.11.7 && < 0.12   if flag(dev)     ghc-options:       -threaded -rtsopts -with-rtsopts=-N -Wall -Werror   else

@@ -1,9 +0,0 @@-# This is a comment-export PATH=~/.cabal/bin:/usr/local/bin:$PATH- -cabal sandbox delete # kill it with fire!-cabal sandbox init-cabal clean-cabal update-cabal install --only-dependencies -j-cabal build -j

@@ -62,5 +62,6 @@     , configTargetSystem = GNULinux     , configReleaseFormat = Nothing     , configKeepReleases = Nothing+    , configKeepOneFailed = False     , configWorkingDir = Nothing     }

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP             #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}  module System.HapistranoSpec   ( spec@@ -11,10 +12,10 @@ import Data.Maybe (mapMaybe) import Numeric.Natural import Path-#if !MIN_VERSION_base(4,13,0)-import Path.Internal (Path(..))-#endif +++ import Path.IO import System.Directory (getCurrentDirectory, listDirectory) import qualified System.Hapistrano as Hap@@ -27,7 +28,9 @@ import Test.Hspec hiding (shouldBe, shouldReturn) import qualified Test.Hspec as Hspec import Test.Hspec.QuickCheck-import Test.QuickCheck+import Test.QuickCheck hiding (Success)+import System.Hapistrano (releasePath)+import System.Hapistrano.Config (deployStateFilename)  testBranchName :: String testBranchName = "another_branch"@@ -46,7 +49,7 @@     let (Just commandTest) =           Hap.mkGenericCommand             "echo \"hapistrano\"; sleep 2; echo \"onartsipah\""-        commandExecution = Hap.execWithInheritStdout commandTest+        commandExecution = Hap.execWithInheritStdout commandTest Nothing         expectedOutput = "hapistrano\nonartsipah"      in do actualOutput <- capture_ (runHap commandExecution)            expectedOutput `Hspec.shouldSatisfy` (`isPrefixOf` actualOutput)@@ -154,14 +157,25 @@             ("test `git rev-parse --abbrev-ref HEAD` = " ++ testBranchName)         -- This fails if there are unstaged changes           justExec rpath "git diff --exit-code"-    describe "registerReleaseAsComplete" $-      it "creates the token all right" $ \(deployPath, repoPath) ->+    describe "createHapistranoDeployState" $ do+      it ("creates the " <> deployStateFilename <> " file correctly") $ \(deployPath, repoPath) ->         runHap $ do           let task = mkTask deployPath repoPath           release <- Hap.pushRelease task-          Hap.registerReleaseAsComplete deployPath release-          (Hap.ctokenPath deployPath release >>= doesFileExist) `shouldReturn`+          parseStatePath <- parseRelFile deployStateFilename+          actualReleasePath <- releasePath deployPath release Nothing+          let stateFilePath = actualReleasePath </> parseStatePath+          Hap.createHapistranoDeployState deployPath release Success+          Path.IO.doesFileExist stateFilePath `shouldReturn`             True+      it "when created in a successful deploy, the contents are \"Success\"" $ \(deployPath, repoPath) ->+        runHap $ do+          let task = mkTask deployPath repoPath+          release <- Hap.pushRelease task+          Hap.createHapistranoDeployState deployPath release Success+          Hap.deployState deployPath Nothing release `shouldReturn`+            Success+     describe "activateRelease" $       it "creates the ‘current’ symlink correctly" $ \(deployPath, repoPath) ->         runHap $ do@@ -172,8 +186,8 @@           let rc :: Hap.Readlink Dir               rc =                 Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath)-          Hap.exec rc `shouldReturn` rpath-          doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False+          Hap.exec rc (Just release) `shouldReturn` rpath+          Path.IO.doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False     describe "playScriptLocally (successful run)" $       it "check that local scripts are run and deployment is successful" $ \(deployPath, repoPath) ->         runHap $ do@@ -181,8 +195,11 @@               task = mkTask deployPath repoPath           Hap.playScriptLocally localCommands           release <- Hap.pushRelease task-          Hap.registerReleaseAsComplete deployPath release-          (Hap.ctokenPath deployPath release >>= doesFileExist) `shouldReturn`+          parseStatePath <- parseRelFile deployStateFilename+          actualReleasePath <- releasePath deployPath release Nothing+          let stateFilePath = actualReleasePath </> parseStatePath+          Hap.createHapistranoDeployState deployPath release Success+          Path.IO.doesFileExist stateFilePath `shouldReturn`             True     describe "playScriptLocally (error exit)" $       it "check that deployment isn't done" $ \(deployPath, repoPath) ->@@ -192,55 +209,51 @@                task = mkTask deployPath repoPath            Hap.playScriptLocally localCommands            release <- Hap.pushRelease task-           Hap.registerReleaseAsComplete deployPath release) `shouldThrow`+           Hap.createHapistranoDeployState deployPath release Success) `shouldThrow`         anyException     describe "rollback" $ do-      context "without completion tokens" $-        it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) ->-          runHap $ do-            let task = mkTask deployPath repoPath-            rs <- replicateM 5 (Hap.pushRelease task)-            Hap.rollback currentSystem deployPath 2-            rpath <- Hap.releasePath deployPath (rs !! 2) Nothing-            let rc :: Hap.Readlink Dir-                rc =-                  Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath)-            Hap.exec rc `shouldReturn` rpath-            doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False-      context "with completion tokens" $-        it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) ->-          runHap $ do-            let task = mkTask deployPath repoPath-            rs <- replicateM 5 (Hap.pushRelease task)-            forM_ (take 3 rs) (Hap.registerReleaseAsComplete deployPath)-            Hap.rollback currentSystem deployPath 2-            rpath <- Hap.releasePath deployPath (rs !! 0) Nothing-            let rc :: Hap.Readlink Dir-                rc =-                  Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath)-            Hap.exec rc `shouldReturn` rpath-            doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False-    describe "dropOldReleases" $+      it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) ->+        runHap $ do+          let task = mkTask deployPath repoPath+          rs <- replicateM 5 (Hap.pushRelease task)+          Hap.rollback currentSystem deployPath 2+          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 "dropOldReleases" $ do       it "works" $ \(deployPath, repoPath) ->         runHap $ do           rs <-             replicateM 7 $ do               r <- Hap.pushRelease (mkTask deployPath repoPath)-              Hap.registerReleaseAsComplete deployPath r+              Hap.createHapistranoDeployState deployPath r Success               return r-          Hap.dropOldReleases deployPath 5-        -- two oldest releases should not survive:+          Hap.dropOldReleases deployPath 5 False+          -- two oldest releases should not survive:           forM_ (take 2 rs) $ \r ->             (Hap.releasePath deployPath r Nothing >>= doesDirExist) `shouldReturn` False-        -- 5 most recent releases should stay alive:+          -- 5 most recent releases should stay alive:           forM_ (drop 2 rs) $ \r ->             (Hap.releasePath deployPath r Nothing >>= 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+      context "when the --keep-one-failed flag is active" $+        it "should delete failed releases other than the most recent" $ \(deployPath, repoPath) ->+          let successfulRelease = mkReleaseWithState deployPath repoPath Success +              failedRelease = mkReleaseWithState deployPath repoPath Fail in+          runHap $ do+            rs <- sequence [successfulRelease, successfulRelease, failedRelease, failedRelease, failedRelease]+            Hap.dropOldReleases deployPath 5 True+            -- The two successful releases should survive+            forM_ (take 2 rs) $ \r ->+              (Hap.releasePath deployPath r Nothing >>= doesDirExist) `shouldReturn` True+            -- The latest failed release should survive:+            forM_ (drop 4 rs) $ \r ->+              (Hap.releasePath deployPath r Nothing >>= doesDirExist) `shouldReturn` True+            -- The two older failed releases should not survive:+            forM_ (take 2 . drop 2 $ rs) $ \r ->+              (Hap.releasePath deployPath r Nothing >>= doesDirExist) `shouldReturn` False     describe "linkToShared" $ do       context "when the deploy_path/shared directory doesn't exist" $         it "should create the link anyway" $ \(deployPath, repoPath) ->@@ -249,18 +262,18 @@                 sharedDir = Hap.sharedPath deployPath             release <- Hap.pushRelease task             rpath <- Hap.releasePath deployPath release Nothing-            Hap.exec $ Hap.Rm sharedDir-            Hap.linkToShared currentSystem rpath deployPath "thing" `shouldReturn`+            Hap.exec (Hap.Rm sharedDir) (Just release)+            Hap.linkToShared currentSystem rpath deployPath "thing" (Just release) `shouldReturn`               ()-      context "when the file/directory to link exists in the respository" $+      context "when the file/directory to link exists in the repository" $         it "should throw an error" $ \(deployPath, repoPath) ->           runHap             (do let task = mkTask deployPath repoPath                 release <- Hap.pushRelease task                 rpath <- Hap.releasePath deployPath release Nothing-                Hap.linkToShared currentSystem rpath deployPath "foo.txt") `shouldThrow`+                Hap.linkToShared currentSystem rpath deployPath "foo.txt" $ Just release) `shouldThrow`           anyException-      context "when it attemps to link a file" $ do+      context "when it attempts to link a file" $ do         context "when the file is not at the root of the shared directory" $           it "should throw an error" $ \(deployPath, repoPath) ->             runHap@@ -270,7 +283,7 @@                   rpath <- Hap.releasePath deployPath release Nothing                   justExec sharedDir "mkdir foo/"                   justExec sharedDir "echo 'Bar!' > foo/bar.txt"-                  Hap.linkToShared currentSystem rpath deployPath "foo/bar.txt") `shouldThrow`+                  Hap.linkToShared currentSystem rpath deployPath "foo/bar.txt" $ Just release) `shouldThrow`             anyException         context "when the file is at the root of the shared directory" $           it "should link the file successfully" $ \(deployPath, repoPath) ->@@ -280,7 +293,7 @@               release <- Hap.pushRelease task               rpath <- Hap.releasePath deployPath release Nothing               justExec sharedDir "echo 'Bar!' > bar.txt"-              Hap.linkToShared currentSystem rpath deployPath "bar.txt"+              Hap.linkToShared currentSystem rpath deployPath "bar.txt" (Just release)               (liftIO . readFile . fromAbsFile)                 (rpath </> $(mkRelFile "bar.txt")) `shouldReturn`                 "Bar!\n"@@ -295,7 +308,7 @@                   justExec sharedDir "mkdir foo/"                   justExec sharedDir "echo 'Bar!' > foo/bar.txt"                   justExec sharedDir "echo 'Baz!' > foo/baz.txt"-                  Hap.linkToShared currentSystem rpath deployPath "foo/") `shouldThrow`+                  Hap.linkToShared currentSystem rpath deployPath "foo/" $ Just release) `shouldThrow`             anyException         it "should link the file successfully" $ \(deployPath, repoPath) ->           runHap $ do@@ -306,7 +319,7 @@             justExec sharedDir "mkdir foo/"             justExec sharedDir "echo 'Bar!' > foo/bar.txt"             justExec sharedDir "echo 'Baz!' > foo/baz.txt"-            Hap.linkToShared currentSystem rpath deployPath "foo"+            Hap.linkToShared currentSystem rpath deployPath "foo" (Just release)             files <-               (liftIO . listDirectory . fromAbsDir)                 (rpath </> $(mkRelDir "foo"))@@ -359,8 +372,8 @@ justExec :: Path Abs Dir -> String -> Hapistrano () justExec path cmd' =   case Hap.mkGenericCommand cmd' of-    Nothing -> Hap.failWith 1 (Just $ "Failed to parse the command: " ++ cmd')-    Just cmd -> Hap.exec (Hap.Cd path cmd)+    Nothing -> Hap.failWith 1 (Just $ "Failed to parse the command: " ++ cmd') Nothing+    Just cmd -> Hap.exec (Hap.Cd path cmd) Nothing  -- | Run 'Hapistrano' monad locally. runHap :: Hapistrano a -> IO a@@ -397,6 +410,14 @@           }     , taskReleaseFormat = ReleaseLong     }++-- | Creates a release tagged with 'Success' or 'Fail'++mkReleaseWithState :: Path Abs Dir -> Path Abs Dir -> DeployState -> Hapistrano Release+mkReleaseWithState deployPath repoPath state = do+  r <- Hap.pushRelease (mkTask deployPath repoPath)+  Hap.createHapistranoDeployState deployPath r state+  return r  currentSystem :: TargetSystem currentSystem =

@@ -3,7 +3,6 @@ -- Copyright   :  © 2015-Present Stack Builders -- License     :  MIT ----- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com> -- Stability   :  experimental -- Portability :  portable --@@ -15,11 +14,12 @@ {-# LANGUAGE TemplateHaskell     #-}  module System.Hapistrano-  ( pushRelease+  ( runHapistrano+  , pushRelease   , pushReleaseWithoutVc-  , registerReleaseAsComplete   , activateRelease   , linkToShared+  , createHapistranoDeployState   , rollback   , dropOldReleases   , playScript@@ -29,23 +29,50 @@   , sharedPath   , currentSymlinkPath   , tempSymlinkPath-  , ctokenPath )+  , deployState ) where  import           Control.Monad import           Control.Monad.Except-import           Control.Monad.Reader       (local)+import           Control.Monad.Reader       (local, runReaderT) import           Data.List                  (dropWhileEnd, genericDrop, sortOn)-import           Data.Maybe                 (mapMaybe)+import           Data.Maybe                 (fromMaybe, mapMaybe) import           Data.Ord                   (Down (..)) import           Data.Time import           Numeric.Natural import           Path import           System.Hapistrano.Commands+import           System.Hapistrano.Config   (deployStateFilename) import           System.Hapistrano.Core import           System.Hapistrano.Types+import           Text.Read                  (readMaybe)  ----------------------------------------------------------------------------++-- | Run the 'Hapistrano' monad. The monad hosts 'exec' actions.+runHapistrano ::+     MonadIO m+  => Maybe SshOptions -- ^ SSH options to use or 'Nothing' if we run locally+  -> Shell -- ^ Shell to run commands+  -> (OutputDest -> String -> IO ()) -- ^ How to print messages+  -> Hapistrano a -- ^ The computation to run+  -> m (Either Int a) -- ^ Status code in 'Left' on failure, result in+              -- 'Right' on success+runHapistrano sshOptions shell' printFnc m =+  liftIO $ do+    let config =+          Config+            { configSshOptions = sshOptions+            , configShellOptions = shell'+            , configPrint = printFnc+            }+    r <- runReaderT (runExceptT m) config+    case r of+      Left (Failure n msg, _) -> do+        forM_ msg (printFnc StderrDest)+        return (Left n)+      Right x -> return (Right x)+ -- High-level functionality  -- | Perform basic setup for a project, making sure necessary directories@@ -60,7 +87,7 @@     -- When the configuration is set for a local directory, it will only create     -- the release directory without any version control operations.     pushReleaseForRepository GitRepository {..} = do-      ensureCacheInPlace gitRepositoryURL taskDeployPath+      ensureCacheInPlace gitRepositoryURL taskDeployPath Nothing       release <- newRelease taskReleaseFormat       cloneToRelease taskDeployPath release       setReleaseRevision taskDeployPath release gitRepositoryRevision@@ -76,17 +103,6 @@   setupDirs taskDeployPath   newRelease taskReleaseFormat --- | Create a file-token that will tell rollback function that this release--- should be considered successfully compiled\/completed.--registerReleaseAsComplete-  :: Path Abs Dir      -- ^ Deploy path-  -> Release           -- ^ Release identifier to activate-  -> Hapistrano ()-registerReleaseAsComplete deployPath release = do-  cpath <- ctokenPath deployPath release-  exec (Touch cpath)- -- | Switch the current symlink to point to the specified release. May be -- used in deploy or rollback cases. @@ -99,9 +115,24 @@   rpath <- releasePath deployPath release Nothing   let tpath = tempSymlinkPath deployPath       cpath = currentSymlinkPath deployPath-  exec (Ln ts rpath tpath) -- create a symlink for the new candidate-  exec (Mv ts tpath cpath) -- atomically replace the symlink+  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 +-- | Creates the file @.hapistrano__state@ containing+-- @fail@ or @success@ depending on how the deployment ended.++createHapistranoDeployState+  :: Path Abs Dir -- ^ Deploy path+  -> Release -- ^ Release being deployed+  -> DeployState -- ^ Indicates how the deployment went+  -> Hapistrano ()+createHapistranoDeployState deployPath release state = do+  parseStatePath <- parseRelFile deployStateFilename+  actualReleasePath <- releasePath deployPath release Nothing+  let stateFilePath = actualReleasePath </> parseStatePath+  exec (Touch stateFilePath) (Just release) -- creates '.hapistrano_deploy_state'+  exec (BasicWrite stateFilePath $ show state) (Just release) -- writes the deploy state to '.hapistrano_deploy_state'+ -- | Activates one of already deployed releases.  rollback@@ -110,14 +141,9 @@   -> Natural           -- ^ How many releases back to go, 0 re-activates current   -> Hapistrano () rollback ts deployPath n = do-  crs <- completedReleases deployPath-  drs <- deployedReleases  deployPath-  -- NOTE If we don't have any completed releases, then perhaps the-  -- application was used with older versions of Hapistrano that did not-  -- have this functionality. We then fall back and use collection of “just”-  -- deployed releases.-  case genericDrop n (if null crs then drs else crs) of-    [] -> failWith 1 (Just "Could not find the requested release to rollback to.")+  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  -- | Remove older releases to avoid filling up the target host filesystem.@@ -125,16 +151,19 @@ dropOldReleases   :: Path Abs Dir      -- ^ Deploy path   -> Natural           -- ^ How many releases to keep-  -> Hapistrano ()     -- ^ Deleted Releases-dropOldReleases deployPath n = do+  -> Bool              -- ^ Whether the @--keep-one-failed@ flag is present or not+  -> Hapistrano ()+dropOldReleases deployPath n keepOneFailed = do+  failedReleases <- releasesWithState Fail deployPath+  when (keepOneFailed && length failedReleases > 1) $+    -- Remove every failed release except the most recent one+    forM_ (tail failedReleases) $ \release -> do+      rpath <- releasePath deployPath release Nothing+      exec (Rm rpath) Nothing   dreleases <- deployedReleases deployPath   forM_ (genericDrop n dreleases) $ \release -> do     rpath <- releasePath deployPath release Nothing-    exec (Rm rpath)-  creleases <- completedReleases deployPath-  forM_ (genericDrop n creleases) $ \release -> do-    cpath <- ctokenPath  deployPath release-    exec (Rm cpath)+    exec (Rm rpath) Nothing  -- | Play the given script switching to directory of given release. @@ -146,18 +175,18 @@   -> Hapistrano () playScript deployDir release mWorkingDir cmds = do   rpath <- releasePath deployDir release mWorkingDir-  forM_ cmds (execWithInheritStdout . Cd rpath)+  forM_ cmds (flip execWithInheritStdout (Just release) . Cd rpath)  -- | Plays the given script on your machine locally. -playScriptLocally :: [GenericCommand] -> Hapistrano ()+playScriptLocally :: [GenericCommand] ->  Hapistrano () playScriptLocally cmds =   local     (\c ->         c         { configSshOptions = Nothing         }) $-  forM_ cmds execWithInheritStdout+  forM_ cmds $ flip execWithInheritStdout Nothing  ---------------------------------------------------------------------------- -- Helpers@@ -168,10 +197,9 @@   :: Path Abs Dir      -- ^ Deploy path   -> Hapistrano () setupDirs deployPath = do-  (exec . MkDir . releasesPath)  deployPath-  (exec . MkDir . cacheRepoPath) deployPath-  (exec . MkDir . ctokensPath)   deployPath-  (exec . MkDir . sharedPath)    deployPath+  (flip exec Nothing . MkDir . releasesPath)  deployPath+  (flip exec Nothing . MkDir . cacheRepoPath) deployPath+  (flip exec Nothing . MkDir . sharedPath)    deployPath  -- | Ensure that the specified repo is cloned and checked out on the given -- revision. Idempotent.@@ -179,17 +207,18 @@ ensureCacheInPlace   :: String            -- ^ Repo URL   -> Path Abs Dir      -- ^ Deploy path+  -> Maybe Release     -- ^ Release that was being attempted, if it was defined   -> Hapistrano ()-ensureCacheInPlace repo deployPath = do+ensureCacheInPlace repo deployPath maybeRelease = do   let cpath = cacheRepoPath deployPath       refs  = cpath </> $(mkRelDir "refs")-  exists <- (exec (Ls refs) >> return True)+  exists <- (exec (Ls refs) Nothing >> return True)     `catchError` const (return False)   unless exists $-    exec (GitClone True (Left repo) cpath)-  exec (Cd cpath (GitFetch "origin")) -- TODO store this in task description?+    exec (GitClone True (Left repo) cpath) maybeRelease+  exec (Cd cpath (GitFetch "origin")) maybeRelease -- TODO store this in task description? --- | Create a new realese identifier based on current timestamp.+-- | Create a new release identifier based on current timestamp.  newRelease :: ReleaseFormat -> Hapistrano Release newRelease releaseFormat =@@ -204,7 +233,7 @@ cloneToRelease deployPath release = do   rpath <- releasePath deployPath release Nothing   let cpath = cacheRepoPath deployPath-  exec (GitClone False (Right cpath) rpath)+  exec (GitClone False (Right cpath) rpath) (Just release)  -- | Set the release to the correct revision by checking out a branch or -- a commit.@@ -216,7 +245,7 @@   -> Hapistrano () setReleaseRevision deployPath release revision = do   rpath <- releasePath deployPath release Nothing-  exec (Cd rpath (GitCheckout revision))+  exec (Cd rpath (GitCheckout revision)) (Just release)  -- | Return a list of all currently deployed releases sorted newest first. @@ -225,22 +254,27 @@   -> Hapistrano [Release] deployedReleases deployPath = do   let rpath = releasesPath deployPath-  xs <- exec (Find 1 rpath :: Find Dir)+  xs <- exec (Find 1 rpath :: Find Dir) Nothing   ps <- stripDirs rpath (filter (/= rpath) xs)   (return . sortOn Down . mapMaybe parseRelease)     (dropWhileEnd (== '/') . fromRelDir <$> ps)  -- | Return a list of successfully completed releases sorted newest first. -completedReleases-  :: Path Abs Dir      -- ^ Deploy path+releasesWithState+  :: DeployState       -- ^ Selector for failed or successful releases+  -> Path Abs Dir      -- ^ Deploy path   -> Hapistrano [Release]-completedReleases deployPath = do-  let cpath = ctokensPath deployPath-  xs <- exec (Find 1 cpath :: Find File)-  ps <- stripDirs cpath xs-  (return . sortOn Down . mapMaybe parseRelease)-    (dropWhileEnd (== '/') . fromRelFile <$> ps)+releasesWithState selectedState deployPath = do+  releases <- deployedReleases deployPath+  filterM (+    fmap ((\bool -> if selectedState == Success then bool else not bool) . stateToBool)+     . deployState deployPath Nothing+    ) releases+  where+    stateToBool :: DeployState -> Bool+    stateToBool Fail = False+    stateToBool _    = True  ---------------------------------------------------------------------------- -- Path helpers@@ -268,12 +302,13 @@   -> Path Abs Dir -- ^ Release path   -> Path Abs Dir -- ^ Deploy path   -> FilePath     -- ^ Thing to link in share+  -> Maybe Release -- ^ Release that was being attempted, if it was defined   -> Hapistrano ()-linkToShared configTargetSystem rpath configDeployPath thingToLink = do+linkToShared configTargetSystem rpath configDeployPath thingToLink maybeRelease = do   destPath <- parseRelFile thingToLink   let dpath = rpath </> destPath       sharedPath' = sharedPath configDeployPath </> destPath-  exec $ Ln configTargetSystem sharedPath' dpath+  exec (Ln configTargetSystem sharedPath' dpath) maybeRelease  -- | Construct path to a particular 'Release'. @@ -285,7 +320,7 @@ releasePath deployPath release mWorkingDir =   let rendered = renderRelease release   in case parseRelDir rendered of-    Nothing    -> failWith 1 (Just $ "Could not append path: " ++ rendered)+    Nothing    -> failWith 1 (Just $ "Could not append path: " ++ rendered) (Just release)     Just rpath ->       return $ case mWorkingDir of         Nothing         -> releasesPath deployPath </> rpath@@ -313,24 +348,25 @@   -> Path Abs File tempSymlinkPath deployPath = deployPath </> $(mkRelFile "current_tmp") --- | Get path to the directory that contains tokens of build completion.--ctokensPath-  :: Path Abs Dir      -- ^ Deploy path-  -> Path Abs Dir-ctokensPath deployPath = deployPath </> $(mkRelDir "ctokens")---- | Get path to completion token file for particular release.+-- | Checks if a release was deployed properly or not+-- by looking into the @.hapistrano_deploy_state@ file.+-- If the file doesn't exist or the contents are anything other than+-- 'Fail' or 'Success', it returns 'Nothing'. -ctokenPath-  :: Path Abs Dir      -- ^ Deploy path-  -> Release           -- ^ 'Release' identifier-  -> Hapistrano (Path Abs File)-ctokenPath deployPath release = do-  let rendered = renderRelease release-  case parseRelFile rendered of-    Nothing    -> failWith 1 (Just $ "Could not append path: " ++ rendered)-    Just rpath -> return (ctokensPath deployPath </> rpath)+deployState+  :: Path Abs Dir -- ^ Deploy path+  -> Maybe (Path Rel Dir) -- ^ Working directory+  -> Release -- ^ 'Release' identifier+  -> Hapistrano DeployState -- ^ Whether the release was deployed successfully or not+deployState deployPath mWorkingDir release = do+  parseStatePath <- parseRelFile deployStateFilename+  actualReleasePath <- releasePath deployPath release mWorkingDir+  let stateFilePath = actualReleasePath </> parseStatePath+  doesExist <- exec (CheckExists stateFilePath) (Just release)+  if doesExist then do+    deployStateContents <- exec (Cat stateFilePath) (Just release)+    return $ (fromMaybe Unknown . readMaybe) deployStateContents+  else return Unknown  stripDirs :: Path Abs Dir -> [Path Abs t] -> Hapistrano [Path Rel t] stripDirs path =

@@ -3,16 +3,15 @@ -- Copyright   :  © 2015-Present Stack Builders -- License     :  MIT ----- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com> -- Stability   :  experimental -- Portability :  portable -- -- Collection of type safe shell commands that can be fed into -- 'System.Hapistrano.Core.runCommand'.-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE GADTs               #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies        #-}  module System.Hapistrano.Commands   ( Command(..)@@ -26,6 +25,9 @@   , Readlink(..)   , Find(..)   , Touch(..)+  , Cat(..)+  , CheckExists(..)+  , BasicWrite(..)   , GitCheckout(..)   , GitClone(..)   , GitFetch(..)@@ -36,4 +38,4 @@   , readScript   ) where -import System.Hapistrano.Commands.Internal+import           System.Hapistrano.Commands.Internal

@@ -3,7 +3,6 @@ -- Copyright   :  © 2015-Present Stack Builders -- License     :  MIT ----- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com> -- Stability   :  experimental -- Portability :  portable --@@ -67,7 +66,7 @@   parseResult Proxy = parseResult (Proxy :: Proxy cmd)  -- | Create a directory. Does not fail if the directory already exists.-data MkDir =+newtype MkDir =   MkDir (Path Abs Dir)  instance Command MkDir where@@ -151,7 +150,7 @@  -- | @ls@, so far used only to check existence of directories, so it's not -- very functional right now.-data Ls =+newtype Ls =   Ls (Path Abs Dir)  instance Command Ls where@@ -190,7 +189,7 @@   parseResult Proxy = mapMaybe (parseAbsFile . trim) . lines  -- | @touch@.-data Touch =+newtype Touch =   Touch (Path Abs File)  instance Command Touch where@@ -198,8 +197,49 @@   renderCommand (Touch path) = formatCmd "touch" [Just (fromAbsFile path)]   parseResult Proxy _ = () +-- | Command that checks for the existance of a particular+-- file in the host.++newtype CheckExists =+  CheckExists+  (Path Abs File) -- ^ The absolute path to the file you want to check for existence++instance Command CheckExists where+  type Result CheckExists = Bool+  renderCommand (CheckExists path) = +    "([ -r " <> fromAbsFile path <> " ] && echo True) || echo False"+  parseResult Proxy = read++-- | Command used to read the contents of a particular+-- file in the host.++newtype Cat =+  Cat+  (Path Abs File) -- ^ The absolute path to the file you want to read++instance Command Cat where+  type Result Cat = String+  renderCommand (Cat path) = formatCmd "cat" [Just (fromAbsFile path)]+  parseResult Proxy = id ++-- | Basic command that writes to a file some contents.+-- It uses the @file > contents@ shell syntax and the @contents@ is+-- represented as a 'String', so it shouldn't be used for+-- bigger writing operations. Currently used to write @fail@ or @success@+-- to the @.hapistrano_deploy_state@ file.+data BasicWrite =+  BasicWrite +  (Path Abs File) -- ^ The absolute path to the file to which you want to write+  String -- ^ The contents that will be written to the file++instance Command BasicWrite where+  type Result BasicWrite = ()+  renderCommand (BasicWrite path contents) =+     "echo \"" <> contents <> "\"" <> " > " <> fromAbsFile path+  parseResult Proxy _ = ()+ -- | Git checkout.-data GitCheckout =+newtype GitCheckout =   GitCheckout String  instance Command GitCheckout where@@ -230,7 +270,7 @@   parseResult Proxy _ = ()  -- | Git fetch (simplified).-data GitFetch =+newtype GitFetch =   GitFetch String  instance Command GitFetch where@@ -242,7 +282,7 @@   parseResult Proxy _ = ()  -- | Git reset.-data GitReset =+newtype GitReset =   GitReset String  instance Command GitReset where@@ -252,7 +292,7 @@   parseResult Proxy _ = ()  -- | Weakly-typed generic command, avoid using it directly.-data GenericCommand =+newtype GenericCommand =   GenericCommand String   deriving (Show, Eq, Ord) 

@@ -1,3 +1,13 @@+-- |+-- Module      :  System.Config+-- Copyright   :  © 2015-Present Stack Builders+-- License     :  MIT+--+-- Stability   :  experimental+-- Portability :  portable+--+-- Definitions for types and functions related to the configuration+-- of the Hapistrano tool. {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}@@ -7,7 +17,8 @@ module System.Hapistrano.Config   ( Config (..)   , CopyThing (..)-  , Target (..))+  , Target (..)+  , deployStateFilename) where  import           Control.Applicative        ((<|>))@@ -19,10 +30,8 @@ import           Numeric.Natural import           Path import           System.Hapistrano.Commands-import           System.Hapistrano.Types    (Shell(..),-                                             ReleaseFormat (..),-                                             Source(..),-                                             TargetSystem (..))+import           System.Hapistrano.Types    (ReleaseFormat (..), Shell (..),+                                             Source (..), TargetSystem (..))  -- | Hapistrano configuration typically loaded from @hap.yaml@ file. @@ -42,12 +51,12 @@     -- ^ Collection of files to copy over to target machine before building   , 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-  -- ^ Perform version control related actions. By default, it's assumed to be True.+  -- ^ Perform version control related actions. By default, it's assumed to be `True`.   , configRunLocally     :: !(Maybe [GenericCommand])   -- ^ Perform a series of commands on the local machine before communication   -- with target server starts@@ -55,14 +64,20 @@   -- ^ Optional parameter to specify the target system. It's GNU/Linux by   -- default   , configReleaseFormat  :: !(Maybe ReleaseFormat)-  -- ^ The release timestamp format, the '--release-format' argument passed via+  -- ^ 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)-  -- ^ The number of releases to keep, the '--keep-releases' argument passed via+  -- ^ 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-  , configWorkingDir :: !(Maybe (Path Rel Dir))+  , 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))   } deriving (Eq, Ord, Show)  -- | Information about source and destination locations of a file\/directory@@ -71,6 +86,8 @@ data CopyThing = CopyThing FilePath FilePath   deriving (Eq, Ord, Show) +-- | Datatype that holds information about the target host.+ data Target =   Target     { targetHost    :: String@@ -116,6 +133,7 @@     configTargetSystem <- o .:? "linux" .!= GNULinux     configReleaseFormat <- o .:? "release_format"     configKeepReleases <- o .:? "keep_releases"+    configKeepOneFailed <- o .:? "keep_one_failed" .!= False     configWorkingDir <- o .:? "working_directory"     return Config {..} @@ -134,3 +152,9 @@   case mkGenericCommand raw of     Nothing  -> fail "invalid restart command"     Just cmd -> return cmd++-- | Constant with the name of the file used to store+-- the deployment state information.++deployStateFilename :: String+deployStateFilename = ".hapistrano_deploy_state"

@@ -3,7 +3,6 @@ -- Copyright   :  © 2015-Present Stack Builders -- License     :  MIT ----- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com> -- Stability   :  experimental -- Portability :  portable --@@ -14,8 +13,7 @@ {-# LANGUAGE ScopedTypeVariables #-}  module System.Hapistrano.Core-  ( runHapistrano-  , failWith+  ( failWith   , exec   , execWithInheritStdout   , scpFile@@ -32,38 +30,14 @@ import           System.Console.ANSI import           System.Exit import           System.Hapistrano.Commands-import           System.Hapistrano.Types+import           System.Hapistrano.Types    hiding (Command) import           System.Process import           System.Process.Typed       (ProcessConfig) import qualified System.Process.Typed       as SPT --- | Run the 'Hapistrano' monad. The monad hosts 'exec' actions.-runHapistrano ::-     MonadIO m-  => Maybe SshOptions -- ^ SSH options to use or 'Nothing' if we run locally-  -> Shell -- ^ Shell to run commands-  -> (OutputDest -> String -> IO ()) -- ^ How to print messages-  -> Hapistrano a -- ^ The computation to run-  -> m (Either Int a) -- ^ Status code in 'Left' on failure, result in-              -- 'Right' on success-runHapistrano sshOptions shell' printFnc m =-  liftIO $ do-    let config =-          Config-            { configSshOptions = sshOptions-            , configShellOptions = shell'-            , configPrint = printFnc-            }-    r <- runReaderT (runExceptT m) config-    case r of-      Left (Failure n msg) -> do-        forM_ msg (printFnc StderrDest)-        return (Left n)-      Right x -> return (Right x)- -- | Fail returning the following status code and message.-failWith :: Int -> Maybe String -> Hapistrano a-failWith n msg = throwError (Failure n msg)+failWith :: Int -> Maybe String -> Maybe Release -> Hapistrano a+failWith n msg maybeRelease = throwError (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@@ -74,20 +48,25 @@ -- parse the result. exec ::      forall a. Command a-  => a+  => a -- ^ Command being executed+  -> Maybe Release -- ^ Release that was being attempted, if it was defined   -> Hapistrano (Result a)-exec typedCmd = do+exec typedCmd maybeRelease = do   let cmd = renderCommand typedCmd   (prog, args) <- getProgAndArgs cmd   parseResult (Proxy :: Proxy a) <$>-    exec' cmd (readProcessWithExitCode prog args "")+    exec' cmd (readProcessWithExitCode prog args "") maybeRelease  -- | Same as 'exec' but it streams to stdout only for _GenericCommand_s-execWithInheritStdout :: Command a => a -> Hapistrano ()-execWithInheritStdout typedCmd = do+execWithInheritStdout ::+     Command a+  => a -- ^ Command being executed+  -> Maybe Release -- ^ Release that was being attempted, if it was defined+  -> Hapistrano ()+execWithInheritStdout typedCmd maybeRelease = do   let cmd = renderCommand typedCmd   (prog, args) <- getProgAndArgs cmd-  void $ exec' cmd (readProcessWithExitCode' (SPT.proc prog args))+  void $ exec' cmd (readProcessWithExitCode' (SPT.proc prog args)) maybeRelease     where     -- | Prepares a process, reads @stdout@ and @stderr@ and returns exit code     -- NOTE: @strdout@ and @stderr@ are empty string because we're writing@@ -101,7 +80,7 @@       where         pc' = SPT.setStdout SPT.inherit $ SPT.setStderr SPT.inherit pc --- | Get program and args to run a command locally or remotelly.+-- | Get program and args to run a command locally or remotely. getProgAndArgs :: String -> Hapistrano (String, [String]) getProgAndArgs cmd = do   Config {..} <- ask@@ -120,6 +99,7 @@ scpFile ::      Path Abs File -- ^ Location of the file to copy   -> Path Abs File -- ^ Where to put the file on target machine+  -> Maybe Release -- ^ Release that was being attempted, if it was defined   -> Hapistrano () scpFile src dest = scp' (fromAbsFile src) (fromAbsFile dest) ["-q"] @@ -127,11 +107,12 @@ scpDir ::      Path Abs Dir -- ^ Location of the directory to copy   -> Path Abs Dir -- ^ Where to put the dir on target machine+  -> Maybe Release -- ^ Release that was being attempted, if it was defined   -> Hapistrano () scpDir src dest = scp' (fromAbsDir src) (fromAbsDir dest) ["-qr"] -scp' :: FilePath -> FilePath -> [String] -> Hapistrano ()-scp' src dest extraArgs = do+scp' :: FilePath -> FilePath -> [String] -> Maybe Release -> Hapistrano ()+scp' src dest extraArgs maybeRelease = do   Config {..} <- ask   let prog = "scp"       portArg =@@ -144,7 +125,7 @@           Just x  -> x ++ ":"       args = extraArgs ++ portArg ++ [src, hostPrefix ++ dest]   void-    (exec' (prog ++ " " ++ unwords args) (readProcessWithExitCode prog args ""))+    (exec' (prog ++ " " ++ unwords args) (readProcessWithExitCode prog args "") maybeRelease)  ---------------------------------------------------------------------------- -- Helpers@@ -152,8 +133,9 @@ exec' ::      String -- ^ How to show the command in print-outs   -> IO (ExitCode, String, String) -- ^ Handler to get (ExitCode, Output, Error) it can change accordingly to @stdout@ and @stderr@ of child process+  -> Maybe Release -- ^ Release that was being attempted, if it was defined   -> Hapistrano String -- ^ Raw stdout output of that program-exec' cmd readProcessOutput = do+exec' cmd readProcessOutput maybeRelease = do   Config {..} <- ask   time <- liftIO getZonedTime   let timeStampFormat = "%T,  %F (%Z)"@@ -171,7 +153,7 @@   unless (null stderr') . liftIO $ configPrint StderrDest stderr'   case exitCode' of     ExitSuccess   -> return stdout'-    ExitFailure n -> failWith n Nothing+    ExitFailure n -> failWith n Nothing maybeRelease  -- | Put something “inside” a line, sort-of beautifully. putLine :: String -> String

@@ -3,13 +3,12 @@ -- Copyright   :  © 2015-Present Stack Builders -- License     :  MIT ----- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com> -- Stability   :  experimental -- Portability :  portable -- -- Type definitions for the Hapistrano tool.+{-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}  module System.Hapistrano.Types   ( Hapistrano@@ -22,7 +21,10 @@   , OutputDest(..)   , Release   , TargetSystem(..)+  , DeployState(..)   , Shell(..)+  , Opts(..)+  , Command(..)   -- * Types helpers   , mkRelease   , releaseTime@@ -33,17 +35,17 @@   , toMaybePath   ) where -import Control.Applicative-import Control.Monad.Except-import Control.Monad.Reader-import Data.Aeson-import Data.Maybe-import Data.Time-import Numeric.Natural-import Path+import           Control.Applicative+import           Control.Monad.Except+import           Control.Monad.Reader+import           Data.Aeson+import           Data.Maybe+import           Data.Time+import           Numeric.Natural+import           Path  -- | Hapistrano monad.-type Hapistrano a = ExceptT Failure (ReaderT Config IO) a+type Hapistrano a = ExceptT (Failure, Maybe Release) (ReaderT Config IO) a  -- | Failure with status code and a message. data Failure =@@ -52,11 +54,11 @@ -- | Hapistrano configuration options. data Config =   Config-    { configSshOptions :: !(Maybe SshOptions)+    { configSshOptions   :: !(Maybe SshOptions)     -- ^ 'Nothing' if we are running locally, or SSH options to use.     , configShellOptions :: !Shell     -- ^ One of the supported 'Shell's-    , configPrint :: !(OutputDest -> String -> IO ())+    , configPrint        :: !(OutputDest -> String -> IO ())     -- ^ How to print messages     } @@ -64,7 +66,7 @@ -- like GitHub or a local directory. data Source   = GitRepository-      { gitRepositoryURL :: String+      { gitRepositoryURL      :: String       -- ^ The URL of remote Git repository to deploy       , gitRepositoryRevision :: String       -- ^ The SHA1 or branch to release@@ -78,9 +80,9 @@ -- | The records describes deployment task. data Task =   Task-    { taskDeployPath :: Path Abs Dir+    { taskDeployPath    :: Path Abs Dir     -- ^ The root of the deploy target on the remote host-    , taskSource :: Source+    , taskSource        :: Source     -- ^ The 'Source' to deploy     , taskReleaseFormat :: ReleaseFormat     -- ^ The 'ReleaseFormat' to use@@ -133,12 +135,41 @@   Release ReleaseFormat UTCTime   deriving (Eq, Show, Ord) --- | Target's system where application will be deployed+-- | Target's system where application will be deployed. data TargetSystem   = GNULinux   | BSD   deriving (Eq, Show, Read, Ord, Bounded, Enum) +-- | State of the deployment after running @hap deploy@.+-- __note:__ the 'Unknown' value is not intended to be+-- written to the @.hapistrano_deploy_state@ file; instead,+-- it's intended to represent whenever Hapistrano couldn't+-- get the information on the deployment state (e.g. the file is not present).+data DeployState+  = Fail+  | Success+  | Unknown+  deriving (Eq, Show, Read, Ord, Bounded, Enum)++-- Command line options++-- | Command line options.++data Opts = Opts+  { optsCommand    :: Command+  , optsConfigFile :: FilePath+  }++-- | Command to execute and command-specific options.++data Command+  = Deploy (Maybe ReleaseFormat) (Maybe Natural) Bool -- ^ Deploy a new release (with timestamp+    -- format, how many releases to keep, and whether the failed releases except the latest one+    -- get deleted or not)+  | Rollback Natural -- ^ Rollback to Nth previous release++ -- | Create a 'Release' indentifier. mkRelease :: ReleaseFormat -> UTCTime -> Release mkRelease = Release@@ -154,7 +185,7 @@     fmt =       case rfmt of         ReleaseShort -> releaseFormatShort-        ReleaseLong -> releaseFormatLong+        ReleaseLong  -> releaseFormatLong  ---------------------------------------------------------------------------- -- Types helpers