stackbuilders/hapistrano
1
1
Fork 0
mirror of https://github.com/stackbuilders/hapistrano.git synced 2024-11-29 09:57:02 +03:00
Code Issues Projects Releases Wiki Activity

When deploying a release, now it gets tagged with fail or success

Browse Source
This commit is contained in:
DavidMazarro 2022-01-24 20:25:58 +01:00
parent d85a2598ee
commit d5a180dca3
No known key found for this signature in database
GPG Key ID: 5B490A04990FAAB7
5 changed files with 91 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
app/Main.hs
View File

@ -113,7 +113,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
@ -122,7 +122,7 @@ main = do
let printFnc dest str = atomically $
writeTChan chan (PrintMsg dest str)
hap shell sshOpts = do
r <- Hap.runHapistrano sshOpts shell printFnc Opts{..} C.Config{..} $
r <- Hap.runHapistrano sshOpts shell printFnc C.Config{..} $
case optsCommand of
Deploy cliReleaseFormat cliKeepReleases cliKeepOneFailed -> do
let releaseFormat = fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat
@ -134,32 +134,32 @@ main = do
else Hap.pushReleaseWithoutVc (task releaseFormat)
rpath <- Hap.releasePath configDeployPath release configWorkingDir
forM_ (toMaybePath configSource) $ \src ->
Hap.scpDir src rpath
Hap.scpDir src rpath (Just release)
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
(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
(Hap.exec . Hap.MkDir . parent) dpath
Hap.scpDir srcPath dpath
(flip Hap.exec (Just release) . Hap.MkDir . parent) dpath
Hap.scpDir srcPath dpath (Just release)
forM_ configLinkedFiles
(Hap.linkToShared configTargetSystem rpath configDeployPath)
$ flip (Hap.linkToShared configTargetSystem rpath configDeployPath) (Just release)
forM_ configLinkedDirs
(Hap.linkToShared configTargetSystem rpath configDeployPath)
$ flip (Hap.linkToShared configTargetSystem rpath configDeployPath) (Just release)
forM_ configBuildScript (Hap.playScript configDeployPath release configWorkingDir)
Hap.registerReleaseAsComplete configDeployPath release
Hap.activateRelease configTargetSystem configDeployPath release
Hap.dropOldReleases configDeployPath keepReleases
forM_ configRestartCommand Hap.exec
forM_ configRestartCommand (flip Hap.exec $ Just release)
Hap.createHapistranoDeployState configDeployPath release System.Hapistrano.Types.Success
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 ()

40
spec/System/HapistranoSpec.hs
View File

@ -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)
@ -28,6 +29,8 @@ import Test.Hspec hiding (shouldBe, shouldReturn)
import qualified Test.Hspec as Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Data.Yaml (decodeEither')
import Data.Either (fromRight)
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)
@ -172,7 +175,7 @@ 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
describe "playScriptLocally (successful run)" $
it "check that local scripts are run and deployment is successful" $ \(deployPath, repoPath) ->
@ -205,7 +208,7 @@ spec = do
let rc :: Hap.Readlink Dir
rc =
Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath)
Hap.exec rc `shouldReturn` rpath
Hap.exec rc Nothing `shouldReturn` rpath
doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False
context "with completion tokens" $
it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) ->
@ -214,11 +217,11 @@ spec = do
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
rpath <- Hap.releasePath deployPath (head rs) Nothing
let rc :: Hap.Readlink Dir
rc =
Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath)
Hap.exec rc `shouldReturn` rpath
Hap.exec rc Nothing `shouldReturn` rpath
doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False
describe "dropOldReleases" $
it "works" $ \(deployPath, repoPath) ->
@ -249,8 +252,8 @@ spec = do
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 repository" $
it "should throw an error" $ \(deployPath, repoPath) ->
@ -258,7 +261,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 +273,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 +283,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 +298,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 +309,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 +362,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')
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
@ -373,7 +376,8 @@ runHapWithShell shell m = do
case dest of
StdoutDest -> putStr str
StderrDest -> hPutStr stderr str
r <- Hap.runHapistrano Nothing shell printFnc m
let placeholderConfig = fromRight (error "unintended config while testing") $ decodeEither' "deploy_path: '/placeholder/'\nlocal_directory: '/placeholder/'"
r <- Hap.runHapistrano Nothing shell printFnc placeholderConfig m
case r of
Left n -> do
expectationFailure ("Failed with status code: " ++ show n)

79
src/System/Hapistrano.hs
View File

