Merge pull request #174 from stackbuilders/keep-failed-releases

Added `keep_one_failed` option that deletes failed releases except for the latest one

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

@@ -8,7 +8,6 @@ module Main (main) where
 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           Data.Version               (showVersion)
 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,23 +26,10 @@ import qualified System.Hapistrano.Config   as C
 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 =
@@ -95,6 +80,10 @@ deployParser = Deploy
             <> 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 @@ data Message
 
 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 @@ main = do
                      , 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
+                  keepOneFailed = cliKeepOneFailed || configKeepOneFailed
-              release <- if configVcAction
+                  -- We define the handler for when an exception happens inside a deployment
-                          then Hap.pushRelease (task releaseFormat)
+                  failStateAndThrow e@(_, maybeRelease) = do
-                          else Hap.pushReleaseWithoutVc (task releaseFormat)
+                    case maybeRelease of
-              rpath <- Hap.releasePath configDeployPath release configWorkingDir
+                      (Just release) -> do
-              forM_ (toMaybePath configSource) $ \src ->
+                        createHapistranoDeployState configDeployPath release Fail
-                Hap.scpDir src rpath
+                        Hap.dropOldReleases configDeployPath keepReleases keepOneFailed 
-              forM_ configCopyFiles $ \(C.CopyThing src dest) -> do
+                        throwError e
-                srcPath  <- resolveFile' src
+                      Nothing -> do
-                destPath <- parseRelFile dest
+                        throwError e
-                let dpath = rpath </> destPath
+              in do
-                (Hap.exec . Hap.MkDir . parent) dpath
+                forM_ configRunLocally Hap.playScriptLocally
-                Hap.scpFile srcPath dpath
+                release <- if configVcAction
-              forM_ configCopyDirs $ \(C.CopyThing src dest) -> do
+                            then Hap.pushRelease (task releaseFormat)
-                srcPath  <- resolveDir' src
+                            else Hap.pushReleaseWithoutVc (task releaseFormat)
-                destPath <- parseRelDir dest
+                rpath <- Hap.releasePath configDeployPath release configWorkingDir
-                let dpath = rpath </> destPath
+                forM_ (toMaybePath configSource) $ \src ->
-                (Hap.exec . Hap.MkDir . parent) dpath
+                  Hap.scpDir src rpath (Just release)
-                Hap.scpDir srcPath dpath
+                forM_ configCopyFiles $ \(C.CopyThing src dest) -> do
-              forM_ configLinkedFiles
+                  srcPath  <- resolveFile' src
-                (Hap.linkToShared configTargetSystem rpath configDeployPath)
+                  destPath <- parseRelFile dest
-              forM_ configLinkedDirs
+                  let dpath = rpath </> destPath
-                (Hap.linkToShared configTargetSystem rpath configDeployPath)
+                  (flip Hap.exec (Just release) . Hap.MkDir . parent) dpath
-              forM_ configBuildScript (Hap.playScript configDeployPath release configWorkingDir)
+                  Hap.scpFile srcPath dpath (Just release)
-              Hap.registerReleaseAsComplete configDeployPath release
+                forM_ configCopyDirs $ \(C.CopyThing src dest) -> do
-              Hap.activateRelease configTargetSystem configDeployPath release
+                  srcPath  <- resolveDir' src
-              Hap.dropOldReleases configDeployPath keepReleases
+                  destPath <- parseRelDir dest
-              forM_ configRestartCommand Hap.exec
+                  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 @@ 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)

example/example.cabal

@@ -5,7 +5,7 @@ description:
   This is an example project that has been created in order to test
   the deployment process using the working_dir feature of hapistrano.
 author:         Justin Leitgeb
-maintainer:     jpaucar@stackbuilders.com
+maintainer:     cmotoche@stackbuilders.com
 copyright:      2015-Present Stack Builders Inc.
 license:        MIT
 license-file:   ../LICENSE

hapistrano.cabal

@@ -21,7 +21,7 @@ description:
 license:             MIT
 license-file:        LICENSE
 author:              Justin Leitgeb
-maintainer:          jpaucar@stackbuilders.com
+maintainer:          cmotoche@stackbuilders.com
 copyright:           2015-Present Stack Builders Inc.
 category:            System
 homepage:            https://github.com/stackbuilders/hapistrano
@@ -82,6 +82,7 @@ executable hap
                      , 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

