-- |
-- Module      :  System.Hapistrano
-- Copyright   :  © 2015-Present Stack Builders
-- License     :  MIT
--
-- Stability   :  experimental
-- Portability :  portable
--
-- A module for creating reliable deploy processes for Haskell applications.
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

module System.Hapistrano
  ( runHapistrano
  , pushRelease
  , pushReleaseWithoutVc
  , activateRelease
  , linkToShared
  , createHapistranoDeployState
  , rollback
  , dropOldReleases
  , playScript
  , playScriptLocally
    -- * Path helpers
  , releasePath
  , sharedPath
  , currentSymlinkPath
  , tempSymlinkPath
  , deployState )
where

import           Control.Monad
import           Control.Monad.Except
import           Control.Monad.Reader       (local, runReaderT)
import           Data.List                  (dropWhileEnd, genericDrop, sortOn)
import           Data.Maybe                 (fromMaybe, mapMaybe)
import           Data.Ord                   (Down (..))
import           Data.Time
import           Numeric.Natural
import           Path
import           System.Hapistrano.Commands
import           System.Hapistrano.Config   (deployStateFilename)
import           System.Hapistrano.Core
import           System.Hapistrano.Types
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 :: Maybe SshOptions
-> Shell
-> (OutputDest -> String -> IO ())
-> Hapistrano a
-> m (Either Int a)
runHapistrano Maybe SshOptions
sshOptions Shell
shell' OutputDest -> String -> IO ()
printFnc Hapistrano a
m =
  IO (Either Int a) -> m (Either Int a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Int a) -> m (Either Int a))
-> IO (Either Int a) -> m (Either Int a)
forall a b. (a -> b) -> a -> b
$ do
    let config :: Config
config =
          Config :: Maybe SshOptions
-> Shell -> (OutputDest -> String -> IO ()) -> Config
Config
            { configSshOptions :: Maybe SshOptions
configSshOptions = Maybe SshOptions
sshOptions
            , configShellOptions :: Shell
configShellOptions = Shell
shell'
            , configPrint :: OutputDest -> String -> IO ()
configPrint = OutputDest -> String -> IO ()
printFnc
            }
    Either (Failure, Maybe Release) a
