module System.Hapistrano
( Config(..)
, ReleaseFormat(..)
, activateRelease
, currentPath
, defaultSuccessHandler
, defaultErrorHandler
, directoryExists
, isReleaseString
, pathToRelease
, pushRelease
, readCurrentLink
, restartServerCommand
, rollback
, runRC
, runBuild
) where
import Control.Monad.Reader (ReaderT(..), ask)
import System.Hapistrano.Types
(Config(..), FailureResult, Hapistrano, Release, ReleaseFormat(..))
import Control.Monad (unless, void)
import System.Exit (ExitCode(..), exitWith)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Either ( left
, right
, eitherT )
import Data.Char (isNumber)
import Data.List (intercalate, sortBy, isInfixOf)
import Data.Time (getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import System.FilePath.Posix (joinPath, splitPath)
import System.IO (hPutStrLn, stderr)
import System.Process (readProcessWithExitCode)
import qualified System.IO as IO
import qualified System.Process as Process
pushRelease :: Hapistrano Release
pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
cleanReleases >> cloneToRelease >>= setReleaseRevision
activateRelease :: Release -> Hapistrano String
activateRelease rel = removeCurrentSymlink >> symlinkCurrent rel
runRC :: ((Int, String) -> ReaderT Config IO a)
-> (a -> ReaderT Config IO a)
-> Config
-> Hapistrano a
-> IO a
runRC errorHandler successHandler config command =
runReaderT (eitherT errorHandler successHandler command) config
defaultErrorHandler :: FailureResult -> ReaderT Config IO ()
defaultErrorHandler res =
liftIO $ hPutStrLn stderr
("Deploy failed with (status, message): " ++ show res)
>> exitWith (ExitFailure 1)
defaultSuccessHandler :: a -> ReaderT Config IO ()
defaultSuccessHandler _ =
liftIO $ putStrLn "Deploy completed successfully."
setupDirs :: Hapistrano ()
setupDirs = do
conf <- ask
mapM_ (runCommand (host conf))
["mkdir -p " ++ releasesPath conf, "mkdir -p " ++ cacheRepoPath conf]
directoryExists :: Maybe String -> FilePath -> IO Bool
directoryExists hst path = do
let (command, args) = case hst of
Just h -> ("ssh", [h, "ls", path])
Nothing -> ("ls", [path])
(code, _, _) <- readProcessWithExitCode command args ""
return $ case code of
ExitSuccess -> True
ExitFailure _ -> False
runCommand :: Maybe String
-> String
-> Hapistrano String
runCommand Nothing command = execShellCommand command
runCommand (Just server) command =
execCommand $ unwords ["ssh", server, command]
execShellCommand :: String -> Hapistrano String
execShellCommand command = do
liftIO $ putStrLn ("Executing: " ++ command)
let process = Process.shell command
(_, Just outHandle, Just errHandle, processHandle) <-
liftIO $
Process.createProcess process { Process.std_err = Process.CreatePipe
, Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
}
exitCode <- liftIO $ Process.waitForProcess processHandle
case exitCode of
ExitFailure code -> do
err <- liftIO $ IO.hGetContents errHandle
left (code, trim err)
ExitSuccess -> do
out <- liftIO $ IO.hGetContents outHandle
unless (null out) (liftIO $ putStrLn ("Output: " ++ out))
right (trim out)
execCommand :: String -> Hapistrano String
execCommand cmd = do
let wds = words cmd
(cmd', args) = (head wds, tail wds)
liftIO $ putStrLn $ "Executing: " ++ cmd
(code, stdout, err) <- liftIO $ readProcessWithExitCode cmd' args ""
case code of
ExitSuccess -> do
unless (null stdout) (liftIO $ putStrLn $ "Output: " ++ stdout)
right $ trim stdout
ExitFailure int -> left (int, trim err)
currentTimestamp :: ReleaseFormat -> IO String
currentTimestamp format = do
curTime <- getCurrentTime
return $ formatTime defaultTimeLocale fstring curTime
where fstring = case format of
Short -> "%Y%m%d%H%M%S"
Long -> "%Y%m%d%H%M%S%q"
readCurrentLink :: Hapistrano FilePath
readCurrentLink = do
conf <- ask
runCommand (host conf) $ "readlink " ++ currentPath (deployPath conf)
trim :: String
-> String
trim = reverse . dropWhile (== '\n') . reverse
ensureRepositoryPushed :: Hapistrano String
ensureRepositoryPushed = do
conf <- ask
res <-
liftIO $ directoryExists (host conf) $ joinPath [cacheRepoPath conf, "refs"]
if res
then right "Repo already existed"
else createCacheRepo
releasesPath :: Config -> FilePath
releasesPath conf = joinPath [deployPath conf, "releases"]
detectPrevious :: [String]
-> Hapistrano String
detectPrevious rs =
case biggest rs of
Nothing -> left (1, "No previous releases detected!")
Just rls -> right rls
rollback :: Hapistrano String
rollback = previousReleases >>= detectPrevious >>= activateRelease
cloneToRelease :: Hapistrano Release
cloneToRelease = do
conf <- ask
rls <- liftIO $ currentTimestamp (releaseFormat conf)
void $ runCommand (host conf) $ "git clone " ++ cacheRepoPath conf ++
" " ++ joinPath [ releasesPath conf, rls ]
return rls
cacheRepoPath :: Config
-> FilePath
cacheRepoPath conf = joinPath [deployPath conf, "repo"]
currentPath :: FilePath
-> FilePath
currentPath depPath = joinPath [depPath, "current"]
pathToRelease :: FilePath
-> Release
pathToRelease = last . splitPath
releases :: Hapistrano [Release]
releases = do
conf <- ask
res <- runCommand (host conf) $ "find " ++ releasesPath conf ++
" -type d -maxdepth 1"
right $
filter (isReleaseString (releaseFormat conf)) . map pathToRelease $
lines res
previousReleases :: Hapistrano [Release]
previousReleases = do
rls <- releases
currentRelease <- readCurrentLink
let currentRel = (head . lines . pathToRelease) currentRelease
return $ filter (< currentRel) rls
releasePath :: Config -> Release -> FilePath
releasePath conf rls = joinPath [releasesPath conf, rls]
oldReleases :: Config -> [Release] -> [FilePath]
oldReleases conf rs = map mergePath toDelete
where sorted = sortBy (flip compare) rs
toDelete = drop 4 sorted
mergePath = releasePath conf
cleanReleases :: Hapistrano [String]
cleanReleases = do
conf <- ask
allReleases <- releases
let deletable = oldReleases conf allReleases
if null deletable
then do
liftIO $ putStrLn "There are no old releases to prune."
return []
else do
_ <- runCommand (host conf) $ "rm -rf -- " ++ unwords deletable
return deletable
isReleaseString :: ReleaseFormat
-> String
-> Bool
isReleaseString format s = all isNumber s && length s == releaseLength
where releaseLength = case format of
Short -> 14
Long -> 26
createCacheRepo :: Hapistrano String
createCacheRepo = do
conf <- ask
runCommand (host conf) $ "git clone --bare " ++ repository conf ++ " " ++
cacheRepoPath conf
currentSymlinkPath :: Config -> FilePath
currentSymlinkPath conf = joinPath [deployPath conf, "current"]
currentTempSymlinkPath :: Config -> FilePath
currentTempSymlinkPath conf = joinPath [deployPath conf, "current_tmp"]
removeCurrentSymlink :: Hapistrano ()
removeCurrentSymlink = do
conf <- ask
void $ runCommand (host conf) $ "rm -rf " ++ currentSymlinkPath conf
targetIsLinux :: Hapistrano Bool
targetIsLinux = do
conf <- ask
res <- runCommand (host conf) "uname"
right $ "Linux" `isInfixOf` res
restartServerCommand :: Hapistrano String
restartServerCommand = do
conf <- ask
case restartCommand conf of
Nothing -> return "No command given for restart action."
Just cmd -> runCommand (host conf) cmd
runBuild :: Release -> Hapistrano Release
runBuild rel = do
conf <- ask
case buildScript conf of
Nothing ->
liftIO $ putStrLn "No build script specified, skipping build step."
Just scr -> do
fl <- liftIO $ readFile scr
buildRelease rel $ lines fl
right rel
mvCommand :: Bool
-> String
mvCommand True = "mv -Tf"
mvCommand False = "mv -f"
lnCommand ::
String
-> String
-> String
lnCommand rlsPath symlinkPath = unwords ["ln -s", rlsPath, symlinkPath]
symlinkCurrent :: Release -> Hapistrano String
symlinkCurrent rel = do
conf <- ask
isLnx <- targetIsLinux
let tmpLnCmd =
lnCommand (releasePath conf rel) (currentTempSymlinkPath conf)
_ <- runCommand (host conf) tmpLnCmd
runCommand (host conf) $ unwords [ mvCommand isLnx
, currentTempSymlinkPath conf
, currentSymlinkPath conf ]
updateCacheRepo :: Hapistrano ()
updateCacheRepo = do
conf <- ask
void $ runCommand (host conf) $ intercalate " && "
[ "cd " ++ cacheRepoPath conf
, "git fetch origin +refs/heads/*:refs/heads/*" ]
setReleaseRevision :: Release -> Hapistrano Release
setReleaseRevision rel = do
conf <- ask
liftIO $ putStrLn "Setting revision in release path."
void $ runCommand (host conf) $ intercalate " && "
[ "cd " ++ releasePath conf rel
, "git fetch --all"
, "git reset --hard " ++ revision conf
]
return rel
buildRelease :: Release
-> [String]
-> Hapistrano ()
buildRelease rel commands = do
conf <- ask
let cdCmd = "cd " ++ releasePath conf rel
void $ runCommand (host conf) $ intercalate " && " $ cdCmd : commands
biggest :: Ord a => [a] -> Maybe a
biggest rls =
case sortBy (flip compare) rls of
[] -> Nothing
r:_ -> Just r