module System.Hapistrano
( Config(..)
, 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)
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 = execCommand command
runCommand (Just server) command =
execCommand $ unwords ["ssh", server, command]
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