-- |
-- Module      :  System.Hapistrano.Core
-- Copyright   :  © 2015-Present Stack Builders
-- License     :  MIT
--
-- Stability   :  experimental
-- Portability :  portable
--
-- Core Hapistrano functions that provide basis on which all the
-- functionality is built.
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

module System.Hapistrano.Core
  ( failWith
  , exec
  , execWithInheritStdout
  , scpFile
  , scpDir )
where

import           Control.Concurrent.STM     (atomically)
import           Control.Monad
import           Control.Monad.Except
import           Control.Monad.Reader
import           Data.Proxy
import           Data.Time
import           Path
import           System.Console.ANSI
import           System.Exit
import           System.Hapistrano.Commands
import           System.Hapistrano.Types    hiding (Command)
import           System.Process
import           System.Process.Typed       (ProcessConfig)
import qualified System.Process.Typed       as SPT

-- | Fail returning the following status code and message.
failWith :: Int -> Maybe String -> Maybe Release -> Hapistrano a
failWith :: Int -> Maybe String -> Maybe Release -> Hapistrano a
failWith Int
n Maybe String
msg Maybe Release
maybeRelease = (Failure, Maybe Release) -> Hapistrano a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Int -> Maybe String -> Failure
Failure Int
n Maybe String
msg, Maybe Release
maybeRelease)

-- | Run the given sequence of command. Whether to use SSH or not is
-- determined from settings contained in the 'Hapistrano' monad
-- configuration. Commands that return non-zero exit codes will result in
-- short-cutting of execution.
-- __NOTE:__ the commands executed with 'exec' will create their own pipe and
-- will stream output there and once the command finishes its execution it will
-- parse the result.
exec ::
     forall a. Command a
  => a -- ^ Command being executed
  -> Maybe Release -- ^ Release that was being attempted, if it was defined
  -> Hapistrano (Result a)
exec :: a -> Maybe Release -> Hapistrano (Result a)
exec a
typedCmd Maybe Release
maybeRelease = do
  let cmd :: String
cmd = a -> String
forall a. Command a => a -> String
renderCommand a
typedCmd
  (String
prog, [String]
args) <- String -> Hapistrano (String, [String])
getProgAndArgs String
cmd
  Proxy a -> String -> Result a
forall a. Command a => Proxy a -> String -> Result a
parseResult (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (String -> Result a)
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
-> Hapistrano (Result a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    String
-> IO (ExitCode, String, String)
-> Maybe Release
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
exec' String
cmd (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
prog [String]
args String
"") Maybe Release
maybeRelease

-- | Same as 'exec' but it streams to stdout only for _GenericCommand_s
execWithInheritStdout ::
     Command a
  => a -- ^ Command being executed
  -> Maybe Release -- ^ Release that was being attempted, if it was defined
  -> Hapistrano ()
execWithInheritStdout :: a -> Maybe Release -> Hapistrano ()
execWithInheritStdout a
typedCmd Maybe Release
maybeRelease = do
  let cmd :: String
cmd = a -> String
forall a. Command a => a -> String
renderCommand a
typedCmd
  (String
prog, [String]
args) <- String -> Hapistrano (String, [String])
getProgAndArgs String
cmd
  ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
-> Hapistrano ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
 -> Hapistrano ())
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
-> Hapistrano ()
forall a b. (a -> b) -> a -> b
$ String
-> IO (ExitCode, String, String)
-> Maybe Release
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
exec' String
cmd (ProcessConfig () () () -> IO (ExitCode, String, String)
forall stdin stdoutIgnored stderrIgnored.
ProcessConfig stdin stdoutIgnored stderrIgnored
-> IO (ExitCode, String, String)
readProcessWithExitCode' (String -> [String] -> ProcessConfig () () ()
SPT.proc String
prog [String]
args)) Maybe Release
maybeRelease
    where
    -- | Prepares a process, reads @stdout@ and @stderr@ and returns exit code
    -- NOTE: @strdout@ and @stderr@ are empty string because we're writing
    -- the output to the parent.
    readProcessWithExitCode' ::
         ProcessConfig stdin stdoutIgnored stderrIgnored
      -> IO (ExitCode, String, String)
    readProcessWithExitCode' :: ProcessConfig stdin stdoutIgnored stderrIgnored
-> IO (ExitCode, String, String)
readProcessWithExitCode' ProcessConfig stdin stdoutIgnored stderrIgnored
pc =
      ProcessConfig stdin () ()
-> (Process stdin () () -> IO (ExitCode, String, String))
-> IO (ExitCode, String, String)
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
SPT.withProcessTerm ProcessConfig stdin () ()
pc' ((Process stdin () () -> IO (ExitCode, String, String))
 -> IO (ExitCode, String, String))