r <- ReaderT Config IO (Either (Failure, Maybe Release) a)
-> Config -> IO (Either (Failure, Maybe Release) a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Hapistrano a
-> ReaderT Config IO (Either (Failure, Maybe Release) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT Hapistrano a
m) Config
config
    case Either (Failure, Maybe Release) a
r of
      Left (Failure Int
n Maybe String
msg, Maybe Release
_) -> do
        Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
msg (OutputDest -> String -> IO ()
printFnc OutputDest
StderrDest)
        Either Int a -> IO (Either Int a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Either Int a
forall a b. a -> Either a b
Left Int
n)
      Right a
x -> Either Int a -> IO (Either Int a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either Int a
forall a b. b -> Either a b
Right a
x)

-- High-level functionality

-- | Perform basic setup for a project, making sure necessary directories
-- exist and pushing a new release directory with the SHA1 or branch
-- specified in the configuration. Return identifier of the pushed release.

pushRelease :: Task -> Hapistrano Release
pushRelease :: Task -> Hapistrano Release
pushRelease Task {Path Abs Dir
ReleaseFormat
Source
taskReleaseFormat :: Task -> ReleaseFormat
taskSource :: Task -> Source
taskDeployPath :: Task -> Path Abs Dir
taskReleaseFormat :: ReleaseFormat
taskSource :: Source
taskDeployPath :: Path Abs Dir
..} = do
  Path Abs Dir -> Hapistrano ()
setupDirs Path Abs Dir
taskDeployPath
  Source -> Hapistrano Release
pushReleaseForRepository Source
taskSource
  where
    -- When the configuration is set for a local directory, it will only create
    -- the release directory without any version control operations.
    pushReleaseForRepository :: Source -> Hapistrano Release
pushReleaseForRepository GitRepository {String
gitRepositoryRevision :: Source -> String
gitRepositoryURL :: Source -> String
gitRepositoryRevision :: String
gitRepositoryURL :: String
..} = do
      String -> Path Abs Dir -> Maybe Release -> Hapistrano ()
ensureCacheInPlace String
gitRepositoryURL Path Abs Dir
taskDeployPath Maybe Release
forall a. Maybe a
Nothing
      Release
release <- ReleaseFormat -> Hapistrano Release
newRelease ReleaseFormat
taskReleaseFormat
      Path Abs Dir -> Release -> Hapistrano ()
cloneToRelease Path Abs Dir
taskDeployPath Release
release
      Path Abs Dir -> Release -> String -> Hapistrano ()
setReleaseRevision Path Abs Dir
taskDeployPath Release
release String
gitRepositoryRevision
      Release -> Hapistrano Release
forall (m :: * -> *) a. Monad m => a -> m a
return Release
release
    pushReleaseForRepository LocalDirectory {} =
      ReleaseFormat -> Hapistrano Release
newRelease ReleaseFormat
taskReleaseFormat

-- | Same as 'pushRelease' but doesn't perform any version control
-- related operations.

pushReleaseWithoutVc :: Task -> Hapistrano Release
pushReleaseWithoutVc :: Task -> Hapistrano Release
pushReleaseWithoutVc Task {Path Abs Dir
ReleaseFormat
Source
taskReleaseFormat :: ReleaseFormat
taskSource :: Source
taskDeployPath :: Path Abs Dir
taskReleaseFormat :: Task -> ReleaseFormat
taskSource :: Task -> Source
taskDeployPath :: Task -> Path Abs Dir
..} = do
  Path Abs Dir -> Hapistrano ()
setupDirs Path Abs Dir
taskDeployPath
  ReleaseFormat -> Hapistrano Release
newRelease ReleaseFormat
taskReleaseFormat

-- | Switch the current symlink to point to the specified release. May be
-- used in deploy or rollback cases.

activateRelease
  :: TargetSystem
  -> Path Abs Dir      -- ^ Deploy path
  -> Release           -- ^ Release identifier to activate
  -> Hapistrano ()
activateRelease :: TargetSystem -> Path Abs Dir -> Release -> Hapistrano ()
activateRelease TargetSystem
ts Path Abs Dir
deployPath Release
release = do
  Path Abs Dir
rpath <- Path Abs Dir
-> Release -> Maybe (Path Rel Dir) -> Hapistrano (Path Abs Dir)
releasePath Path Abs Dir
deployPath Release
release Maybe (Path Rel Dir)
forall a. Maybe a
Nothing
  let tpath :: Path Abs File
tpath = Path Abs Dir -> Path Abs File
tempSymlinkPath Path Abs Dir
deployPath
      cpath :: Path Abs File
cpath = Path Abs Dir -> Path Abs File
currentSymlinkPath Path Abs Dir
deployPath
  Ln -> Maybe Release -> Hapistrano (Result Ln)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (TargetSystem -> Path Abs Dir -> Path Abs File -> Ln
forall t. TargetSystem -> Path Abs t -> Path Abs File -> Ln
Ln TargetSystem
ts Path Abs Dir
rpath Path Abs File
tpath) (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
release) -- create a symlink for the new candidate
  Mv File -> Maybe Release -> Hapistrano (Result (Mv File))
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (TargetSystem -> Path Abs File -> Path Abs File -> Mv File
forall t. TargetSystem -> Path Abs t -> Path Abs t -> Mv t
Mv TargetSystem
ts Path Abs File
tpath Path Abs File
cpath) (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
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 :: Path Abs Dir -> Release -> DeployState -> Hapistrano ()
createHapistranoDeployState Path Abs Dir
deployPath Release
release DeployState
state = do
  Path Rel File
parseStatePath <- String
-> ExceptT
     (Failure, Maybe Release) (ReaderT Config IO) (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
deployStateFilename
  Path Abs Dir
actualReleasePath <- Path Abs Dir
-> Release -> Maybe (Path Rel Dir) -> Hapistrano (Path Abs Dir)
releasePath Path Abs Dir
deployPath Release
release Maybe (Path Rel Dir)
forall a. Maybe a
Nothing
  let stateFilePath :: Path Abs File
stateFilePath = Path Abs Dir
actualReleasePath Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
parseStatePath
  Touch -> Maybe Release -> Hapistrano (Result Touch)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Path Abs File -> Touch
Touch Path Abs File
stateFilePath) (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
release) -- creates '.hapistrano_deploy_state'
  BasicWrite -> Maybe Release -> Hapistrano (Result BasicWrite)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Path Abs File -> String -> BasicWrite
BasicWrite Path Abs File
stateFilePath (String -> BasicWrite) -> String -> BasicWrite
forall a b. (a -> b) -> a -> b
$ DeployState -> String
forall a. Show a => a -> String
show DeployState
state) (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
release) -- writes the deploy state to '.hapistrano_deploy_state'

-- | Activates one of already deployed releases.

rollback
  :: TargetSystem
  -> Path Abs Dir      -- ^ Deploy path
  -> Natural           -- ^ How many releases back to go, 0 re-activates current
  -> Hapistrano ()
rollback :: TargetSystem -> Path Abs Dir -> Natural -> Hapistrano ()
rollback TargetSystem
ts Path Abs Dir
deployPath Natural
n = do
  [Release]
releases <- DeployState -> Path Abs Dir -> Hapistrano [Release]
releasesWithState DeployState
Success Path Abs Dir
deployPath
  case Natural -> [Release] -> [Release]
forall i a. Integral i => i -> [a] -> [a]
genericDrop Natural
n [Release]
releases of
    [] -> Int -> Maybe String -> Maybe Release -> Hapistrano ()
forall a. Int -> Maybe String -> Maybe Release -> Hapistrano a
failWith Int
1 (String -> Maybe String
forall a. a -> Maybe a
Just String
"Could not find the requested release to rollback to.") Maybe Release
forall a. Maybe a
Nothing
    (Release
x:[Release]
_) -> TargetSystem -> Path Abs Dir -> Release -> Hapistrano ()
activateRelease TargetSystem
ts Path Abs Dir
deployPath Release
x

-- | Remove older releases to avoid filling up the target host filesystem.

dropOldReleases
  :: Path Abs Dir      -- ^ Deploy path
  -> Natural           -- ^ How many releases to keep
  -> Bool              -- ^ Whether the @--keep-one-failed@ flag is present or not
  -> Hapistrano ()
dropOldReleases :: Path Abs Dir -> Natural -> Bool -> Hapistrano ()
dropOldReleases Path Abs Dir
deployPath Natural
n Bool
keepOneFailed = do
  [Release]
failedReleases <- DeployState -> Path Abs Dir -> Hapistrano [Release]
releasesWithState DeployState
Fail Path Abs Dir
deployPath
  Bool -> Hapistrano () -> Hapistrano ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
keepOneFailed Bool -> Bool -> Bool
&& [Release] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Release]
failedReleases Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Hapistrano () -> Hapistrano ()) -> Hapistrano () -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$
    -- Remove every failed release except the most recent one
    [Release] -> (Release -> Hapistrano ()) -> Hapistrano ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Release] -> [Release]
