hapistrano (empty) → 0.1.0.0
raw patch · 5 files changed
+544/−0 lines, 5 filesdep +basedep +eitherdep +filepathsetup-changed
Dependencies added: base, either, filepath, lens, old-locale, process, time, transformers
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- hapistrano.cabal +43/−0
- src/Hapistrano.hs +407/−0
- src/Main.hs +72/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Stack Builders Inc.++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hapistrano.cabal view
@@ -0,0 +1,43 @@+name: hapistrano+version: 0.1.0.0+synopsis: A deployment library for Haskell applications+description: Hapistrano makes it easy to reliably deploy Haskell+ applications.++license: MIT+license-file: LICENSE+author: Justin Leitgeb+maintainer: justin@stackbuilders.com+copyright: 2014 Stack Builders Inc.+category: System+build-type: Simple+cabal-version: >=1.10++executable hap+ main-is: Main.hs+ hs-source-dirs: src+ build-depends: base >=4.6 && <4.8+ , time+ , old-locale+ , process+ , either+ , transformers+ , lens >= 4.1+ , filepath+ , either+ default-language: Haskell2010++library+ exposed-modules: Hapistrano+ build-depends: base >=4.6 && <4.8+ , time+ , old-locale+ , process+ , either+ , transformers+ , lens >= 4.1+ , filepath+ , either++ hs-source-dirs: src+ default-language: Haskell2010
+ src/Hapistrano.hs view
@@ -0,0 +1,407 @@+{-# 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 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++-- | 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 _ = putStrLn "Deploy failed."++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+ pathName <- use $ config . deployPath+ remoteCommand $ "mkdir -p " ++ joinPath [pathName, "releases"]++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 " ++ 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++-- | 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
+ src/Main.hs view
@@ -0,0 +1,72 @@+module Main where++import qualified Hapistrano as Hap+import Control.Monad (void)+import System.Environment (getArgs, getEnv, lookupEnv)+import System.IO (hPutStrLn, stderr)+import System.Exit (exitFailure, exitSuccess)+import Control.Applicative ((<$>))+import Control.Monad.IO.Class (MonadIO(liftIO))++-- | Rolls back to previous release.+rollback :: Hap.Config -> IO ()+rollback cfg =+ Hap.runRC errorHandler successHandler (Hap.initialState cfg) $ do++ Hap.rollback+ void Hap.restartServerCommand++ where+ errorHandler = Hap.defaultErrorHandler+ successHandler = Hap.defaultSuccessHandler++-- | 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++ void Hap.restartServerCommand++ where+ errorHandler = Hap.defaultErrorHandler+ successHandler = Hap.defaultSuccessHandler++-- | 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"+ 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+ }++main :: IO ()+main = do+ args <- getArgs+ case args of+ [] -> do+ hPutStrLn stderr+ "First argument must be either 'deploy' or 'rollback'."+ exitFailure++ arg1:_ -> do+ cfg <- configFromEnv++ case arg1 of+ "deploy" -> deploy cfg+ "rollback" -> rollback cfg+ _ -> do+ hPutStrLn stderr $ "Invalid argument: " ++ arg1+ exitFailure