-> (Process stdin () () -> IO (ExitCode, String, String))
-> IO (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ \Process stdin () ()
p ->
        STM (ExitCode, String, String) -> IO (ExitCode, String, String)
forall a. STM a -> IO a
atomically (STM (ExitCode, String, String) -> IO (ExitCode, String, String))
-> STM (ExitCode, String, String) -> IO (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ (,,) (ExitCode -> String -> String -> (ExitCode, String, String))
-> STM ExitCode
-> STM (String -> String -> (ExitCode, String, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Process stdin () () -> STM ExitCode
forall stdin stdout stderr.
Process stdin stdout stderr -> STM ExitCode
SPT.waitExitCodeSTM Process stdin () ()
p STM (String -> String -> (ExitCode, String, String))
-> STM String -> STM (String -> (ExitCode, String, String))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> STM String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"" STM (String -> (ExitCode, String, String))
-> STM String -> STM (ExitCode, String, String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> STM String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
      where
        pc' :: ProcessConfig stdin () ()
pc' = StreamSpec 'STOutput ()
-> ProcessConfig stdin stdoutIgnored ()
-> ProcessConfig stdin () ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
SPT.setStdout StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
SPT.inherit (ProcessConfig stdin stdoutIgnored () -> ProcessConfig stdin () ())
-> ProcessConfig stdin stdoutIgnored ()
-> ProcessConfig stdin () ()
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput ()
-> ProcessConfig stdin stdoutIgnored stderrIgnored
-> ProcessConfig stdin stdoutIgnored ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
SPT.setStderr StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
SPT.inherit ProcessConfig stdin stdoutIgnored stderrIgnored
pc

-- | Get program and args to run a command locally or remotely.
getProgAndArgs :: String -> Hapistrano (String, [String])
getProgAndArgs :: String -> Hapistrano (String, [String])
getProgAndArgs String
cmd = do
  Config {Maybe SshOptions
Shell
OutputDest -> String -> IO ()
configPrint :: Config -> OutputDest -> String -> IO ()
configShellOptions :: Config -> Shell
configSshOptions :: Config -> Maybe SshOptions
configPrint :: OutputDest -> String -> IO ()
configShellOptions :: Shell
configSshOptions :: Maybe SshOptions
..} <- ExceptT (Failure, Maybe Release) (ReaderT Config IO) Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  (String, [String]) -> Hapistrano (String, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, [String]) -> Hapistrano (String, [String]))
-> (String, [String]) -> Hapistrano (String, [String])
forall a b. (a -> b) -> a -> b
$
    case Maybe SshOptions
configSshOptions of
      Maybe SshOptions
Nothing -> (Shell -> String
renderShell Shell
configShellOptions, [String
"-c", String
cmd])
      Just SshOptions {String
[String]
Word
sshArgs :: SshOptions -> [String]
sshPort :: SshOptions -> Word
sshHost :: SshOptions -> String
sshArgs :: [String]
sshPort :: Word
sshHost :: String
..} ->
        (String
"ssh", [String]
sshArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
sshHost, String
"-p", Word -> String
forall a. Show a => a -> String
show Word
sshPort, String
cmd])
    where
      renderShell :: Shell -> String
      renderShell :: Shell -> String
renderShell Shell
Zsh  = String
"zsh"
      renderShell Shell
Bash = String
"bash"


-- | Copy a file from local path to target server.
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 :: Path Abs File -> Path Abs File -> Maybe Release -> Hapistrano ()
scpFile Path Abs File
src Path Abs File
dest = String -> String -> [String] -> Maybe Release -> Hapistrano ()
scp' (Path Abs File -> String
fromAbsFile Path Abs File
src) (Path Abs File -> String
fromAbsFile Path Abs File
dest) [String
"-q"]

-- | Copy a local directory recursively to target server.
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 :: Path Abs Dir -> Path Abs Dir -> Maybe Release -> Hapistrano ()
scpDir Path Abs Dir
src Path Abs Dir
dest = String -> String -> [String] -> Maybe Release -> Hapistrano ()
scp' (Path Abs Dir -> String
fromAbsDir Path Abs Dir
src) (Path Abs Dir -> String
fromAbsDir Path Abs Dir
dest) [String
"-qr"]

scp' :: FilePath -> FilePath -> [String] -> Maybe Release -> Hapistrano ()
scp' :: String -> String -> [String] -> Maybe Release -> Hapistrano ()
scp' String
src String
dest [String]
extraArgs Maybe Release
maybeRelease = do
  Config {Maybe SshOptions
Shell
OutputDest -> String -> IO ()
configPrint :: OutputDest -> String -> IO ()
configShellOptions :: Shell
configSshOptions :: Maybe SshOptions
configPrint :: Config -> OutputDest -> String -> IO ()
configShellOptions :: Config -> Shell
configSshOptions :: Config -> Maybe SshOptions
..} <- ExceptT (Failure, Maybe Release) (ReaderT Config IO) Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  let prog :: String
prog = String
"scp"
      portArg :: [String]
portArg =
        case SshOptions -> Word
sshPort (SshOptions -> Word) -> Maybe SshOptions -> Maybe Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SshOptions
configSshOptions of
          Maybe Word
Nothing -> []
          Just Word
x  -> [String
"-P", Word -> String
forall a. Show a => a -> String
show Word
x]
      hostPrefix :: String
hostPrefix =
        case SshOptions -> String
sshHost (SshOptions -> String) -> Maybe SshOptions -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SshOptions
configSshOptions of
          Maybe String
Nothing -> String
""
          Just String
x  -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
      args :: [String]
args = [String]
extraArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
portArg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
src, String
hostPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dest]
  ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