spec/System/HapistranoConfigSpec.hs

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

spec/System/HapistranoSpec.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP             #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module System.HapistranoSpec
   ( spec
@@ -11,9 +12,9 @@ import Data.List (isPrefixOf)
 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)
@@ -27,7 +28,9 @@ import System.Info (os)
 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 @@ spec = do
     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 @@ spec = do
             ("test `git rev-parse --abbrev-ref HEAD` = " ++ testBranchName)
         -- This fails if there are unstaged changes
           justExec rpath "git diff --exit-code"
-    describe "registerReleaseAsComplete" $
+    describe "createHapistranoDeployState" $ do
-      it "creates the token all right" $ \(deployPath, repoPath) ->
+      it ("creates the " <> deployStateFilename <> " file correctly") $ \(deployPath, repoPath) ->
         runHap $ do
           let task = mkTask deployPath repoPath
           release <- Hap.pushRelease task
-          Hap.registerReleaseAsComplete deployPath release
+          parseStatePath <- parseRelFile deployStateFilename
-          (Hap.ctokenPath deployPath release >>= doesFileExist) `shouldReturn`
+          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 @@ spec = do
           let rc :: Hap.Readlink Dir
               rc =
                 Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath)
-          Hap.exec rc `shouldReturn` rpath
+          Hap.exec rc (Just release) `shouldReturn` rpath
-          doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False
+          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 @@ spec = do
               task = mkTask deployPath repoPath
           Hap.playScriptLocally localCommands
           release <- Hap.pushRelease task
-          Hap.registerReleaseAsComplete deployPath release
+          parseStatePath <- parseRelFile deployStateFilename
-          (Hap.ctokenPath deployPath release >>= doesFileExist) `shouldReturn`
+          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 @@ spec = do
                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) ->
-        it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) ->
+        runHap $ do
-          runHap $ do
+          let task = mkTask deployPath repoPath
-            let task = mkTask deployPath repoPath
+          rs <- replicateM 5 (Hap.pushRelease task)
-            rs <- replicateM 5 (Hap.pushRelease task)
+          Hap.rollback currentSystem deployPath 2
-            Hap.rollback currentSystem deployPath 2
+          rpath <- Hap.releasePath deployPath (rs !! 2) Nothing
-            rpath <- Hap.releasePath deployPath (rs !! 2) Nothing
+          let rc :: Hap.Readlink Dir
-            let rc :: Hap.Readlink Dir
+              rc =
-                rc =
+                Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath)
-                  Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath)
+          Hap.exec rc Nothing `shouldReturn` rpath
-            Hap.exec rc `shouldReturn` rpath
+          Path.IO.doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False
-            doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False
+    describe "dropOldReleases" $ do
-      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 "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
+          Hap.dropOldReleases deployPath 5 False
-        -- two oldest releases should not survive:
+          -- 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:
+      context "when the --keep-one-failed flag is active" $
-          forM_ (take 2 rs) $ \r ->
+        it "should delete failed releases other than the most recent" $ \(deployPath, repoPath) ->
-            (Hap.ctokenPath deployPath r >>= doesFileExist) `shouldReturn` False
+          let successfulRelease = mkReleaseWithState deployPath repoPath Success 
-        -- 5 most recent completion tokens should stay alive:
+              failedRelease = mkReleaseWithState deployPath repoPath Fail in
-          forM_ (drop 2 rs) $ \r ->
+          runHap $ do
-            (Hap.ctokenPath deployPath r >>= doesFileExist) `shouldReturn` True
+            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,8 +262,8 @@ spec = do
                 sharedDir = Hap.sharedPath deployPath
             release <- Hap.pushRelease task
             rpath <- Hap.releasePath deployPath release Nothing
-            Hap.exec $ Hap.Rm sharedDir
+            Hap.exec (Hap.Rm sharedDir) (Just release)
-            Hap.linkToShared currentSystem rpath deployPath "thing" `shouldReturn`
+            Hap.linkToShared currentSystem rpath deployPath "thing" (Just release) `shouldReturn`
               ()
       context "when the file/directory to link exists in the repository" $
         it "should throw an error" $ \(deployPath, repoPath) ->
