Added CLI flag and hap.yaml setting for keeping failed releases

README.md

@@ -108,6 +108,10 @@ The following parameters are *optional*:
   '--keep-releases' argument passed via the CLI takes precedence over this
   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_

app/Main.hs

@@ -9,9 +9,9 @@ import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Monad
 
-#if !MIN_VERSION_base(4,13,0)
-import           Data.Monoid                ((<>))
-#endif
+
+
+
 import           Data.Version               (showVersion)
 import qualified Data.Yaml.Config           as Yaml
 import           Development.GitRev
@@ -42,7 +42,7 @@ data Opts = Opts
 -- | Command to execute and command-specific options.
 
 data Command
-  = Deploy (Maybe ReleaseFormat) (Maybe Natural) -- ^ Deploy a new release (with timestamp
+  = Deploy (Maybe ReleaseFormat) (Maybe Natural) Bool -- ^ Deploy a new release (with timestamp
     -- format and how many releases to keep)
   | Rollback Natural -- ^ Rollback to Nth previous release
 
@@ -95,6 +95,11 @@ deployParser = Deploy
             <> help "How many releases to keep, default is '5'"
             )
         )
+  <*> switch
+            ( long "keep-one-failed"
+            <> short 'f'
+            <> 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
@@ -136,9 +141,10 @@ main = do
       hap shell sshOpts =  do
         r <- Hap.runHapistrano sshOpts shell printFnc $
           case optsCommand of
-            Deploy cliReleaseFormat cliKeepReleases -> do
+            Deploy cliReleaseFormat cliKeepReleases cliKeepOneFailed -> do
               let releaseFormat = fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat
                   keepReleases = fromMaybeKeepReleases cliKeepReleases configKeepReleases
+                  keepOneFailed = cliKeepOneFailed || configKeepOneFailed
               forM_ configRunLocally Hap.playScriptLocally
               release <- if configVcAction
                           then Hap.pushRelease (task releaseFormat)
@@ -187,7 +193,7 @@ main = do
         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)

spec/System/HapistranoConfigSpec.hs

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

src/System/Hapistrano.hs

@@ -189,7 +189,7 @@ ensureCacheInPlace repo deployPath = do
     exec (GitClone True (Left repo) cpath)
   exec (Cd cpath (GitFetch "origin")) -- 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 =

src/System/Hapistrano/Config.hs

@@ -47,7 +47,7 @@ data Config = Config
   , 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,13 +55,19 @@ data Config = Config
   -- ^ 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
+  , 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)
 
@@ -116,6 +122,7 @@ instance FromJSON Config where
     configTargetSystem <- o .:? "linux" .!= GNULinux
     configReleaseFormat <- o .:? "release_format"
     configKeepReleases <- o .:? "keep_releases"
+    configKeepOneFailed <- o .:? "keep_one_failed" .!= False
     configWorkingDir <- o .:? "working_directory"
     return Config {..}