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
This commit is contained in:
Cristhian Motoche 2022-09-08 09:34:24 -05:00 committed by GitHub
parent a1ccbe631e
commit 856f1037dd
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 82 additions and 54 deletions

View File

@ -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)

View File

@ -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

View File

@ -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")
@ -186,7 +187,8 @@ spec = do
void $ Hap.pushRelease task2
repoFile <- (liftIO . readFile . fromAbsFile) repoConfigFile
repoFile `shouldContain` tempDirPrefix
repoFile `shouldContain` "hap-test-repotwo"
describe "createHapistranoDeployState" $ do
it ("creates the " <> deployStateFilename <> " file correctly") $ \(deployPath, repoPath) ->
runHap $ do

View File

@ -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

View File

@ -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

View File

@ -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 =