forall a. [a] -> [a]
tail [Release]
failedReleases) ((Release -> Hapistrano ()) -> Hapistrano ())
-> (Release -> Hapistrano ()) -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$ \Release
release -> do
      Path Abs Dir
rpath <- Path Abs Dir
-> Release -> Maybe (Path Rel Dir) -> Hapistrano (Path Abs Dir)
releasePath Path Abs Dir
deployPath Release
release Maybe (Path Rel Dir)
forall a. Maybe a
Nothing
      Rm -> Maybe Release -> Hapistrano (Result Rm)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Path Abs Dir -> Rm
forall t. Path Abs t -> Rm
Rm Path Abs Dir
rpath) Maybe Release
forall a. Maybe a
Nothing
  [Release]
dreleases <- Path Abs Dir -> Hapistrano [Release]
deployedReleases Path Abs Dir
deployPath
  [Release] -> (Release -> Hapistrano ()) -> Hapistrano ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Natural -> [Release] -> [Release]
forall i a. Integral i => i -> [a] -> [a]
genericDrop Natural
n [Release]
dreleases) ((Release -> Hapistrano ()) -> Hapistrano ())
-> (Release -> Hapistrano ()) -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$ \Release
release -> do
    Path Abs Dir
rpath <- Path Abs Dir
-> Release -> Maybe (Path Rel Dir) -> Hapistrano (Path Abs Dir)
releasePath Path Abs Dir
deployPath Release
release Maybe (Path Rel Dir)
forall a. Maybe a
Nothing
    Rm -> Maybe Release -> Hapistrano (Result Rm)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Path Abs Dir -> Rm
