diff --git a/hapistrano.cabal b/hapistrano.cabal --- a/hapistrano.cabal +++ b/hapistrano.cabal @@ -1,46 +1,89 @@ name: hapistrano -version: 0.1.0.2 +version: 0.2.0.1 synopsis: A deployment library for Haskell applications -description: Hapistrano makes it easy to reliably deploy Haskell - applications. - +description: + . + Hapistrano makes it easy to reliably deploy Haskell applications + to a server. + . + Following popular libraries like Ruby's , Hapistrano does the work of building the application + with dependencies into a distinct folder, and then atomically moves + a symlink to the latest complete build. + . + This allows for atomic switchovers to new application code after the + build is complete. Rollback is even simpler, since Hapistrano can + just point the `current` symlink to the previous release. + . + See + for more information. + . license: MIT license-file: LICENSE author: Justin Leitgeb maintainer: justin@stackbuilders.com -copyright: 2014 Stack Builders Inc. +copyright: 2015 Stack Builders Inc. category: System +Homepage: https://github.com/stackbuilders/hapistrano +Bug-reports: https://github.com/stackbuilders/hapistrano/issues build-type: Simple cabal-version: >=1.10 executable hap main-is: Main.hs hs-source-dirs: src - build-depends: base >=4.6 && <4.8 + build-depends: base >=4.5 && <4.8 , time , old-locale , process , either , transformers - , lens >= 4.1 + , mtl , filepath - , either + , base-compat + default-language: Haskell2010 + ghc-options: -Wall library - exposed-modules: Hapistrano - build-depends: base >=4.6 && <4.8 + exposed-modules: System.Hapistrano + other-modules: System.Hapistrano.Types + + build-depends: base >=4.5 && <4.8 , time , old-locale , process , either , transformers - , lens >= 4.1 + , mtl , filepath - , either + , base-compat hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall + +test-suite hapistrano-test + type: exitcode-stdio-1.0 + hs-source-dirs: spec, src + main-is: Spec.hs + + build-depends: base >=4.5 && <4.8 + , time + , old-locale + , process + , either + , transformers + , mtl + , filepath + , base-compat + + , hspec + , temporary + , directory + + default-language: Haskell2010 + ghc-options: -Wall source-repository head type: git diff --git a/spec/Spec.hs b/spec/Spec.hs new file mode 100644 --- /dev/null +++ b/spec/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/Hapistrano.hs b/src/Hapistrano.hs deleted file mode 100644 --- a/src/Hapistrano.hs +++ /dev/null @@ -1,414 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - --- | A module for easily creating reliable deploy processes for Haskell --- applications. -module Hapistrano - ( - Config(..) - , initialState - , runRC - - , activateRelease - , runBuild - , defaultSuccessHandler - , defaultErrorHandler - , pushRelease - , restartServerCommand - , rollback - ) where - -import Control.Lens (makeLenses, use, (^.), (.=)) -import Control.Monad (unless) -import System.Exit (ExitCode(..), exitWith) - -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.State (StateT, evalStateT, get) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Either ( EitherT(..) - , left - , right - , runEitherT - , eitherT ) -import Data.Char (isNumber) -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, splitPath) -import System.IO (hPutStrLn, stderr) -import System.Locale (defaultTimeLocale) -import System.Process (readProcessWithExitCode) - --- | Config stuff that will be replaced by config file reading -data Config = Config { _deployPath :: String - , _host :: String - , _repository :: String -- ^ The remote git repo - , _revision :: String -- ^ A SHA1 or branch to release - , _buildScript :: Maybe FilePath - , _restartCommand :: Maybe String - } deriving (Show) - -makeLenses ''Config - - -data HapistranoState = HapistranoState { _config :: Config - , _timestamp :: Maybe String - } -makeLenses ''HapistranoState - -type Release = String - -type RC a = StateT HapistranoState (EitherT (Int, Maybe String) IO) a - --- | 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 = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >> - cleanReleases >> cloneToRelease >> setReleaseRevision - --- | Switches the current symlink to point to the release specified in --- the configuration. Maybe used in either deploy or rollback cases. -activateRelease :: RC (Maybe String) -activateRelease = removeCurrentSymlink >> symlinkCurrent - - --- | 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. -runRC :: ((Int, Maybe String) -> IO a) -- ^ Error handler - -> (a -> IO a) -- ^ Success handler - -> HapistranoState -- ^ Initial state - -> RC a - -> IO a -runRC errorHandler successHandler initState remoteCmd = - eitherT errorHandler - successHandler - (evalStateT remoteCmd initState) - -defaultErrorHandler :: (Int, Maybe String) -> IO () -defaultErrorHandler _ = - hPutStrLn stderr "Deploy failed." >> exitWith (ExitFailure 1) - -defaultSuccessHandler :: a -> IO () -defaultSuccessHandler _ = putStrLn "Deploy completed successfully." - - --- | Creates necessary directories for the hapistrano project. Should --- only need to run the first time the project is deployed on a given --- system. -setupDirs :: RC (Maybe String) -setupDirs = do - conf <- use config - - remoteCommand $ intercalate " && " - [ "mkdir -p " ++ releasesPath conf - , "mkdir -p " ++ cacheRepoPath conf - ] - -remoteCommand :: String -- ^ The command to run remotely - -> RC (Maybe String) -remoteCommand command = do - server <- use $ config . host - liftIO $ putStrLn $ "Going to execute " ++ command ++ " on host " ++ server - ++ "." - - (code, stdout, err) <- - liftIO $ readProcessWithExitCode "ssh" (server : words command) "" - - case code of - ExitSuccess -> do - liftIO $ putStrLn $ "Command '" ++ command ++ - "' was successful on host '" ++ server ++ "'." - - unless (null stdout) (liftIO $ putStrLn $ "Output:\n" ++ stdout) - - lift $ right $ maybeString stdout - - ExitFailure int -> do - let maybeError = maybeString err - liftIO $ printCommandError server command (int, maybeError) - lift $ left (int, maybeError) - --- | Returns a timestamp in the default format for build directories. -currentTimestamp :: IO String -currentTimestamp = do - curTime <- getCurrentTime - return $ formatTime defaultTimeLocale "%Y%m%d%H%M%S" curTime - -echoMessage :: String -> RC (Maybe String) -echoMessage msg = do - liftIO $ putStrLn msg - lift $ right Nothing - -printCommandError :: String -> String -> (Int, Maybe String) -> IO () -printCommandError server cmd (errCode, Nothing) = - hPutStrLn stderr $ "Command " ++ " '" ++ cmd ++ "' failed on host '" ++ - server ++ "' with error code " ++ show errCode ++ " and no STDERR output." -printCommandError server cmd (errCode, Just errMsg) = - hPutStrLn stderr $ "Command " ++ " '" ++ cmd ++ "' failed on host '" ++ - server ++ "' with error code " ++ show errCode ++ " and message '" ++ - errMsg ++ "'." - -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 - conf <- use config - res <- directoryExists $ cacheRepoPath conf - - case res of - 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. -maybeString :: String -> Maybe String -maybeString possibleString = - if null possibleString then Nothing else Just possibleString - --- | Returns the full path of the folder containing all of the release builds. -releasesPath :: Config -> FilePath -releasesPath conf = joinPath [conf ^. deployPath, "releases"] - --- | 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 - - 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 [Release] -releases = do - conf <- use config - res <- remoteCommand $ "find " ++ releasesPath conf ++ " -type d -maxdepth 1" - - case res of - Nothing -> lift $ right [] - Just s -> - lift $ right $ filter isReleaseString . map pathToRelease - $ lines s - -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 - -releasePath :: Config -> Release -> FilePath -releasePath conf rls = joinPath [releasesPath conf, 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 -> [Release] -> [FilePath] -oldReleases conf rs = map mergePath toDelete - where sorted = sortBy (flip compare) rs - toDelete = drop 4 sorted - mergePath = releasePath conf - --- | Removes releases older than the last five to avoid filling up the target --- host filesystem. -cleanReleases :: RC (Maybe String) -cleanReleases = do - conf <- use config - allReleases <- releases - - case allReleases of - [] -> echoMessage "There are no old releases to prune." - xs -> do - let deletable = oldReleases conf xs - - remoteCommand $ "rm -rf -- " ++ foldr (\a b -> a ++ " " ++ b) "" - deletable - --- | Returns a Bool indicating if the given String is in the proper release --- format. -isReleaseString :: String -> Bool -isReleaseString s = all isNumber s && length s == 14 - --- | Creates the git repository that is used on the target host for --- cache purposes. -createCacheRepo :: RC (Maybe String) -createCacheRepo = do - conf <- use config - remoteCommand $ "git clone --bare " ++ conf ^. repository ++ " " ++ - cacheRepoPath conf - --- | Returns the full path of the symlink pointing to the current --- release. -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) -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 <- remoteCommand "uname" - - case res of - Just output -> lift $ right $ "Linux" `isInfixOf` output - _ -> lift $ left (1, Just "Unable to determine remote host type") - -restartServerCommand :: RC (Maybe String) -restartServerCommand = do - conf <- use config - case conf ^. restartCommand of - Nothing -> return $ Just "No command given for restart action." - Just cmd -> remoteCommand cmd - -runBuild :: RC (Maybe String) -runBuild = do - conf <- use config - case conf ^. buildScript of - Nothing -> do - liftIO $ putStrLn "No build script specified, skipping build step." - return Nothing - - Just scr -> do - fl <- liftIO $ readFile scr - let commands = lines fl - buildRelease commands - --- | 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 - conf <- use config - releaseTimestamp <- use timestamp - - case releaseTimestamp of - Nothing -> lift $ left (1, Just "No releases to symlink!") - Just rls -> do - isLnx <- remoteIsLinux - - remoteCommand $ "ln -s " ++ releasePath conf 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) -updateCacheRepo = do - conf <- use config - remoteCommand $ intercalate " && " - [ "cd " ++ cacheRepoPath conf - , "git fetch origin +refs/heads/*:refs/heads/*" ] - --- | Sets the release to the correct revision by resetting the --- head of the git repo. -setReleaseRevision :: RC (Maybe String) -setReleaseRevision = do - conf <- use config - releaseTimestamp <- use timestamp - case releaseTimestamp of - Nothing -> lift $ left (1, Just "No releases to symlink!") - Just rls -> - remoteCommand $ intercalate " && " - [ "cd " ++ releasePath conf rls - , "git fetch --all" - , "git reset --hard " ++ conf ^. revision - ] - --- | Returns a command that builds this application. Sets the context --- of the build by switching to the release directory before running --- the script. -buildRelease :: [String] -- ^ Commands to be run. List intercalated - -- with "&&" so that failure aborts the - -- sequence. - -> RC (Maybe String) -buildRelease commands = do - conf <- use config - releaseTimestamp <- use timestamp - case releaseTimestamp of - Nothing -> lift $ left (1, Just "No releases to symlink!") - Just rls -> do - let cdCmd = "cd " ++ releasePath conf rls - remoteCommand $ intercalate " && " $ cdCmd : commands - --- | A safe version of the `maximum` function in Data.List. -biggest :: Ord a => [a] -> Maybe a -biggest rls = - case sortBy (flip compare) rls of - [] -> Nothing - r:_ -> Just r diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,19 +1,20 @@ module Main where -import qualified Hapistrano as Hap +import qualified System.Hapistrano as Hap import Control.Monad (void) -import System.Environment (getArgs, getEnv, lookupEnv) +import System.Environment (getArgs, getEnv) +import System.Environment.Compat (lookupEnv) import System.IO (hPutStrLn, stderr) -import System.Exit (exitFailure, exitSuccess) -import Control.Applicative ((<$>)) -import Control.Monad.IO.Class (MonadIO(liftIO)) +import System.Exit (exitFailure) +import System.Hapistrano.Types (ReleaseFormat(..)) + -- | Rolls back to previous release. rollback :: Hap.Config -> IO () rollback cfg = - Hap.runRC errorHandler successHandler (Hap.initialState cfg) $ do + Hap.runRC errorHandler successHandler cfg $ do - Hap.rollback + _ <- Hap.rollback void Hap.restartServerCommand where @@ -23,10 +24,8 @@ -- | Deploys the current release with Config options. deploy :: Hap.Config -> IO () deploy cfg = - Hap.runRC errorHandler successHandler (Hap.initialState cfg) $ do - Hap.pushRelease - Hap.runBuild - Hap.activateRelease + Hap.runRC errorHandler successHandler cfg $ do + _ <- Hap.pushRelease >>= Hap.runBuild >>= Hap.activateRelease void Hap.restartServerCommand @@ -37,19 +36,22 @@ -- | Retrieves the configuration from environment variables. configFromEnv :: IO Hap.Config configFromEnv = do - deployPath <- getEnv "DEPLOY_PATH" - host <- getEnv "HOST" - repository <- getEnv "REPOSITORY" - revision <- getEnv "REVISION" + deployPath <- getEnv "DEPLOY_PATH" + repository <- getEnv "REPOSITORY" + revision <- getEnv "REVISION" + + host <- lookupEnv "HOST" buildScript <- lookupEnv "BUILD_SCRIPT" restartCommand <- lookupEnv "RESTART_COMMAND" - return Hap.Config { Hap._deployPath = deployPath - , Hap._host = host - , Hap._repository = repository - , Hap._revision = revision - , Hap._buildScript = buildScript - , Hap._restartCommand = restartCommand + + return Hap.Config { Hap.deployPath = deployPath + , Hap.host = host + , Hap.releaseFormat = Short + , Hap.repository = repository + , Hap.revision = revision + , Hap.buildScript = buildScript + , Hap.restartCommand = restartCommand } main :: IO () diff --git a/src/System/Hapistrano.hs b/src/System/Hapistrano.hs new file mode 100644 --- /dev/null +++ b/src/System/Hapistrano.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A module for easily creating reliable deploy processes for Haskell +-- applications. +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 System.FilePath.Posix (joinPath, splitPath) +import System.IO (hPutStrLn, stderr) +import System.Locale (defaultTimeLocale) +import System.Process (readProcessWithExitCode) + +-- | 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 :: Hapistrano Release +pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >> + cleanReleases >> cloneToRelease >>= setReleaseRevision + +-- | Switches the current symlink to point to the release specified in +-- the configuration. Maybe used in either deploy or rollback cases. +activateRelease :: Release -> Hapistrano String +activateRelease rel = removeCurrentSymlink >> symlinkCurrent rel + +-- | Runs the deploy, along with an optional success or failure function. +runRC :: ((Int, String) -> ReaderT Config IO a) -- ^ Error handler + -> (a -> ReaderT Config IO a) -- ^ Success handler + -> Config -- ^ Hapistrano deployment configuration + -> Hapistrano a -- ^ The remote command to run + -> IO a +runRC errorHandler successHandler config command = + runReaderT (eitherT errorHandler successHandler command) config + +-- | Default method to run on deploy failure. Emits a failure message +-- and exits with a status code of 1. +defaultErrorHandler :: FailureResult -> ReaderT Config IO () +defaultErrorHandler res = + liftIO $ hPutStrLn stderr + ("Deploy failed with (status, message): " ++ show res) + >> exitWith (ExitFailure 1) + +-- | Default method to run on deploy success. +defaultSuccessHandler :: a -> ReaderT Config IO () +defaultSuccessHandler _ = + liftIO $ putStrLn "Deploy completed successfully." + + +-- | Creates necessary directories for the hapistrano project. Should +-- only need to run the first time the project is deployed on a given +-- system. +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 + +-- | Runs the given command either locally or on the local machine. +runCommand :: Maybe String -- ^ The host on which to run the command + -> String -- ^ The command to run, either on the local or remote host + -> 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) + +-- | Returns a timestamp in the default format for build directories. +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" + +-- | Returns the FilePath pointed to by the current symlink. +readCurrentLink :: Hapistrano FilePath -- ^ The target of the symlink in the Hapistrano monad +readCurrentLink = do + conf <- ask + runCommand (host conf) $ "readlink " ++ currentPath (deployPath conf) + +-- ^ Trims any newlines from the given String +trim :: String -- ^ String to have trailing newlines stripped + -> String -- ^ String with trailing newlines removed +trim = reverse . dropWhile (== '\n') . reverse + +-- | Ensure that the initial bare repo exists in the repo directory. Idempotent. +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 + +-- | Returns the full path of the folder containing all of the release builds. +releasesPath :: Config -> FilePath +releasesPath conf = joinPath [deployPath conf, "releases"] + +-- | Figures out the most recent release if possible. +detectPrevious :: [String] -- ^ The releases in `releases` path + -> Hapistrano String -- ^ The previous release in the Hapistrano monad +detectPrevious rs = + case biggest rs of + Nothing -> left (1, "No previous releases detected!") + Just rls -> right rls + +-- | Activates the previous detected release. +rollback :: Hapistrano String -- ^ The current Release in the Hapistrano monad +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. Returns the +-- timestamp of the release that we cloned to. +cloneToRelease :: Hapistrano Release -- ^ The newly-cloned Release, in the Hapistrano monad +cloneToRelease = do + conf <- ask + rls <- liftIO $ currentTimestamp (releaseFormat conf) + + void $ runCommand (host conf) $ "git clone " ++ cacheRepoPath conf ++ + " " ++ joinPath [ releasesPath conf, rls ] + + return rls + + +-- | Returns the full path to the git repo used for cache purposes on the +-- target host filesystem. +cacheRepoPath :: Config -- ^ The Hapistrano configuration + -> FilePath -- ^ The full path to the git cache repo used for speeding up deploys +cacheRepoPath conf = joinPath [deployPath conf, "repo"] + +-- | Returns the full path to the current symlink. +currentPath :: FilePath -- ^ The full path of the deploy folder root + -> FilePath -- ^ The full path to the `current` symlink +currentPath depPath = joinPath [depPath, "current"] + +-- | Take the release timestamp from the end of a filepath. +pathToRelease :: FilePath -- ^ The entire FilePath to a Release directory + -> Release -- ^ The Release number. +pathToRelease = last . splitPath + +-- | Returns a list of Strings representing the currently deployed releases. +releases :: Hapistrano [Release] -- ^ A list of all found Releases on the target host +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] -- ^ All non-current releases on the target host +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] + +-- | 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 -> [Release] -> [FilePath] +oldReleases conf rs = map mergePath toDelete + where sorted = sortBy (flip compare) rs + toDelete = drop 4 sorted + mergePath = releasePath conf + +-- | Removes releases older than the last five to avoid filling up the target +-- host filesystem. +cleanReleases :: Hapistrano [String] -- ^ Deleted Release directories +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 + +-- | Returns a Bool indicating if the given String is in the proper release +-- format. +isReleaseString :: ReleaseFormat -- ^ Format of Release directories + -> String -- ^ String to check against Release format + -> Bool -- ^ Whether the given String adheres to the specified Release format +isReleaseString format s = all isNumber s && length s == releaseLength + where releaseLength = case format of + Short -> 14 + Long -> 26 + +-- | Creates the git repository that is used on the target host for +-- cache purposes. +createCacheRepo :: Hapistrano String -- ^ Output of the git command used to create the bare cache repo +createCacheRepo = do + conf <- ask + + runCommand (host conf) $ "git clone --bare " ++ repository conf ++ " " ++ + cacheRepoPath conf + +-- | Returns the full path of the symlink pointing to the current +-- release. +currentSymlinkPath :: Config -> FilePath +currentSymlinkPath conf = joinPath [deployPath conf, "current"] + +currentTempSymlinkPath :: Config -> FilePath +currentTempSymlinkPath conf = joinPath [deployPath conf, "current_tmp"] + +-- | Removes the current symlink in preparation for a new release being +-- activated. +removeCurrentSymlink :: Hapistrano () +removeCurrentSymlink = do + conf <- ask + + void $ runCommand (host conf) $ "rm -rf " ++ currentSymlinkPath conf + +-- | Determines whether the target host OS is Linux +targetIsLinux :: Hapistrano Bool +targetIsLinux = do + conf <- ask + res <- runCommand (host conf) "uname" + + right $ "Linux" `isInfixOf` res + +-- | Runs a command to restart a server if a command is provided. +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 + +-- | Runs a build script if one is provided. +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 + +-- | 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 current release. +lnCommand :: + String -- ^ The path of the new release + -> String -- ^ The temporary symlink target for the release + -> String -- ^ A command to create the temporary symlink +lnCommand rlsPath symlinkPath = unwords ["ln -s", rlsPath, symlinkPath] + +-- | Creates a symlink to the directory indicated by the release timestamp. +-- hapistrano does this by creating a temporary symlink and doing an atomic +-- mv (1) operation to activate the new release. +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 ] + + +-- | Updates the git repo used as a cache in the target host filesystem. +updateCacheRepo :: Hapistrano () +updateCacheRepo = do + conf <- ask + + void $ runCommand (host conf) $ intercalate " && " + [ "cd " ++ cacheRepoPath conf + , "git fetch origin +refs/heads/*:refs/heads/*" ] + +-- | Sets the release to the correct revision by resetting the +-- head of the git repo. +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 + +-- | Returns a command that builds this application. Sets the context +-- of the build by switching to the release directory before running +-- the script. +buildRelease :: Release -- ^ The Release to build + -> [String] -- ^ Commands to be run. List intercalated + -- with "&&" so that failure aborts the + -- sequence. + -> Hapistrano () +buildRelease rel commands = do + conf <- ask + let cdCmd = "cd " ++ releasePath conf rel + void $ runCommand (host conf) $ intercalate " && " $ cdCmd : commands + + +-- | A safe version of the `maximum` function in Data.List. +biggest :: Ord a => [a] -> Maybe a +biggest rls = + case sortBy (flip compare) rls of + [] -> Nothing + r:_ -> Just r diff --git a/src/System/Hapistrano/Types.hs b/src/System/Hapistrano/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Hapistrano/Types.hs @@ -0,0 +1,49 @@ +module System.Hapistrano.Types + ( Config(..) + , FailureResult + , Hapistrano + , Release + , ReleaseFormat(..) + ) where + +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.Trans.Either (EitherT(..)) + +-- | Config stuff that will be replaced by config file reading +data Config = + Config { deployPath :: String + -- ^ The root of the deploy target on the remote host + + , repository :: String -- ^ The remote git repo + , revision :: String -- ^ A SHA1 or branch to release + + , releaseFormat :: ReleaseFormat + , host :: Maybe String + -- ^ The target host for the deploy, or Nothing to indicate that + -- operations should be done directly in the local deployPath without + -- going over SSH + + , buildScript :: Maybe FilePath + -- ^ The local path to a file that should be executed on the remote + -- server to build the application. + + , restartCommand :: Maybe String + -- ^ Optional command to restart the server after a successful deploy + + } deriving (Show) + +data ReleaseFormat = Short + -- ^ Standard release path following Capistrano's format + + | Long + -- ^ Long release path including picoseconds for testing + -- or people seriously into continuous deployment + + deriving (Show) + + +type Release = String + +type FailureResult = (Int, String) + +type Hapistrano a = EitherT FailureResult (ReaderT Config IO) a