stackbuilders/hapistrano
1
1
Fork 0
mirror of https://github.com/stackbuilders/hapistrano.git synced 2024-12-29 06:54:03 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #10 from stackbuilders/rollback

Browse Source 
Implement rollback function
This commit is contained in:
Justin S. Leitgeb 2014-06-03 14:28:48 -04:00
commit 95dae7f3a8
2 changed files with 154 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
BuildTest.hs
View File

@ -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

204
src/Hapistrano.hs
View File

@ -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