forall t. Path Abs t -> Rm
Rm Path Abs Dir
rpath) Maybe Release
forall a. Maybe a
Nothing

-- | Play the given script switching to directory of given release.

playScript
  :: Path Abs Dir         -- ^ Deploy path
  -> Release              -- ^ Release identifier
  -> Maybe (Path Rel Dir) -- ^ Working directory
  -> [GenericCommand]     -- ^ Commands to execute
  -> Hapistrano ()
playScript :: Path Abs Dir
-> Release
-> Maybe (Path Rel Dir)
-> [GenericCommand]
-> Hapistrano ()
playScript Path Abs Dir
deployDir Release
release Maybe (Path Rel Dir)
mWorkingDir [GenericCommand]
cmds = do
  Path Abs Dir
rpath <- Path Abs Dir
-> Release -> Maybe (Path Rel Dir) -> Hapistrano (Path Abs Dir)
releasePath Path Abs Dir
deployDir Release
release Maybe (Path Rel Dir)
mWorkingDir
  [GenericCommand]
-> (GenericCommand -> Hapistrano ()) -> Hapistrano ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GenericCommand]
cmds ((Cd GenericCommand -> Maybe Release -> Hapistrano ())
-> Maybe Release -> Cd GenericCommand -> Hapistrano ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Cd GenericCommand -> Maybe Release -> Hapistrano ()
forall a. Command a => a -> Maybe Release -> Hapistrano ()
execWithInheritStdout (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
release) (Cd GenericCommand -> Hapistrano ())
-> (GenericCommand -> Cd GenericCommand)
-> GenericCommand
-> Hapistrano ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> GenericCommand -> Cd GenericCommand
forall cmd. Path Abs Dir -> cmd -> Cd cmd
Cd Path Abs Dir
rpath)

-- | Plays the given script on your machine locally.

playScriptLocally :: [GenericCommand] ->  Hapistrano ()
playScriptLocally :: [GenericCommand] -> Hapistrano ()
playScriptLocally [GenericCommand]
cmds =
  (Config -> Config) -> Hapistrano () -> Hapistrano ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
    (\Config
c ->
        Config
c
        { configSshOptions :: Maybe SshOptions
configSshOptions = Maybe SshOptions
forall a. Maybe a
Nothing
        }) (Hapistrano () -> Hapistrano ()) -> Hapistrano () -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$
  [GenericCommand]
-> (GenericCommand -> Hapistrano ()) -> Hapistrano ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GenericCommand]
cmds ((GenericCommand -> Hapistrano ()) -> Hapistrano ())
-> (GenericCommand -> Hapistrano ()) -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$ (GenericCommand -> Maybe Release -> Hapistrano ())
-> Maybe Release -> GenericCommand -> Hapistrano ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip GenericCommand -> Maybe Release -> Hapistrano ()
forall a. Command a => a -> Maybe Release -> Hapistrano ()
execWithInheritStdout Maybe Release
forall a. Maybe a
Nothing

----------------------------------------------------------------------------
-- Helpers

-- | Ensure that necessary directories exist. Idempotent.

setupDirs
  :: Path Abs Dir      -- ^ Deploy path
  -> Hapistrano ()
