{-# 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
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)
exec ::
forall a. Command a
=> a
-> Maybe Release
-> 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
execWithInheritStdout ::
Command a
=> a
-> Maybe Release
-> 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
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
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"
scpFile ::
Path Abs File
-> Path Abs File
-> Maybe Release
-> 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"]
scpDir ::
Path Abs Dir
-> Path Abs Dir
-> Maybe Release
-> 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)
exec' ::
String
-> IO (ExitCode, String, String)
-> Maybe Release
-> Hapistrano String
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
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]