@ -56,12 +56,11 @@ runHapistrano ::
=> Maybe SshOptions -- ^ SSH options to use or 'Nothing' if we run locally
-> Shell -- ^ Shell to run commands
-> (OutputDest -> String -> IO ()) -- ^ How to print messages
-> Opts -- ^ CLI options
-> C.Config -- ^ Config file options
-> 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 Opts{..} C.Config{..} m =
runHapistrano sshOptions shell' printFnc C.Config{..} m =
liftIO $ do
let config =
Config
@ -71,23 +70,15 @@ runHapistrano sshOptions shell' printFnc Opts{..} C.Config{..} m =
}
r <- runReaderT (runExceptT $ m `catchError` failStateAndThrow) config
case r of
Left (Failure n msg) -> do
Left (Failure n msg, _) -> do
forM_ msg (printFnc StderrDest)
return (Left n)
Right x -> return (Right x)
where
failStateAndThrow e = do
let task rf = Task { taskDeployPath = configDeployPath
, taskSource = configSource
, taskReleaseFormat = rf }
case optsCommand of
Deploy cliReleaseFormat _ _ -> do
let releaseFormat = fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat
release <- if configVcAction
then pushRelease (task releaseFormat)
else pushReleaseWithoutVc (task releaseFormat)
createHapistranoDeployState configDeployPath release Fail >> throwError e
_ -> throwError e
failStateAndThrow e@(_, maybeRelease) =
case maybeRelease of
(Just release) -> createHapistranoDeployState configDeployPath release Fail >> throwError e
Nothing -> throwError e
-- High-level functionality
@ -103,7 +94,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
@ -128,7 +119,7 @@ registerReleaseAsComplete
-> Hapistrano ()
registerReleaseAsComplete deployPath release = do
cpath <- ctokenPath deployPath release
exec (Touch cpath)
exec (Touch cpath) (Just release)
-- | Switch the current symlink to point to the specified release. May be
-- used in deploy or rollback cases.
@ -142,8 +133,8 @@ 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 (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.
@ -157,8 +148,8 @@ createHapistranoDeployState deployPath release deployState = do
parseStatePath <- parseRelFile ".hapistrano_deploy_state"
actualReleasePath <- releasePath deployPath release Nothing
let stateFilePath = actualReleasePath </> parseStatePath
exec (Touch stateFilePath) -- creates '.hapistrano_deploy_state'
exec (BasicWrite stateFilePath $ show deployState) -- writes the deploy state to '.hapistrano_deploy_state'
exec (Touch stateFilePath) (Just release) -- creates '.hapistrano_deploy_state'
exec (BasicWrite stateFilePath $ show deployState) (Just release) -- writes the deploy state to '.hapistrano_deploy_state'
-- | Activates one of already deployed releases.
@ -175,7 +166,7 @@ rollback ts deployPath n = do
-- 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.")
[] -> 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.
@ -188,11 +179,11 @@ dropOldReleases deployPath n = do
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)
exec (Rm cpath) Nothing
-- | Play the given script switching to directory of given release.
@ -204,18 +195,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
@ -226,10 +217,10 @@ setupDirs
:: 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 . ctokensPath) deployPath
(flip exec Nothing . MkDir . sharedPath) deployPath
-- | Ensure that the specified repo is cloned and checked out on the given
-- revision. Idempotent.
@ -237,15 +228,16 @@ 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 (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 release identifier based on current timestamp.
@ -262,7 +254,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.
@ -274,7 +266,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.
@ -283,7 +275,7 @@ 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)
@ -295,7 +287,7 @@ completedReleases
-> Hapistrano [Release]
completedReleases deployPath = do
let cpath = ctokensPath deployPath
xs <- exec (Find 1 cpath :: Find File)
xs <- exec (Find 1 cpath :: Find File) Nothing
ps <- stripDirs cpath xs
(return . sortOn Down . mapMaybe parseRelease)
(dropWhileEnd (== '/') . fromRelFile <$> ps)
@ -326,12 +318,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'.
@ -343,7 +336,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
@ -387,7 +380,7 @@ ctokenPath
ctokenPath deployPath release = do
let rendered = renderRelease release
case parseRelFile 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 (ctokensPath deployPath </> rpath)
stripDirs :: Path Abs Dir -> [Path Abs t] -> Hapistrano [Path Rel t]

34
src/System/Hapistrano/Core.hs
View File

@ -37,8 +37,8 @@ import System.Process.Typed (ProcessConfig)
import qualified System.Process.Typed as SPT
-- | 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
@ -49,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 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
@ -95,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"]
@ -102,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' src dest extraArgs = do
scp' :: FilePath -> FilePath -> [String] -> Maybe Release -> Hapistrano ()
scp' src dest extraArgs maybeRelease = do
Config {..} <- ask
let prog = "scp"
portArg =
@ -119,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
@ -127,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)"
@ -146,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

2
src/System/Hapistrano/Types.hs
View File

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