-> Hapistrano ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
    (String
-> IO (ExitCode, String, String)
-> Maybe Release
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
exec' (String
prog String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
args) (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
prog [String]
args String
"") Maybe Release
maybeRelease)

----------------------------------------------------------------------------
-- Helpers
-- | A helper for 'exec' and similar functions.
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' :: String
-> IO (ExitCode, String, String)
-> Maybe Release
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
exec' String
cmd IO (ExitCode, String, String)
readProcessOutput Maybe Release
maybeRelease = do
  Config {Maybe SshOptions
Shell
OutputDest -> String -> IO ()
configPrint :: OutputDest -> String -> IO ()
configShellOptions :: Shell
configSshOptions :: Maybe SshOptions
configPrint :: Config -> OutputDest -> String -> IO ()
configShellOptions :: Config -> Shell
configSshOptions :: Config -> Maybe SshOptions
..} <- ExceptT (Failure, Maybe Release) (ReaderT Config IO) Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  ZonedTime
time <- IO ZonedTime
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) ZonedTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ZonedTime
getZonedTime
  let timeStampFormat :: String
timeStampFormat = String
"%T,  %F (%Z)"
      printableTime :: String
printableTime = TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
timeStampFormat ZonedTime
time
      hostLabel :: String
hostLabel =
        case Maybe SshOptions
configSshOptions of
          Maybe SshOptions
Nothing              -> String
"localhost"
          Just SshOptions {String
[String]
Word
sshArgs :: [String]
sshPort :: Word
sshHost :: String
sshArgs :: SshOptions -> [String]
sshPort :: SshOptions -> Word
sshHost :: SshOptions -> String
..} -> String
sshHost String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
sshPort
      hostInfo :: String
hostInfo = Color -> String -> String
colorizeString Color
Blue (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
putLine String
hostLabel
      timestampInfo :: String
timestampInfo = Color -> String -> String
colorizeString Color
Cyan (String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
printableTime String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] INFO -- : $ ")
      cmdInfo :: String
cmdInfo = Color -> String -> String
colorizeString Color
Green (String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
  IO () -> Hapistrano ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hapistrano ()) -> IO () -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$ OutputDest -> String -> IO ()
configPrint OutputDest
StdoutDest (String
hostInfo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
timestampInfo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdInfo)
  (ExitCode
exitCode', String
stdout', String
stderr') <- IO (ExitCode, String, String)
-> ExceptT
     (Failure, Maybe Release)
     (ReaderT Config IO)
     (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (ExitCode, String, String)
readProcessOutput
  Bool -> Hapistrano () -> Hapistrano ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stdout') (Hapistrano () -> Hapistrano ())
-> (IO () -> Hapistrano ()) -> IO () -> Hapistrano ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Hapistrano ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hapistrano ()) -> IO () -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$ OutputDest -> String -> IO ()
configPrint OutputDest
StdoutDest String
stdout'
  Bool -> Hapistrano () -> Hapistrano ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stderr') (Hapistrano () -> Hapistrano ())
-> (IO () -> Hapistrano ()) -> IO () -> Hapistrano ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Hapistrano ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hapistrano ()) -> IO () -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$ OutputDest -> String -> IO ()
configPrint OutputDest
StderrDest String
stderr'
  case ExitCode
exitCode' of
    ExitCode
ExitSuccess   -> String
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
stdout'
    ExitFailure Int
n -> Int
-> Maybe String
-> Maybe Release
-> ExceptT (Failure, Maybe Release) (ReaderT Config IO) String
forall a. Int -> Maybe String -> Maybe Release -> Hapistrano a
failWith Int
n Maybe String
forall a. Maybe a
Nothing Maybe Release
maybeRelease

-- | Put something “inside” a line, sort-of beautifully.
putLine :: String -> String
putLine :: String -> String
putLine String
str = String
"*** " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
padding String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  where
    padding :: String
padding = Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
75 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) Char
'*'

colorizeString :: Color -> String -> String
colorizeString :: Color -> String -> String
colorizeString Color
color String
msg =
  [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
color] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SGR] -> String
setSGRCode [SGR
Reset]