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