{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.Hapistrano.Core
( runHapistrano
, failWith
, exec
, execWithInheritStdout
, scpFile
, scpDir )
where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Concurrent.STM (atomically)
import Data.Proxy
import Path
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
runHapistrano :: MonadIO m
=> Maybe SshOptions
-> (OutputDest -> String -> IO ())
-> Hapistrano a
-> m (Either Int a)
runHapistrano sshOptions printFnc m = liftIO $ do
let config = Config
{ configSshOptions = sshOptions
, configPrint = printFnc }
r <- runReaderT (runExceptT m) config
case r of
Left (Failure n msg) -> do
forM_ msg (printFnc StderrDest)
return (Left n)
Right x -> return (Right x)
failWith :: Int -> Maybe String -> Hapistrano a
failWith n msg = throwError (Failure n msg)
exec :: forall a. Command a => a -> Hapistrano (Result a)
exec typedCmd = do
Config {..} <- ask
let (prog, args) =
case configSshOptions of
Nothing ->
("bash", ["-c", cmd])
Just SshOptions {..} ->
("ssh", [sshHost, "-p", show sshPort, cmd])
cmd = renderCommand typedCmd
parseResult (Proxy :: Proxy a) <$> exec' cmd (readProcessWithExitCode prog args "")
execWithInheritStdout :: Command a => a -> Hapistrano ()
execWithInheritStdout typedCmd = do
Config {..} <- ask
let (prog, args) =
case configSshOptions of
Nothing ->
("bash", ["-c", cmd])
Just SshOptions {..} ->
("ssh", [sshHost, "-p", show sshPort, cmd])
cmd = renderCommand typedCmd
void $ exec' cmd (readProcessWithExitCode' (SPT.proc prog args))
where
readProcessWithExitCode'
:: ProcessConfig stdin stdoutIgnored stderrIgnored
-> IO (ExitCode, String, String)
readProcessWithExitCode' pc =
SPT.withProcess pc' $ \p -> atomically $
(,,) <$> SPT.waitExitCodeSTM p
<*> return ""
<*> return ""
where
pc' = SPT.setStdout SPT.inherit
$ SPT.setStderr SPT.inherit pc
scpFile
:: Path Abs File
-> Path Abs File
-> Hapistrano ()
scpFile src dest =
scp' (fromAbsFile src) (fromAbsFile dest) ["-q"]
scpDir
:: Path Abs Dir
-> Path Abs Dir
-> Hapistrano ()
scpDir src dest =
scp' (fromAbsDir src) (fromAbsDir dest) ["-qr"]
scp'
:: FilePath
-> FilePath
-> [String]
-> Hapistrano ()
scp' src dest extraArgs = do
Config {..} <- ask
let prog = "scp"
portArg =
case sshPort <$> configSshOptions of
Nothing -> []
Just x -> ["-P", show x]
hostPrefix =
case sshHost <$> configSshOptions of
Nothing -> ""
Just x -> x ++ ":"
args = extraArgs ++ portArg ++ [src, hostPrefix ++ dest]
void (exec' (prog ++ " " ++ unwords args) (readProcessWithExitCode prog args ""))
exec'
:: String
-> IO (ExitCode, String, String)
-> Hapistrano String
exec' cmd readProcessOutput = do
Config {..} <- ask
let hostLabel =
case configSshOptions of
Nothing -> "localhost"
Just SshOptions {..} -> sshHost ++ ":" ++ show sshPort
liftIO $ configPrint StdoutDest (putLine hostLabel ++ "$ " ++ cmd ++ "\n")
(exitCode', stdout', stderr') <- liftIO readProcessOutput
unless (null stdout') . liftIO $
configPrint StdoutDest stdout'
unless (null stderr') . liftIO $
configPrint StderrDest stderr'
case exitCode' of
ExitSuccess ->
return stdout'
ExitFailure n ->
failWith n Nothing
putLine :: String -> String
putLine str = "*** " ++ str ++ padding ++ "\n"
where
padding = ' ' : replicate (75 - length str) '*'