@@ -258,7 +271,7 @@ spec = do
             (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 attempts to link a file" $ do
         context "when the file is not at the root of the shared directory" $
@@ -270,7 +283,7 @@ spec = do
                   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 @@ spec = do
               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 @@ spec = do
                   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 @@ spec = do
             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 @@ populateTestRepo path =
 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')
+    Nothing -> Hap.failWith 1 (Just $ "Failed to parse the command: " ++ cmd') Nothing
-    Just cmd -> Hap.exec (Hap.Cd path cmd)
+    Just cmd -> Hap.exec (Hap.Cd path cmd) Nothing
 
 -- | Run 'Hapistrano' monad locally.
 runHap :: Hapistrano a -> IO a
@@ -398,6 +411,14 @@ mkTaskWithCustomRevision deployPath repoPath revision =
     , 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 =
   if os == "linux"

src/System/Hapistrano.hs

@@ -15,11 +15,12 @@
 {-# LANGUAGE TemplateHaskell     #-}
 
 module System.Hapistrano
-  ( pushRelease
+  ( runHapistrano
+  , pushRelease
   , pushReleaseWithoutVc
-  , registerReleaseAsComplete
   , activateRelease
   , linkToShared
+  , createHapistranoDeployState
   , rollback
   , dropOldReleases
   , playScript
@@ -29,14 +30,14 @@ module System.Hapistrano
   , 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                 (mapMaybe, fromMaybe)
 import           Data.Ord                   (Down (..))
 import           Data.Time
 import           Numeric.Natural
@@ -44,8 +45,35 @@ import           Path
 import           System.Hapistrano.Commands
 import           System.Hapistrano.Core
 import           System.Hapistrano.Types
+import           System.Hapistrano.Config (deployStateFilename)
+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 +88,7 @@ pushRelease Task {..} = do
     -- 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 +104,6 @@ pushReleaseWithoutVc Task {..} = do
   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,8 +116,23 @@ activateRelease ts deployPath release = do
   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 (Ln ts rpath tpath) (Just release) -- create a symlink for the new candidate
-  exec (Mv ts tpath cpath) -- atomically replace the symlink
+  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.
 
@@ -110,14 +142,9 @@ rollback
   -> Natural           -- ^ How many releases back to go, 0 re-activates current
   -> Hapistrano ()
 rollback ts deployPath n = do
-  crs <- completedReleases deployPath
+  releases <- releasesWithState Success deployPath
-  drs <- deployedReleases  deployPath
+  case genericDrop n releases of
-  -- NOTE If we don't have any completed releases, then perhaps the
+    [] -> failWith 1 (Just "Could not find the requested release to rollback to.") Nothing
-  -- 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.")
     (x:_) -> activateRelease ts deployPath x
 
 -- | Remove older releases to avoid filling up the target host filesystem.
@@ -125,16 +152,19 @@ rollback ts deployPath n = do
 dropOldReleases
   :: Path Abs Dir      -- ^ Deploy path
   -> Natural           -- ^ How many releases to keep
-  -> Hapistrano ()     -- ^ Deleted Releases
+  -> Bool              -- ^ Whether the @--keep-one-failed@ flag is present or not
-dropOldReleases deployPath n = do
+  -> 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)
+    exec (Rm rpath) Nothing
-  creleases <- completedReleases deployPath
-  forM_ (genericDrop n creleases) $ \release -> do
-    cpath <- ctokenPath  deployPath release
-    exec (Rm cpath)
 
 -- | Play the given script switching to directory of given release.
 
@@ -146,18 +176,18 @@ playScript
   -> 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 +198,9 @@ setupDirs
   :: Path Abs Dir      -- ^ Deploy path
   -> Hapistrano ()
 setupDirs deployPath = do
-  (exec . MkDir . releasesPath)  deployPath
+  (flip exec Nothing . MkDir . releasesPath)  deployPath
-  (exec . MkDir . cacheRepoPath) deployPath
+  (flip exec Nothing . MkDir . cacheRepoPath) deployPath
-  (exec . MkDir . ctokensPath)   deployPath
+  (flip exec Nothing . MkDir . sharedPath)    deployPath
-  (exec . MkDir . sharedPath)    deployPath
 
 -- | Ensure that the specified repo is cloned and checked out on the given
 -- revision. Idempotent.
@@ -179,17 +208,18 @@ setupDirs deployPath = do
 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 (GitClone True (Left repo) cpath) maybeRelease
-  exec (Cd cpath (GitFetch "origin")) -- TODO store this in task description?
+  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 +234,7 @@ cloneToRelease
 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 +246,7 @@ setReleaseRevision
   -> 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 +255,27 @@ deployedReleases
   -> 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
+releasesWithState
-  :: Path Abs Dir      -- ^ Deploy path
+  :: DeployState       -- ^ Selector for failed or successful releases
+  -> Path Abs Dir      -- ^ Deploy path
   -> Hapistrano [Release]
-completedReleases deployPath = do
+releasesWithState selectedState deployPath = do
-  let cpath = ctokensPath deployPath
+  releases <- deployedReleases deployPath
-  xs <- exec (Find 1 cpath :: Find File)
+  filterM (
-  ps <- stripDirs cpath xs
+    fmap ((\bool -> if selectedState == Success then bool else not bool) . stateToBool)
-  (return . sortOn Down . mapMaybe parseRelease)
+     . deployState deployPath Nothing
-    (dropWhileEnd (== '/') . fromRelFile <$> ps)
+    ) releases
+  where
+    stateToBool :: DeployState -> Bool
+    stateToBool Fail = False
+    stateToBool _ = True
 
 ----------------------------------------------------------------------------
 -- Path helpers
@@ -268,12 +303,13 @@ linkToShared
   -> 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 +321,7 @@ releasePath
 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 +349,25 @@ tempSymlinkPath
   -> Path Abs File
 tempSymlinkPath deployPath = deployPath </> $(mkRelFile "current_tmp")
 
--- | Get path to the directory that contains tokens of build completion.
+-- | 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'.
 
-ctokensPath
+deployState
-  :: Path Abs Dir      -- ^ Deploy path
+  :: Path Abs Dir -- ^ Deploy path
-  -> Path Abs Dir
+  -> Maybe (Path Rel Dir) -- ^ Working directory
-ctokensPath deployPath = deployPath </> $(mkRelDir "ctokens")
+  -> Release -- ^ 'Release' identifier
-
+  -> Hapistrano DeployState -- ^ Whether the release was deployed successfully or not
--- | Get path to completion token file for particular release.
+deployState deployPath mWorkingDir release = do
-
+  parseStatePath <- parseRelFile deployStateFilename
-ctokenPath
+  actualReleasePath <- releasePath deployPath release mWorkingDir
-  :: Path Abs Dir      -- ^ Deploy path
+  let stateFilePath = actualReleasePath </> parseStatePath
-  -> Release           -- ^ 'Release' identifier
+  doesExist <- exec (CheckExists stateFilePath) (Just release)
-  -> Hapistrano (Path Abs File)
+  if doesExist then do
-ctokenPath deployPath release = do
+    deployStateContents <- exec (Cat stateFilePath) (Just release)
-  let rendered = renderRelease release
+    return $ (fromMaybe Unknown . readMaybe) deployStateContents
-  case parseRelFile rendered of
+  else return Unknown 
-    Nothing    -> failWith 1 (Just $ "Could not append path: " ++ rendered)
-    Just rpath -> return (ctokensPath deployPath </> rpath)
 
 stripDirs :: Path Abs Dir -> [Path Abs t] -> Hapistrano [Path Rel t]
 stripDirs path =

src/System/Hapistrano/Commands.hs

@@ -3,7 +3,7 @@
 -- Copyright   :  © 2015-Present Stack Builders
 -- License     :  MIT
 --
--- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com>
+-- Maintainer  :  Cristhian Motoche <cmotoche@stackbuilders.com>
 -- Stability   :  experimental
 -- Portability :  portable
 --
@@ -26,6 +26,9 @@ module System.Hapistrano.Commands
   , Readlink(..)
   , Find(..)
   , Touch(..)
+  , Cat(..)
+  , CheckExists(..)
+  , BasicWrite(..)
   , GitCheckout(..)
   , GitClone(..)
   , GitFetch(..)

src/System/Hapistrano/Commands/Internal.hs

@@ -3,7 +3,7 @@
 -- Copyright   :  © 2015-Present Stack Builders
 -- License     :  MIT
 --
--- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com>
+-- Maintainer  :  Cristhian Motoche <cmotoche@stackbuilders.com>
 -- Stability   :  experimental
 -- Portability :  portable
 --
@@ -67,7 +67,7 @@ instance Command cmd => Command (Cd cmd) where
   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 +151,7 @@ instance Command (Readlink Dir) where
 
 -- | @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 +190,7 @@ instance Command (Find File) where
   parseResult Proxy = mapMaybe (parseAbsFile . trim) . lines
 
 -- | @touch@.
-data Touch =
+newtype Touch =
   Touch (Path Abs File)
 
 instance Command Touch where
@@ -198,8 +198,49 @@ instance Command Touch where
   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 +271,7 @@ instance Command GitClone where
   parseResult Proxy _ = ()
 
 -- | Git fetch (simplified).
-data GitFetch =
+newtype GitFetch =
   GitFetch String
 
 instance Command GitFetch where
@@ -242,7 +283,7 @@ instance Command GitFetch where
   parseResult Proxy _ = ()
 
 -- | Git reset.
-data GitReset =
+newtype GitReset =
   GitReset String
 
 instance Command GitReset where
@@ -252,7 +293,7 @@ instance Command GitReset where
   parseResult Proxy _ = ()
 
 -- | Weakly-typed generic command, avoid using it directly.
-data GenericCommand =
+newtype GenericCommand =
   GenericCommand String
   deriving (Show, Eq, Ord)
 

src/System/Hapistrano/Config.hs

@@ -1,3 +1,14 @@
+-- |
+-- Module      :  System.Config
+-- Copyright   :  © 2015-Present Stack Builders
+-- License     :  MIT
+--
+-- Maintainer  :  Cristhian Motoche <cmotoche@stackbuilders.com>
+-- 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 +18,8 @@
 module System.Hapistrano.Config
   ( Config (..)
   , CopyThing (..)
-  , Target (..))
+  , Target (..)
+  , deployStateFilename)
 where
 
 import           Control.Applicative        ((<|>))
@@ -47,7 +59,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 +67,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)
 
@@ -71,6 +89,8 @@ data Config = Config
 data CopyThing = CopyThing FilePath FilePath
   deriving (Eq, Ord, Show)
 
+-- | Datatype that holds information about the target host.
+
 data Target =
   Target
     { targetHost    :: String
@@ -116,6 +136,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 {..}
 
@@ -134,3 +155,9 @@ mkCmd raw =
   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"

src/System/Hapistrano/Core.hs

@@ -3,7 +3,7 @@
 -- Copyright   :  © 2015-Present Stack Builders
 -- License     :  MIT
 --
--- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com>
+-- Maintainer  :  Cristhian Motoche <cmotoche@stackbuilders.com>
 -- Stability   :  experimental
 -- Portability :  portable
 --
@@ -14,8 +14,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module System.Hapistrano.Core
-  ( runHapistrano
+  ( failWith
-  , failWith
   , exec
   , execWithInheritStdout
   , scpFile
@@ -32,38 +31,14 @@ import           Path
 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 :: Int -> Maybe String -> Maybe Release -> Hapistrano a
-failWith n msg = throwError (Failure n msg)
+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 +49,25 @@ failWith n msg = throwError (Failure n msg)
 -- 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 ::
-execWithInheritStdout typedCmd = do
+     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
@@ -120,6 +100,7 @@ getProgAndArgs cmd = do
 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 +108,12 @@ scpFile src dest = scp' (fromAbsFile src) (fromAbsFile dest) ["-q"]
 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' :: FilePath -> FilePath -> [String] -> Maybe Release -> Hapistrano ()
-scp' src dest extraArgs = do
+scp' src dest extraArgs maybeRelease = do
   Config {..} <- ask
   let prog = "scp"
       portArg =
@@ -144,7 +126,7 @@ scp' src dest extraArgs = do
           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 +134,9 @@ scp' src dest extraArgs = do
 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 +154,7 @@ exec' cmd readProcessOutput = do
   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

src/System/Hapistrano/Types.hs

@@ -3,7 +3,7 @@
 -- Copyright   :  © 2015-Present Stack Builders
 -- License     :  MIT
 --
--- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com>
+-- Maintainer  :  Cristhian Motoche <cmotoche@stackbuilders.com>
 -- Stability   :  experimental
 -- Portability :  portable
 --
@@ -22,7 +22,10 @@ module System.Hapistrano.Types
   , OutputDest(..)
   , Release
   , TargetSystem(..)
+  , DeployState(..)
   , Shell(..)
+  , Opts(..)
+  , Command(..)
   -- * Types helpers
   , mkRelease
   , releaseTime
@@ -43,7 +46,7 @@ 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 =
@@ -133,12 +136,41 @@ data Release =
   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