-- |
-- 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.Catch        (throwM)
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 :: forall a. Int -> Maybe [Char] -> Maybe Release -> Hapistrano a
failWith Int
n Maybe [Char]
msg Maybe Release
maybeRelease = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ (Failure, Maybe Release) -> HapistranoException
HapistranoException (Int -> Maybe [Char] -> Failure
Failure Int
n Maybe [Char]
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 :: forall a. Command a => a -> Maybe Release -> Hapistrano (Result a)
exec a
typedCmd Maybe Release
maybeRelease = do
  let cmd :: [Char]
cmd = forall a. Command a => a -> [Char]
renderCommand a
typedCmd
  ([Char]
prog, [[Char]]
args) <- [Char] -> Hapistrano ([Char], [[Char]])
getProgAndArgs [Char]
cmd
  forall a. Command a => Proxy a -> [Char] -> Result a
parseResult (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [Char]
-> IO (ExitCode, [Char], [Char])
-> Maybe Release
-> Hapistrano [Char]
exec' [Char]
cmd ([Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode [Char]
prog [[Char]]
args [Char]
"") 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 :: forall a. Command a => a -> Maybe Release -> Hapistrano ()
execWithInheritStdout a
typedCmd Maybe Release
maybeRelease = do
  let cmd :: [Char]
cmd = forall a. Command a => a -> [Char]
renderCommand a
typedCmd
  ([Char]
prog, [[Char]]
args) <- [Char] -> Hapistrano ([Char], [[Char]])
getProgAndArgs [Char]
cmd
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ [Char]
-> IO (ExitCode, [Char], [Char])
-> Maybe Release
-> Hapistrano [Char]
exec' [Char]
cmd (forall stdin stdoutIgnored stderrIgnored.
ProcessConfig stdin stdoutIgnored stderrIgnored
-> IO (ExitCode, [Char], [Char])
readProcessWithExitCode' ([Char] -> [[Char]] -> ProcessConfig () () ()
SPT.proc [Char]
prog [[Char]]
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' :: forall stdin stdoutIgnored stderrIgnored.
ProcessConfig stdin stdoutIgnored stderrIgnored
-> IO (ExitCode, [Char], [Char])
readProcessWithExitCode' ProcessConfig stdin stdoutIgnored stderrIgnored
pc =
      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' forall a b. (a -> b) -> a -> b
$ \Process stdin () ()
p ->
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall stdin stdout stderr.
Process stdin stdout stderr -> STM ExitCode
SPT.waitExitCodeSTM Process stdin () ()
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
      where
        pc' :: ProcessConfig stdin () ()
pc' = forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
SPT.setStdout forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
SPT.inherit forall a b. (a -> b) -> a -> b
$ forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
SPT.setStderr 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 :: [Char] -> Hapistrano ([Char], [[Char]])
getProgAndArgs [Char]
cmd = do
  Config {Maybe SshOptions
Shell
OutputDest -> [Char] -> IO ()
configPrint :: Config -> OutputDest -> [Char] -> IO ()
configShellOptions :: Config -> Shell
configSshOptions :: Config -> Maybe SshOptions
configPrint :: OutputDest -> [Char] -> IO ()
configShellOptions :: Shell
configSshOptions :: Maybe SshOptions
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    case Maybe SshOptions
configSshOptions of
      Maybe SshOptions
Nothing -> (Shell -> [Char]
renderShell Shell
configShellOptions, [[Char]
"-c", [Char]
cmd])
      Just SshOptions {[Char]
[[Char]]
Word
sshArgs :: SshOptions -> [[Char]]
sshPort :: SshOptions -> Word
sshHost :: SshOptions -> [Char]
sshArgs :: [[Char]]
sshPort :: Word
sshHost :: [Char]
..} ->
        ([Char]
"ssh", [[Char]]
sshArgs forall a. [a] -> [a] -> [a]
++ [[Char]
sshHost, [Char]
"-p", forall a. Show a => a -> [Char]
show Word
sshPort, [Char]
cmd])
    where
      renderShell :: Shell -> String
      renderShell :: Shell -> [Char]
renderShell Shell
Zsh  = [Char]
"zsh"
      renderShell Shell
Bash = [Char]
"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 = [Char] -> [Char] -> [[Char]] -> Maybe Release -> Hapistrano ()
scp' (Path Abs File -> [Char]
fromAbsFile Path Abs File
src) (Path Abs File -> [Char]
fromAbsFile Path Abs File
dest) [[Char]
"-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 = [Char] -> [Char] -> [[Char]] -> Maybe Release -> Hapistrano ()
scp' (Path Abs Dir -> [Char]
fromAbsDir Path Abs Dir
src) (Path Abs Dir -> [Char]
fromAbsDir Path Abs Dir
dest) [[Char]
"-qr"]

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

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

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