setupDirs :: Path Abs Dir -> Hapistrano ()
setupDirs Path Abs Dir
deployPath = do
  ((MkDir -> Maybe Release -> Hapistrano ())
-> Maybe Release -> MkDir -> Hapistrano ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip MkDir -> Maybe Release -> Hapistrano ()
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec Maybe Release
forall a. Maybe a
Nothing (MkDir -> Hapistrano ())
-> (Path Abs Dir -> MkDir) -> Path Abs Dir -> Hapistrano ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> MkDir
MkDir (Path Abs Dir -> MkDir)
-> (Path Abs Dir -> Path Abs Dir) -> Path Abs Dir -> MkDir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Abs Dir
releasesPath)  Path Abs Dir
deployPath
  ((MkDir -> Maybe Release -> Hapistrano ())
-> Maybe Release -> MkDir -> Hapistrano ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip MkDir -> Maybe Release -> Hapistrano ()
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec Maybe Release
forall a. Maybe a
Nothing (MkDir -> Hapistrano ())
-> (Path Abs Dir -> MkDir) -> Path Abs Dir -> Hapistrano ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> MkDir
MkDir (Path Abs Dir -> MkDir)
-> (Path Abs Dir -> Path Abs Dir) -> Path Abs Dir -> MkDir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Abs Dir
cacheRepoPath) Path Abs Dir
deployPath
  ((MkDir -> Maybe Release -> Hapistrano ())
-> Maybe Release -> MkDir -> Hapistrano ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip MkDir -> Maybe Release -> Hapistrano ()
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec Maybe Release
forall a. Maybe a
Nothing (MkDir -> Hapistrano ())
-> (Path Abs Dir -> MkDir) -> Path Abs Dir -> Hapistrano ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> MkDir
MkDir (Path Abs Dir -> MkDir)
-> (Path Abs Dir -> Path Abs Dir) -> Path Abs Dir -> MkDir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Abs Dir
sharedPath)    Path Abs Dir
deployPath

-- | Ensure that the specified repo is cloned and checked out on the given
-- revision. Idempotent.

ensureCacheInPlace
  :: String            -- ^ Repo URL
  -> Path Abs Dir      -- ^ Deploy path
  -> Maybe Release     -- ^ Release that was being attempted, if it was defined
  -> Hapistrano ()
ensureCacheInPlace :: String -> Path Abs Dir -> Maybe Release -> Hapistrano ()
ensureCacheInPlace String
repo Path Abs Dir
deployPath Maybe Release
maybeRelease = do
  let cpath :: Path Abs Dir
cpath = Path Abs Dir -> Path Abs Dir
cacheRepoPath Path Abs Dir
deployPath
      refs :: Path Abs Dir
refs  = Path Abs Dir
cpath Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelDir "refs")
  Bool
exists <- (Ls -> Maybe Release -> Hapistrano (Result Ls)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Path Abs Dir -> Ls
Ls Path Abs Dir
refs) Maybe Release
forall a. Maybe a
Nothing Hapistrano ()
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
    ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
-> ((Failure, Maybe Release)
    -> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool)
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
-> (Failure, Maybe Release)
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
forall a b. a -> b -> a
const (Bool -> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
  Bool -> Hapistrano () -> Hapistrano ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (Hapistrano () -> Hapistrano ()) -> Hapistrano () -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$
    GitClone -> Maybe Release -> Hapistrano (Result GitClone)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Bool -> Either String (Path Abs Dir) -> Path Abs Dir -> GitClone
GitClone Bool
True (String -> Either String (Path Abs Dir)
forall a b. a -> Either a b
Left String
repo) Path Abs Dir
cpath) Maybe Release
maybeRelease
  Cd GitFetch -> Maybe Release -> Hapistrano (Result (Cd GitFetch))
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Path Abs Dir -> GitFetch -> Cd GitFetch
forall cmd. Path Abs Dir -> cmd -> Cd cmd
Cd Path Abs Dir
cpath (String -> GitFetch
GitFetch String
"origin")) Maybe Release
maybeRelease -- TODO store this in task description?

-- | Create a new release identifier based on current timestamp.

newRelease :: ReleaseFormat -> Hapistrano Release
newRelease :: ReleaseFormat -> Hapistrano Release
newRelease ReleaseFormat
releaseFormat =
  ReleaseFormat -> UTCTime -> Release
mkRelease ReleaseFormat
releaseFormat (UTCTime -> Release)
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) UTCTime
-> Hapistrano Release
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

-- | Clone the repository to create the specified 'Release'.

cloneToRelease
  :: Path Abs Dir      -- ^ Deploy path
  -> Release           -- ^ 'Release' to create
  -> Hapistrano ()
cloneToRelease :: Path Abs Dir -> Release -> Hapistrano ()
cloneToRelease Path Abs Dir
deployPath Release
release = do
  Path Abs Dir
rpath <- Path Abs Dir
-> Release -> Maybe (Path Rel Dir) -> Hapistrano (Path Abs Dir)
releasePath Path Abs Dir
deployPath Release
release Maybe (Path Rel Dir)
forall a. Maybe a
Nothing
  let cpath :: Path Abs Dir
