Define Hapistrano with Deriving Via strategy (#204)

* Use deriving strategies

* Add missing type classes to derive from

* Remove duplicated runHapistrano

* Only derive from ReaderT

* Replace catch/throw

app/Main.hs

@@ -1,7 +1,7 @@
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE CPP               #-}
 
 module Main (main) where
 
@@ -9,26 +9,26 @@ import           Control.Concurrent.Async
 import           Control.Concurrent.STM
 import           Control.Monad
 #if !MIN_VERSION_base(4,13,0)
-import           Data.Monoid                ((<>))
+import           Data.Monoid                   ((<>))
 #endif
-import           Data.Version               (showVersion)
-import qualified Data.Yaml.Config           as Yaml
+import           Control.Monad.Catch           (catch, throwM)
+import           Data.Version                  (showVersion)
+import qualified Data.Yaml.Config              as Yaml
 import           Development.GitRev
-import           Formatting                 (formatToString, string, (%))
-import           Options.Applicative        hiding (str)
+import           Formatting                    (formatToString, string, (%))
+import           Options.Applicative           hiding (str)
 import           Path
 import           Path.IO
-import           Paths_hapistrano           (version)
+import           Paths_hapistrano              (version)
 import           System.Exit
-import qualified System.Hapistrano          as Hap
-import qualified System.Hapistrano.Commands as Hap
-import qualified System.Hapistrano.Config   as C
-import qualified System.Hapistrano.Core     as Hap
+import           System.Hapistrano             (createHapistranoDeployState)
+import qualified System.Hapistrano             as Hap
+import qualified System.Hapistrano.Commands    as Hap
+import qualified System.Hapistrano.Config      as C
+import qualified System.Hapistrano.Core        as Hap
 import qualified System.Hapistrano.Maintenance as Hap
 import           System.Hapistrano.Types
 import           System.IO
-import           System.Hapistrano (createHapistranoDeployState)
-import           Control.Monad.Error.Class (throwError, catchError)
 
 ----------------------------------------------------------------------------
 
@@ -142,14 +142,14 @@ main = do
                   keepReleases = fromMaybeKeepReleases cliKeepReleases configKeepReleases
                   keepOneFailed = cliKeepOneFailed || configKeepOneFailed
                   -- We define the handler for when an exception happens inside a deployment
-                  failStateAndThrow e@(_, maybeRelease) = do
+                  failStateAndThrow e@(HapistranoException (_, maybeRelease)) = do
                     case maybeRelease of
                       (Just release) -> do
                         createHapistranoDeployState configDeployPath release Fail
                         Hap.dropOldReleases configDeployPath keepReleases keepOneFailed
-                        throwError e
+                        throwM e
                       Nothing -> do
-                        throwError e
+                        throwM e
               in do
                 forM_ configRunLocally Hap.playScriptLocally
                 release <- if configVcAction
@@ -179,7 +179,7 @@ main = do
                 forM_ configRestartCommand (flip Hap.exec $ Just release)
                 Hap.createHapistranoDeployState configDeployPath release System.Hapistrano.Types.Success
                 Hap.dropOldReleases configDeployPath keepReleases keepOneFailed
-              `catchError` failStateAndThrow
+              `catch` failStateAndThrow
             Rollback n -> do
               Hap.rollback configTargetSystem configDeployPath n
               forM_ configRestartCommand (flip Hap.exec Nothing)

hapistrano.cabal

@@ -63,6 +63,7 @@ library
                      , typed-process      >= 0.2 && < 0.3
                      , time               >= 1.5 && < 1.11
                      , transformers       >= 0.4 && < 0.6
+                     , exceptions         >= 0.10 && < 0.11
                      , yaml               >= 0.11.7 && < 0.12
   if flag(dev)
     ghc-options:       -Wall -Werror
@@ -77,6 +78,7 @@ executable hap
   build-depends:       aeson              >= 2.0 && < 3.0
                      , async              >= 2.0.1.6 && < 2.4
                      , base               >= 4.9 && < 5.0
+                     , exceptions
                      , formatting         >= 6.2 && < 8.0
                      , gitrev             >= 1.2 && < 1.4
                      , hapistrano

spec/System/HapistranoSpec.hs

@@ -1,38 +1,40 @@
-{-# LANGUAGE CPP             #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 module System.HapistranoSpec
   ( spec
   ) where
 
-import Control.Monad
-import Control.Monad.Reader
-import Data.List (isPrefixOf)
-import Data.Maybe (mapMaybe)
-import Numeric.Natural
-import Path
+import           Control.Monad
+import           Control.Monad.Reader
+import           Data.List                     (isPrefixOf)
+import           Data.Maybe                    (mapMaybe)
+import           Numeric.Natural
+import           Path
 
 
 
 
-import Path.IO
-import System.Directory
-    ( doesFileExist, getCurrentDirectory, listDirectory )
-import qualified System.Hapistrano as Hap
-import qualified System.Hapistrano.Commands as Hap
-import qualified System.Hapistrano.Core as Hap
-import System.Hapistrano.Types
-import System.IO
-import System.IO.Silently (capture_)
-import System.Info (os)
-import Test.Hspec hiding (shouldBe, shouldContain, shouldReturn)
-import qualified Test.Hspec as Hspec
-import Test.Hspec.QuickCheck
-import Test.QuickCheck hiding (Success)
-import System.Hapistrano (releasePath)
-import System.Hapistrano.Config (deployStateFilename)
-import System.Hapistrano.Maintenance
+import           Path.IO
+import           System.Directory              (doesFileExist,
+                                                getCurrentDirectory,
+                                                listDirectory)
+import           System.Hapistrano             (releasePath)
+import qualified System.Hapistrano             as Hap
+import qualified System.Hapistrano.Commands    as Hap
+import           System.Hapistrano.Config      (deployStateFilename)
+import qualified System.Hapistrano.Core        as Hap
+import           System.Hapistrano.Maintenance
+import           System.Hapistrano.Types
+import           System.Info                   (os)
+import           System.IO
+import           System.IO.Silently            (capture_)
+import           Test.Hspec                    hiding (shouldBe, shouldContain,
+                                                shouldReturn)
+import qualified Test.Hspec                    as Hspec
+import           Test.Hspec.QuickCheck
+import           Test.QuickCheck               hiding (Success)
 
 testBranchName :: String
 testBranchName = "another_branch"
@@ -175,9 +177,8 @@ spec = do
         -- This fails if there are unstaged changes
           justExec rpath "git diff --exit-code"
       it "updates the origin url when it's changed" $ \(deployPath, repoPath) ->
-        runHap $ do
-          let tempDirPrefix = "hap-test-repotwo"
-          withSystemTempDir tempDirPrefix $ \repoPathTwo -> do
+         withSystemTempDir "hap-test-repotwo" $ \repoPathTwo -> do
+          runHap $ do
             let task1 = mkTask deployPath repoPath
                 task2 = mkTask deployPath repoPathTwo
                 repoConfigFile = deployPath </> $(mkRelDir "repo") </> $(mkRelFile "config")
@@ -185,8 +186,9 @@ spec = do
             void $ Hap.pushRelease task1
             void $ Hap.pushRelease task2
 
-            repoFile <- (liftIO . readFile . fromAbsFile) repoConfigFile 
-            repoFile `shouldContain` tempDirPrefix
+            repoFile <- (liftIO . readFile . fromAbsFile) repoConfigFile
+            repoFile `shouldContain` "hap-test-repotwo"
+
     describe "createHapistranoDeployState" $ do
       it ("creates the " <> deployStateFilename <> " file correctly") $ \(deployPath, repoPath) ->
         runHap $ do

src/System/Hapistrano.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
 
 module System.Hapistrano
   ( runHapistrano
@@ -32,9 +33,11 @@ module System.Hapistrano
   , deployState )
 where
 
+import           Control.Exception          (try)
 import           Control.Monad
+import           Control.Monad.Catch        (catch)
 import           Control.Monad.Except
-import           Control.Monad.Reader       (local, runReaderT)
+import           Control.Monad.Reader       (local)
 import           Data.List                  (dropWhileEnd, genericDrop, sortOn)
 import           Data.Maybe                 (fromMaybe, mapMaybe)
 import           Data.Ord                   (Down (..))
@@ -66,9 +69,9 @@ runHapistrano sshOptions shell' printFnc m =
             , configShellOptions = shell'
             , configPrint = printFnc
             }
-    r <- runReaderT (runExceptT m) config
+    r <- try @HapistranoException $ unHapistrano m config
     case r of
-      Left (Failure n msg, _) -> do
+      Left (HapistranoException (Failure n msg, _)) -> do
         forM_ msg (printFnc StderrDest)
         return (Left n)
       Right x -> return (Right x)
@@ -213,7 +216,7 @@ ensureCacheInPlace repo deployPath maybeRelease = do
   let cpath = cacheRepoPath deployPath
       refs  = cpath </> $(mkRelDir "refs")
   exists <- (exec (Ls refs) Nothing >> return True)
-    `catchError` const (return False)
+    `catch` (\(_ :: HapistranoException)  -> return False)
   unless exists $
     exec (GitClone True (Left repo) cpath) maybeRelease
   exec (Cd cpath (GitSetOrigin repo)) maybeRelease

src/System/Hapistrano/Core.hs

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

src/System/Hapistrano/Types.hs

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