mirror of
https://github.com/stackbuilders/hapistrano.git
synced 2024-12-30 15:32:34 +03:00
Merge pull request #10 from stackbuilders/rollback
Implement rollback function
This commit is contained in:
commit
95dae7f3a8
22
BuildTest.hs
22
BuildTest.hs
@ -10,15 +10,19 @@ testConfig = Hap.Config { Hap._deployPath = "/tmp/project"
|
||||
, Hap._revision = "origin/transformer-refactor"
|
||||
}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
initState <- Hap.initialState testConfig
|
||||
|
||||
Hap.runRC errorHandler successHandler initState $
|
||||
do
|
||||
Hap.pushRelease
|
||||
Hap.defaultBuildRelease
|
||||
void Hap.activateRelease
|
||||
rollback :: IO ()
|
||||
rollback = do
|
||||
Hap.runRC errorHandler successHandler (Hap.initialState testConfig) $
|
||||
void Hap.rollback
|
||||
|
||||
where
|
||||
errorHandler = Hap.defaultErrorHandler
|
||||
successHandler = Hap.defaultSuccessHandler
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
Hap.runRC errorHandler successHandler (Hap.initialState testConfig) $
|
||||
void (Hap.pushRelease >> Hap.defaultBuildRelease >> Hap.activateRelease)
|
||||
|
||||
where
|
||||
errorHandler = Hap.defaultErrorHandler
|
||||
|
@ -8,18 +8,19 @@ module Hapistrano
|
||||
Config(..)
|
||||
, initialState
|
||||
, runRC
|
||||
, pushRelease
|
||||
|
||||
, activateRelease
|
||||
, defaultBuildRelease
|
||||
, defaultSuccessHandler
|
||||
, defaultErrorHandler
|
||||
, currentTimestamp
|
||||
, pushRelease
|
||||
, rollback
|
||||
) where
|
||||
|
||||
import Control.Lens (makeLenses, use, (^.))
|
||||
import Control.Lens (makeLenses, use, (^.), (.=))
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.IO.Class (MonadIO(liftIO))
|
||||
import Control.Monad.Trans.State (StateT, evalStateT, runStateT, get)
|
||||
import Control.Monad.Trans.State (StateT, evalStateT, get)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Either ( EitherT(..)
|
||||
, left
|
||||
@ -27,11 +28,11 @@ import Control.Monad.Trans.Either ( EitherT(..)
|
||||
, runEitherT
|
||||
, eitherT )
|
||||
import Data.Char (isNumber)
|
||||
import Data.List (intercalate, sortBy)
|
||||
import Data.List (intercalate, sortBy, sort, isInfixOf)
|
||||
import Data.Time (getCurrentTime)
|
||||
import Data.Time.Format (formatTime)
|
||||
import System.Exit (ExitCode(..))
|
||||
import System.FilePath.Posix (joinPath)
|
||||
import System.FilePath.Posix (joinPath, splitPath)
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import System.Locale (defaultTimeLocale)
|
||||
import System.Process (readProcessWithExitCode)
|
||||
@ -47,19 +48,20 @@ makeLenses ''Config
|
||||
|
||||
|
||||
data HapistranoState = HapistranoState { _config :: Config
|
||||
, _timestamp :: String
|
||||
, _timestamp :: Maybe String
|
||||
}
|
||||
makeLenses ''HapistranoState
|
||||
|
||||
type Release = String
|
||||
|
||||
type RC a = StateT HapistranoState (EitherT (Int, Maybe String) IO) a
|
||||
|
||||
initialState :: Config -> IO HapistranoState
|
||||
initialState cfg = do
|
||||
ts <- currentTimestamp
|
||||
return HapistranoState { _config = cfg
|
||||
, _timestamp = ts
|
||||
}
|
||||
-- | Returns an initial state for the deploy.
|
||||
initialState :: Config -> HapistranoState
|
||||
initialState cfg = HapistranoState { _config = cfg
|
||||
, _timestamp = Nothing
|
||||
}
|
||||
|
||||
-- | Given a pair of actions, one to perform in case of failure, and
|
||||
-- one to perform in case of success, run an EitherT and get back a
|
||||
-- monadic result.
|
||||
@ -68,10 +70,10 @@ runRC :: ((Int, Maybe String) -> IO a) -- ^ Error handler
|
||||
-> HapistranoState -- ^ Initial state
|
||||
-> RC a
|
||||
-> IO a
|
||||
runRC errorHandler successHandler initState remoteCommand =
|
||||
runRC errorHandler successHandler initState remoteCmd =
|
||||
eitherT errorHandler
|
||||
successHandler
|
||||
(evalStateT remoteCommand initState)
|
||||
(evalStateT remoteCmd initState)
|
||||
|
||||
defaultErrorHandler :: (Int, Maybe String) -> IO ()
|
||||
defaultErrorHandler _ = putStrLn "Deploy failed."
|
||||
@ -88,7 +90,7 @@ setupDirs = do
|
||||
remoteCommand $ "mkdir -p " ++ joinPath [pathName, "releases"]
|
||||
|
||||
remoteCommand :: String -- ^ The command to run remotely
|
||||
-> RC (Maybe String)
|
||||
-> RC (Maybe String)
|
||||
remoteCommand command = do
|
||||
server <- use $ config . host
|
||||
liftIO $ putStrLn $ "Going to execute " ++ command ++ " on host " ++ server
|
||||
@ -135,17 +137,21 @@ directoryExists :: FilePath -> RC (Maybe String)
|
||||
directoryExists path =
|
||||
remoteCommand $ "ls " ++ path
|
||||
|
||||
-- | Returns the FilePath pointed to by the current symlink.
|
||||
readCurrentLink :: RC (Maybe FilePath)
|
||||
readCurrentLink = do
|
||||
conf <- use config
|
||||
remoteCommand $ "readlink " ++ currentPath conf
|
||||
|
||||
-- | Ensure that the initial bare repo exists in the repo directory. Idempotent.
|
||||
ensureRepositoryPushed :: RC (Maybe String)
|
||||
ensureRepositoryPushed = do
|
||||
st <- get
|
||||
conf <- use config
|
||||
let e = runStateT (directoryExists (cacheRepoPath conf)) st
|
||||
res <- liftIO $ runEitherT e
|
||||
res <- directoryExists $ cacheRepoPath conf
|
||||
|
||||
case res of
|
||||
Left _ -> createCacheRepo
|
||||
Right _ -> lift $ right $ Just "Repo already existed"
|
||||
Nothing -> createCacheRepo
|
||||
Just _ -> lift $ right $ Just "Repo already existed"
|
||||
|
||||
-- | Returns a Just String or Nothing based on whether the input is null or
|
||||
-- has contents.
|
||||
@ -157,42 +163,84 @@ maybeString possibleString =
|
||||
releasesPath :: Config -> FilePath
|
||||
releasesPath conf = joinPath [(conf ^. deployPath), "releases"]
|
||||
|
||||
-- | Clones the repository to the next releasePath timestamp.
|
||||
-- | Figures out the most recent release if possible, and sets the
|
||||
-- StateT monad with the correct timestamp. This function is used
|
||||
-- before rollbacks.
|
||||
detectPrevious :: [String] -> RC (Maybe String)
|
||||
detectPrevious rs = do
|
||||
let mostRecentRls = biggest rs
|
||||
case mostRecentRls of
|
||||
Nothing -> lift $ left (1, Just "No previous releases detected!")
|
||||
Just rls -> do
|
||||
timestamp .= mostRecentRls
|
||||
lift $ right $ Just rls
|
||||
|
||||
-- | Activates the previous detected release.
|
||||
rollback :: RC (Maybe String)
|
||||
rollback = previousReleases >>= detectPrevious >> activateRelease
|
||||
|
||||
-- | Clones the repository to the next releasePath timestamp. Makes a new
|
||||
-- timestamp if one doesn't yet exist in the HapistranoState.
|
||||
cloneToRelease :: RC (Maybe String)
|
||||
cloneToRelease = do
|
||||
conf <- use config
|
||||
releaseTimestamp <- use timestamp
|
||||
remoteCommand $
|
||||
"git clone " ++ cacheRepoPath conf ++ " " ++ joinPath [releasesPath conf, releaseTimestamp]
|
||||
|
||||
rls <- case releaseTimestamp of
|
||||
Nothing -> do
|
||||
ts <- liftIO $ currentTimestamp
|
||||
timestamp .= Just ts
|
||||
return ts
|
||||
|
||||
Just r -> return r
|
||||
|
||||
remoteCommand $ "git clone " ++ cacheRepoPath conf ++ " " ++
|
||||
joinPath [ releasesPath conf, rls ]
|
||||
|
||||
|
||||
-- | Returns the full path to the git repo used for cache purposes on the
|
||||
-- target host filesystem.
|
||||
cacheRepoPath :: Config -> FilePath
|
||||
cacheRepoPath conf = joinPath [conf ^. deployPath, "repo"]
|
||||
|
||||
-- | Returns the full path to the current symlink.
|
||||
currentPath :: Config -> FilePath
|
||||
currentPath conf = joinPath [conf ^. deployPath, "current"]
|
||||
|
||||
-- | Take the release timestamp from the end of a filepath.
|
||||
pathToRelease :: FilePath -> Release
|
||||
pathToRelease = last . splitPath
|
||||
|
||||
-- | Returns a list of Strings representing the currently deployed releases.
|
||||
releases :: RC [String]
|
||||
releases :: RC [Release]
|
||||
releases = do
|
||||
st <- get
|
||||
conf <- use config
|
||||
res <- liftIO $ runEitherT
|
||||
(evalStateT (remoteCommand ("find " ++ releasesPath conf ++
|
||||
" -type d -maxdepth 1")) st)
|
||||
res <- remoteCommand $ "find " ++ releasesPath conf ++ " -type d -maxdepth 1"
|
||||
|
||||
case res of
|
||||
Left r -> lift $ left r
|
||||
Right Nothing -> lift $ right []
|
||||
Right (Just s) ->
|
||||
lift $ right $ filter isReleaseString . map (reverse . take 14 . reverse)
|
||||
Nothing -> lift $ right []
|
||||
Just s ->
|
||||
lift $ right $ filter isReleaseString . map pathToRelease
|
||||
$ lines s
|
||||
|
||||
-- | Given a list of release strings, takes the last five in the sequence.
|
||||
previousReleases :: RC [Release]
|
||||
previousReleases = do
|
||||
rls <- releases
|
||||
currentRelease <- readCurrentLink
|
||||
|
||||
case currentRelease of
|
||||
Nothing -> lift $ left (1, Just "Bad pointer from current link")
|
||||
Just c -> do
|
||||
let currentRel = (head . lines . pathToRelease) c
|
||||
return $ filter (< currentRel) rls
|
||||
|
||||
-- | Given a list of release strings, takes the last four in the sequence.
|
||||
-- Assumes a list of folders that has been determined to be a proper release
|
||||
-- path.
|
||||
oldReleases :: Config -> [String] -> [FilePath]
|
||||
oldReleases :: Config -> [Release] -> [FilePath]
|
||||
oldReleases conf rs = map mergePath toDelete
|
||||
where sorted = sortBy (flip compare) rs
|
||||
toDelete = drop 5 sorted
|
||||
toDelete = drop 4 sorted
|
||||
mergePath fileName = joinPath [releasesPath conf, fileName]
|
||||
|
||||
-- | Removes releases older than the last five to avoid filling up the target
|
||||
@ -209,7 +257,7 @@ cleanReleases = do
|
||||
Right xs -> do
|
||||
let deletable = oldReleases conf xs
|
||||
|
||||
remoteCommand $ "rm -rf --" ++ foldr (\a b -> a ++ " " ++ b) ""
|
||||
remoteCommand $ "rm -rf -- " ++ foldr (\a b -> a ++ " " ++ b) ""
|
||||
deletable
|
||||
|
||||
-- | Returns a Bool indicating if the given String is in the proper release
|
||||
@ -230,6 +278,9 @@ createCacheRepo = do
|
||||
currentSymlinkPath :: Config -> FilePath
|
||||
currentSymlinkPath conf = joinPath [conf ^. deployPath, "current"]
|
||||
|
||||
currentTempSymlinkPath :: Config -> FilePath
|
||||
currentTempSymlinkPath conf = joinPath [conf ^. deployPath, "current_tmp"]
|
||||
|
||||
-- | Removes the current symlink in preparation for a new release being
|
||||
-- activated.
|
||||
removeCurrentSymlink :: RC (Maybe String)
|
||||
@ -237,19 +288,39 @@ removeCurrentSymlink = do
|
||||
conf <- use config
|
||||
remoteCommand $ "rm -rf " ++ currentSymlinkPath conf
|
||||
|
||||
-- | Determines whether the target host OS is Linux
|
||||
remoteIsLinux :: RC Bool
|
||||
remoteIsLinux = do
|
||||
st <- get
|
||||
res <- liftIO $ runEitherT $ evalStateT (remoteCommand "uname") st
|
||||
|
||||
case res of
|
||||
Right (Just output) -> lift $ right $ "Linux" `isInfixOf` output
|
||||
_ -> lift $ left (1, Just "Unable to determine remote host type")
|
||||
|
||||
-- | Returns the best 'mv' command for a symlink given the target platform.
|
||||
mvCommand ::
|
||||
Bool -- ^ Whether the target host is Linux
|
||||
-> String -- ^ The best mv command for a symlink on the platform
|
||||
mvCommand True = "mv -Tf"
|
||||
mvCommand False = "mv -f"
|
||||
|
||||
-- | Creates a symlink to the directory indicated by the release timestamp.
|
||||
symlinkCurrent :: RC (Maybe String)
|
||||
symlinkCurrent = do
|
||||
st <- get
|
||||
conf <- use config
|
||||
allReleases <- liftIO . runEitherT $ evalStateT releases st
|
||||
releaseTimestamp <- use timestamp
|
||||
|
||||
case allReleases of
|
||||
Left err -> lift $ left err
|
||||
Right [] -> lift $ left (1, Just "No releases to symlink!")
|
||||
Right rls -> do
|
||||
let latest = joinPath [releasesPath conf, maximum rls]
|
||||
remoteCommand $ "ln -s " ++ latest ++ " " ++ currentSymlinkPath conf
|
||||
case releaseTimestamp of
|
||||
Nothing -> lift $ left (1, Just "No releases to symlink!")
|
||||
Just rls -> do
|
||||
isLnx <- remoteIsLinux
|
||||
|
||||
remoteCommand $ "ln -s " ++ rls ++ " " ++
|
||||
currentTempSymlinkPath conf ++
|
||||
" && " ++ mvCommand isLnx ++ " " ++
|
||||
currentTempSymlinkPath conf
|
||||
++ " " ++ currentSymlinkPath conf
|
||||
|
||||
-- | Updates the git repo used as a cache in the target host filesystem.
|
||||
updateCacheRepo :: RC (Maybe String)
|
||||
@ -268,30 +339,37 @@ defaultBuildRelease :: RC (Maybe String)
|
||||
defaultBuildRelease = do
|
||||
conf <- use config
|
||||
releaseTimestamp <- use timestamp
|
||||
remoteCommand $ intercalate " && "
|
||||
[ "cd " ++ joinPath [releasesPath conf, releaseTimestamp]
|
||||
, "export PATH=~/.cabal/bin:/usr/local/bin:$PATH"
|
||||
, "git fetch --all"
|
||||
, "git reset --hard " ++ conf ^. revision
|
||||
, "rm -rf .cabal-sandbox"
|
||||
, "cabal sandbox init"
|
||||
, "cabal clean"
|
||||
, "cabal update"
|
||||
, "cabal install --only-dependencies -j"
|
||||
, "cabal build -j" ]
|
||||
case releaseTimestamp of
|
||||
Nothing -> lift $ left (1, Just "No releases to symlink!")
|
||||
Just rls ->
|
||||
remoteCommand $ intercalate " && "
|
||||
[ "cd " ++ joinPath [releasesPath conf, rls]
|
||||
, "export PATH=~/.cabal/bin:/usr/local/bin:$PATH"
|
||||
, "git fetch --all"
|
||||
, "git reset --hard " ++ conf ^. revision
|
||||
, "rm -rf .cabal-sandbox"
|
||||
, "cabal sandbox init"
|
||||
, "cabal clean"
|
||||
, "cabal update"
|
||||
, "cabal install --only-dependencies -j"
|
||||
, "cabal build -j"
|
||||
]
|
||||
|
||||
-- | A safe version of the `maximum` function in Data.List.
|
||||
biggest :: Ord a => [a] -> Maybe a
|
||||
biggest rls =
|
||||
case (reverse . sort) rls of
|
||||
[] -> Nothing
|
||||
r:_ -> Just r
|
||||
|
||||
-- | Does basic project setup for a project, including making sure
|
||||
-- some directories exist, and pushing a new release directory with the
|
||||
-- SHA1 or branch specified in the configuration.
|
||||
pushRelease :: RC (Maybe String)
|
||||
pushRelease = do
|
||||
setupDirs
|
||||
ensureRepositoryPushed
|
||||
updateCacheRepo
|
||||
cleanReleases
|
||||
cloneToRelease
|
||||
pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
|
||||
cleanReleases >> cloneToRelease
|
||||
|
||||
-- | Switches the current symlink to point to the release specified in
|
||||
-- the configuration.
|
||||
-- the configuration. Maybe used in either deploy or rollback cases.
|
||||
activateRelease :: RC (Maybe String)
|
||||
activateRelease = removeCurrentSymlink >> symlinkCurrent
|
||||
|
Loading…
Reference in New Issue
Block a user