cpath = Path Abs Dir -> Path Abs Dir
cacheRepoPath Path Abs Dir
deployPath
  GitClone -> Maybe Release -> Hapistrano (Result GitClone)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Bool -> Either String (Path Abs Dir) -> Path Abs Dir -> GitClone
GitClone Bool
False (Path Abs Dir -> Either String (Path Abs Dir)
forall a b. b -> Either a b
Right Path Abs Dir
cpath) Path Abs Dir
rpath) (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
release)

-- | Set the release to the correct revision by checking out a branch or
-- a commit.

setReleaseRevision
  :: Path Abs Dir      -- ^ Deploy path
  -> Release           -- ^ 'Release' to checkout
  -> String            -- ^ Revision to checkout
  -> Hapistrano ()
setReleaseRevision :: Path Abs Dir -> Release -> String -> Hapistrano ()
setReleaseRevision Path Abs Dir
deployPath Release
release String
revision = do
  Path Abs Dir
rpath <- Path Abs Dir
-> Release -> Maybe (Path Rel Dir) -> Hapistrano (Path Abs Dir)
releasePath Path Abs Dir
deployPath Release
release Maybe (Path Rel Dir)
forall a. Maybe a
Nothing
  Cd GitCheckout
-> Maybe Release -> Hapistrano (Result (Cd GitCheckout))
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Path Abs Dir -> GitCheckout -> Cd GitCheckout
forall cmd. Path Abs Dir -> cmd -> Cd cmd
Cd Path Abs Dir
rpath (String -> GitCheckout
GitCheckout String
revision)) (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
release)

-- | Return a list of all currently deployed releases sorted newest first.

deployedReleases
  :: Path Abs Dir      -- ^ Deploy path
  -> Hapistrano [Release]
deployedReleases :: Path Abs Dir -> Hapistrano [Release]
deployedReleases Path Abs Dir
deployPath = do
  let rpath :: Path Abs Dir
rpath = Path Abs Dir -> Path Abs Dir
releasesPath Path Abs Dir
deployPath
  [Path Abs Dir]
xs <- Find Dir -> Maybe Release -> Hapistrano (Result (Find Dir))
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Natural -> Path Abs Dir -> Find Dir
forall t. Natural -> Path Abs Dir -> Find t
Find Natural
1 Path Abs Dir
rpath :: Find Dir) Maybe Release
forall a. Maybe a
Nothing
  [Path Rel Dir]
ps <- Path Abs Dir -> [Path Abs Dir] -> Hapistrano [Path Rel Dir]
forall t. Path Abs Dir -> [Path Abs t] -> Hapistrano [Path Rel t]
stripDirs Path Abs Dir
rpath ((Path Abs Dir -> Bool) -> [Path Abs Dir] -> [Path Abs Dir]
forall a. (a -> Bool) -> [a] -> [a]
filter (Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
/= Path Abs Dir
rpath) [Path Abs Dir]
xs)
  ([Release] -> Hapistrano [Release]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Release] -> Hapistrano [Release])
-> ([String] -> [Release]) -> [String] -> Hapistrano [Release]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Release -> Down Release) -> [Release] -> [Release]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Release -> Down Release
forall a. a -> Down a
Down ([Release] -> [Release])
-> ([String] -> [Release]) -> [String] -> [Release]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe Release) -> [String] -> [Release]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe Release
parseRelease)
    ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (String -> String)
-> (Path Rel Dir -> String) -> Path Rel Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel Dir -> String
fromRelDir (Path Rel Dir -> String) -> [Path Rel Dir] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path Rel Dir]
ps)

-- | Return a list of successfully completed releases sorted newest first.

releasesWithState
  :: DeployState       -- ^ Selector for failed or successful releases
  -> Path Abs Dir      -- ^ Deploy path
  -> Hapistrano [Release]
releasesWithState :: DeployState -> Path Abs Dir -> Hapistrano [Release]
releasesWithState DeployState
selectedState Path Abs Dir
deployPath = do
  [Release]
releases <- Path Abs Dir -> Hapistrano [Release]
deployedReleases Path Abs Dir
deployPath
  (Release
 -> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool)
