-- |
-- Module      :  System.Hapistrano.Core
-- Copyright   :  © 2015-Present Stack Builders
-- License     :  MIT
--
-- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com>
-- 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
  ( runHapistrano
  , 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
import           System.Process
import           System.Process.Typed       (ProcessConfig)
import qualified System.Process.Typed       as SPT

-- | 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 a
r <- ReaderT Config IO (Either Failure a)
-> Config -> IO (Either Failure a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Hapistrano a -> ReaderT Config IO (Either Failure a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT Hapistrano a
m) Config
config
    case Either Failure a
r of
      Left (Failure Int
n Maybe String
msg) -> 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)

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

-- | 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
  -> Hapistrano (Result a)
exec :: a -> Hapistrano (Result a)
exec a
typedCmd = 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 (ReaderT Config IO) String
-> Hapistrano (Result a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    String
-> IO (ExitCode, String, String)
-> ExceptT Failure (ReaderT Config IO) String
exec' String
cmd (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
prog [String]
args String
"")

-- | Same as 'exec' but it streams to stdout only for _GenericCommand_s
execWithInheritStdout :: Command a => a -> Hapistrano ()
execWithInheritStdout :: a -> Hapistrano ()
execWithInheritStdout a
typedCmd = 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 (ReaderT Config IO) String -> Hapistrano ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT Failure (ReaderT Config IO) String -> Hapistrano ())
-> ExceptT Failure (ReaderT Config IO) String -> Hapistrano ()
forall a b. (a -> b) -> a -> b
$ String
-> IO (ExitCode, String, String)
-> ExceptT Failure (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))
    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 remotelly.
getProgAndArgs :: String -> Hapistrano (String, [String])
getProgAndArgs :: String -> Hapistrano (String, [String])
getProgAndArgs String
cmd = 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 (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
  -> Hapistrano ()
scpFile :: Path Abs File -> Path Abs File -> Hapistrano ()
scpFile Path Abs File
src Path Abs File
dest = String -> String -> [String] -> 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
  -> Hapistrano ()
scpDir :: Path Abs Dir -> Path Abs Dir -> Hapistrano ()
scpDir Path Abs Dir
src Path Abs Dir
dest = String -> String -> [String] -> 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] -> Hapistrano ()
scp' :: String -> String -> [String] -> Hapistrano ()
scp' String
src String
dest [String]
extraArgs = 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 (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 (ReaderT Config IO) String -> Hapistrano ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
    (String
-> IO (ExitCode, String, String)
-> ExceptT Failure (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
""))

----------------------------------------------------------------------------
-- 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
  -> Hapistrano String -- ^ Raw stdout output of that program
exec' :: String
-> IO (ExitCode, String, String)
-> ExceptT Failure (ReaderT Config IO) String
exec' String
cmd IO (ExitCode, String, String)
readProcessOutput = 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 (ReaderT Config IO) Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  ZonedTime
time <- IO ZonedTime -> ExceptT Failure (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 (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 (ReaderT Config IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
stdout'
    ExitFailure Int
n -> Int -> Maybe String -> ExceptT Failure (ReaderT Config IO) String
forall a. Int -> Maybe String -> Hapistrano a
failWith Int
n Maybe String
forall a. Maybe a
Nothing

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