-> [Release] -> Hapistrano [Release]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (
    (DeployState -> Bool)
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) DeployState
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((\Bool
bool -> if DeployState
selectedState DeployState -> DeployState -> Bool
forall a. Eq a => a -> a -> Bool
== DeployState
Success then Bool
bool else Bool -> Bool
not Bool
bool) (Bool -> Bool) -> (DeployState -> Bool) -> DeployState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeployState -> Bool
stateToBool)
     (ExceptT (Failure, Maybe Release) (ReaderT Config IO) DeployState
 -> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool)
-> (Release
    -> ExceptT
         (Failure, Maybe Release) (ReaderT Config IO) DeployState)
-> Release
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir
-> Maybe (Path Rel Dir)
-> Release
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) DeployState
deployState Path Abs Dir
deployPath Maybe (Path Rel Dir)
forall a. Maybe a
Nothing
    ) [Release]
releases
  where
    stateToBool :: DeployState -> Bool
    stateToBool :: DeployState -> Bool
stateToBool DeployState
Fail = Bool
False
    stateToBool DeployState
_    = Bool
True

----------------------------------------------------------------------------
-- Path helpers

-- | Return the full path to the directory containing all of the release
-- builds.

releasesPath
  :: Path Abs Dir      -- ^ Deploy path
  -> Path Abs Dir
releasesPath :: Path Abs Dir -> Path Abs Dir
releasesPath Path Abs Dir
deployPath = Path Abs Dir
deployPath Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelDir "releases")

-- | Return the full path to the directory containing the shared files/directories.

sharedPath
  :: Path Abs Dir      -- ^ Deploy path
  -> Path Abs Dir
sharedPath :: Path Abs Dir -> Path Abs Dir
sharedPath Path Abs Dir
deployPath = Path Abs Dir
deployPath Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelDir "shared")

-- | Link something (file or directory) from the {deploy_path}/shared/ directory
-- to a release

linkToShared
  :: TargetSystem -- ^ System to deploy
  -> 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 :: TargetSystem
-> Path Abs Dir
-> Path Abs Dir
-> String
-> Maybe Release
-> Hapistrano ()
linkToShared TargetSystem
configTargetSystem Path Abs Dir
rpath Path Abs Dir
configDeployPath String
thingToLink Maybe Release
maybeRelease = do
  Path Rel File
destPath <- String
-> ExceptT
     (Failure, Maybe Release) (ReaderT Config IO) (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
thingToLink
  let dpath :: Path Abs File
dpath = Path Abs Dir
rpath Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
destPath
      sharedPath' :: Path Abs File
sharedPath' = Path Abs Dir -> Path Abs Dir
sharedPath Path Abs Dir
configDeployPath Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
destPath
  Ln -> Maybe Release -> Hapistrano (Result Ln)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (TargetSystem -> Path Abs File -> Path Abs File -> Ln
forall t. TargetSystem -> Path Abs t -> Path Abs File -> Ln
Ln TargetSystem
configTargetSystem Path Abs File
sharedPath' Path Abs File
dpath) Maybe Release
maybeRelease

-- | Construct path to a particular 'Release'.

releasePath
  :: Path Abs Dir         -- ^ Deploy path
  -> Release              -- ^ 'Release' identifier
  -> Maybe (Path Rel Dir) -- ^ Working directory
  -> Hapistrano (Path Abs Dir)
releasePath :: Path Abs Dir
-> Release -> Maybe (Path Rel Dir) -> Hapistrano (Path Abs Dir)
releasePath Path Abs Dir
deployPath Release
release Maybe (Path Rel Dir)
mWorkingDir =
  let rendered :: String
rendered = Release -> String
renderRelease Release
release
  in case String -> Maybe (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
rendered of
    Maybe (Path Rel Dir)
Nothing    -> Int -> Maybe String -> Maybe Release -> Hapistrano (Path Abs Dir)
forall a. Int -> Maybe String -> Maybe Release -> Hapistrano a
failWith Int
1 (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Could not append path: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rendered) (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
release)
    Just Path Rel Dir
rpath ->
      Path Abs Dir -> Hapistrano (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir -> Hapistrano (Path Abs Dir))
-> Path Abs Dir -> Hapistrano (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ case Maybe (Path Rel Dir)
mWorkingDir of
        Maybe (Path Rel Dir)
Nothing         -> Path Abs Dir -> Path Abs Dir
releasesPath Path Abs Dir
deployPath Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
rpath
        Just Path Rel Dir
workingDir -> Path Abs Dir -> Path Abs Dir
releasesPath Path Abs Dir
deployPath Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
rpath Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
workingDir

-- | Return the full path to the git repo used for cache purposes on the
-- target host filesystem.

cacheRepoPath
  :: Path Abs Dir      -- ^ Deploy path
  -> Path Abs Dir
cacheRepoPath :: Path Abs Dir -> Path Abs Dir
cacheRepoPath Path Abs Dir
deployPath = Path Abs Dir
deployPath Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelDir "repo")

-- | Get full path to current symlink.

currentSymlinkPath
  :: Path Abs Dir      -- ^ Deploy path
  -> Path Abs File
currentSymlinkPath :: Path Abs Dir -> Path Abs File
currentSymlinkPath Path Abs Dir
deployPath = Path Abs Dir
deployPath Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelFile "current")

-- | Get full path to temp symlink.

tempSymlinkPath
  :: Path Abs Dir      -- ^ Deploy path
  -> Path Abs File
tempSymlinkPath :: Path Abs Dir -> Path Abs File
tempSymlinkPath Path Abs Dir
deployPath = Path Abs Dir
deployPath Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelFile "current_tmp")

-- | 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'.

deployState
  :: Path Abs Dir -- ^ Deploy path
  -> Maybe (Path Rel Dir) -- ^ Working directory
  -> Release -- ^ 'Release' identifier
  -> Hapistrano DeployState -- ^ Whether the release was deployed successfully or not
deployState :: Path Abs Dir
-> Maybe (Path Rel Dir)
-> Release
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) DeployState
deployState Path Abs Dir
deployPath Maybe (Path Rel Dir)
mWorkingDir Release
release = do
  Path Rel File
parseStatePath <- String
-> ExceptT
     (Failure, Maybe Release) (ReaderT Config IO) (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
deployStateFilename
  Path Abs Dir
actualReleasePath <- Path Abs Dir
-> Release -> Maybe (Path Rel Dir) -> Hapistrano (Path Abs Dir)
releasePath Path Abs Dir
deployPath Release
release Maybe (Path Rel Dir)
mWorkingDir
  let stateFilePath :: Path Abs File
stateFilePath = Path Abs Dir
actualReleasePath Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
parseStatePath
  Bool
doesExist <- CheckExists -> Maybe Release -> Hapistrano (Result CheckExists)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Path Abs File -> CheckExists
CheckExists Path Abs File
stateFilePath) (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
release)
  if Bool
doesExist then do
    String
deployStateContents <- Cat -> Maybe Release -> Hapistrano (Result Cat)
forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec (Path Abs File -> Cat
Cat Path Abs File
stateFilePath) (Release -> Maybe Release
forall a. a -> Maybe a
Just Release
release)
    DeployState
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) DeployState
forall (m :: * -> *) a. Monad m => a -> m a
return (DeployState
 -> ExceptT
      (Failure, Maybe Release) (ReaderT Config IO) DeployState)
-> DeployState
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) DeployState
forall a b. (a -> b) -> a -> b
$ (DeployState -> Maybe DeployState -> DeployState
forall a. a -> Maybe a -> a
fromMaybe DeployState
Unknown (Maybe DeployState -> DeployState)
-> (String -> Maybe DeployState) -> String -> DeployState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe DeployState
forall a. Read a => String -> Maybe a
readMaybe) String
deployStateContents
  else DeployState
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) DeployState
forall (m :: * -> *) a. Monad m => a -> m a
return DeployState
Unknown

stripDirs :: Path Abs Dir -> [Path Abs t] -> Hapistrano [Path Rel t]
stripDirs :: Path Abs Dir -> [Path Abs t] -> Hapistrano [Path Rel t]
stripDirs Path Abs Dir
path =
#if MIN_VERSION_path(0,6,0)
  (Path Abs t
 -> ExceptT
      (Failure, Maybe Release) (ReaderT Config IO) (Path Rel t))
-> [Path Abs t] -> Hapistrano [Path Rel t]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Path Abs Dir
-> Path Abs t
-> ExceptT
     (Failure, Maybe Release) (ReaderT Config IO) (Path Rel t)
forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
path)
#else
  mapM (stripDir path)
#endif