mirror of
https://github.com/stackbuilders/hapistrano.git
synced 2024-12-23 11:32:09 +03:00
Refactoring and test additions
This commit is contained in:
Justin Leitgeb
parent
d531e5dfd7
commit
2653d984bb
@ -1,9 +1,15 @@
|
||||
name: hapistrano
|
||||
version: 0.1.0.2
|
||||
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.
|
||||
.
|
||||
Following popular libraries like Ruby's <http://capistranorb.com/ Capistrano>,
|
||||
Hapistrano simply creates a new sandbox, installs dependencies, builds, and
|
||||
then symlinks to the new build directory when installation is done.
|
||||
.
|
||||
This process makes deploy atomic, without allowing for dependency problems.
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Justin Leitgeb
|
||||
@ -22,28 +28,52 @@ executable hap
|
||||
, process
|
||||
, either
|
||||
, transformers
|
||||
, lens >= 4.1
|
||||
, mtl
|
||||
, filepath
|
||||
, either
|
||||
, base-compat
|
||||
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
||||
library
|
||||
exposed-modules: Hapistrano
|
||||
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
|
||||
|
||||
1
spec/Spec.hs
Normal file
1
spec/Spec.hs
Normal file
@ -0,0 +1 @@
|
||||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
141
spec/System/HapistranoSpec.hs
Normal file
141
spec/System/HapistranoSpec.hs
Normal file
@ -0,0 +1,141 @@
|
||||
module System.HapistranoSpec (spec) where
|
||||
|
||||
import Test.Hspec (it, describe, shouldBe, Spec)
|
||||
|
||||
import System.IO.Temp (withSystemTempDirectory)
|
||||
|
||||
import System.Directory (getDirectoryContents)
|
||||
import Control.Monad (void, replicateM_)
|
||||
import System.FilePath.Posix (joinPath)
|
||||
|
||||
import qualified System.Hapistrano as Hap
|
||||
import System.Hapistrano.Types
|
||||
import Data.List (sort)
|
||||
|
||||
rollback :: HapistranoState -> IO ()
|
||||
rollback cfg =
|
||||
Hap.runRC errorHandler successHandler cfg $ do
|
||||
|
||||
_ <- Hap.rollback
|
||||
void Hap.restartServerCommand
|
||||
|
||||
where
|
||||
errorHandler = Hap.defaultErrorHandler
|
||||
successHandler = Hap.defaultSuccessHandler
|
||||
|
||||
|
||||
-- | Deploys the current release with Config options.
|
||||
deployOnly :: HapistranoState -> IO ()
|
||||
deployOnly cfg =
|
||||
Hap.runRC errorHandler successHandler cfg $ void Hap.pushRelease
|
||||
|
||||
where
|
||||
errorHandler = Hap.defaultErrorHandler
|
||||
successHandler = Hap.defaultSuccessHandler
|
||||
|
||||
-- | Deploys the current release with Config options.
|
||||
deployAndActivate :: HapistranoState -> IO ()
|
||||
deployAndActivate cfg =
|
||||
Hap.runRC errorHandler successHandler cfg $ do
|
||||
_ <- Hap.pushRelease
|
||||
_ <- Hap.runBuild
|
||||
|
||||
void Hap.activateRelease
|
||||
|
||||
where
|
||||
errorHandler = Hap.defaultErrorHandler
|
||||
successHandler = Hap.defaultSuccessHandler
|
||||
|
||||
defaultState :: FilePath -> HapistranoState
|
||||
defaultState tmpDir = Hap.initialState
|
||||
Hap.Config { Hap.deployPath = tmpDir
|
||||
, Hap.host = Nothing
|
||||
, Hap.repository =
|
||||
"https://github.com/stackbuilders/atomic-write.git"
|
||||
|
||||
, Hap.releaseFormat = Long
|
||||
, Hap.revision = "master"
|
||||
, Hap.buildScript = Nothing
|
||||
, Hap.restartCommand = Nothing
|
||||
}
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "hapistrano" $ do
|
||||
describe "readCurrentLink" $
|
||||
it "trims trailing whitespace" $
|
||||
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
|
||||
|
||||
deployAndActivate (defaultState tmpDir)
|
||||
|
||||
ltarget <- Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
|
||||
|
||||
last ltarget /= '\n' `shouldBe` True
|
||||
|
||||
describe "deploying" $ do
|
||||
it "a simple deploy" $
|
||||
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
|
||||
|
||||
deployOnly (defaultState tmpDir)
|
||||
|
||||
contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
|
||||
length (filter (Hap.isReleaseString Long) contents) `shouldBe` 1
|
||||
|
||||
it "activates the release" $
|
||||
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
|
||||
|
||||
deployAndActivate (defaultState tmpDir)
|
||||
|
||||
contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
|
||||
length (filter (Hap.isReleaseString Long) contents) `shouldBe` 1
|
||||
|
||||
it "cleans up old releases" $
|
||||
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
|
||||
|
||||
replicateM_ 7 $ deployAndActivate (defaultState tmpDir)
|
||||
|
||||
contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
|
||||
length (filter (Hap.isReleaseString Long) contents) `shouldBe` 5
|
||||
|
||||
describe "rollback" $
|
||||
it "rolls back to the previous release" $
|
||||
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
|
||||
|
||||
let deployState = defaultState tmpDir
|
||||
|
||||
deployAndActivate deployState
|
||||
|
||||
-- current symlink should point to the last release directory
|
||||
contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
|
||||
|
||||
let firstRelease = head $ filter (Hap.isReleaseString Long) contents
|
||||
|
||||
firstReleaseLinkTarget <-
|
||||
Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
|
||||
|
||||
putStrLn $ "the first: " ++ show firstReleaseLinkTarget
|
||||
firstRelease `shouldBe` Hap.pathToRelease firstReleaseLinkTarget
|
||||
|
||||
-- deploy a second version
|
||||
deployAndActivate deployState
|
||||
|
||||
-- current symlink should point to second release
|
||||
|
||||
conts <- getDirectoryContents (joinPath [tmpDir, "releases"])
|
||||
|
||||
let secondRelease =
|
||||
sort (filter (Hap.isReleaseString Long) conts) !! 1
|
||||
|
||||
secondReleaseLinkTarget <-
|
||||
Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
|
||||
|
||||
secondRelease `shouldBe` Hap.pathToRelease secondReleaseLinkTarget
|
||||
|
||||
-- roll back, and current symlink should point to first release again
|
||||
|
||||
|
||||
rollback deployState
|
||||
|
||||
afterRollbackLinkTarget <-
|
||||
Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
|
||||
|
||||
Hap.pathToRelease afterRollbackLinkTarget `shouldBe` firstRelease
|
||||
@ -1,70 +1,55 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- | A module for easily creating reliable deploy processes for Haskell
|
||||
-- applications.
|
||||
module Hapistrano
|
||||
(
|
||||
Config(..)
|
||||
, initialState
|
||||
, runRC
|
||||
module System.Hapistrano
|
||||
( Config(..)
|
||||
|
||||
, activateRelease
|
||||
, runBuild
|
||||
, currentPath
|
||||
, defaultSuccessHandler
|
||||
, defaultErrorHandler
|
||||
, directoryExists
|
||||
, initialState
|
||||
, isReleaseString
|
||||
, pathToRelease
|
||||
, pushRelease
|
||||
, readCurrentLink
|
||||
, restartServerCommand
|
||||
, rollback
|
||||
, runRC
|
||||
, runBuild
|
||||
|
||||
) where
|
||||
|
||||
import Control.Lens (makeLenses, use, (^.), (.=))
|
||||
import Control.Monad (unless)
|
||||
import System.Hapistrano.Types (
|
||||
Config(..), HapistranoState(..), RC, Release, ReleaseFormat(..))
|
||||
|
||||
import Control.Monad (unless, void)
|
||||
import System.Exit (ExitCode(..), exitWith)
|
||||
|
||||
import Control.Monad.State.Lazy (gets, put)
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO(liftIO))
|
||||
import Control.Monad.Trans.State (StateT, evalStateT, get)
|
||||
import Control.Monad.Trans.State (evalStateT, get)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Either ( EitherT(..)
|
||||
, left
|
||||
import Control.Monad.Trans.Either ( left
|
||||
, right
|
||||
, runEitherT
|
||||
, eitherT )
|
||||
|
||||
import Data.Char (isNumber)
|
||||
import Data.List (intercalate, sortBy, sort, isInfixOf)
|
||||
import Data.List (intercalate, sortBy, 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 :: RC ()
|
||||
pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
|
||||
cleanReleases >> cloneToRelease >> setReleaseRevision
|
||||
|
||||
@ -73,11 +58,10 @@ pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
|
||||
activateRelease :: RC (Maybe String)
|
||||
activateRelease = removeCurrentSymlink >> symlinkCurrent
|
||||
|
||||
|
||||
-- | Returns an initial state for the deploy.
|
||||
initialState :: Config -> HapistranoState
|
||||
initialState cfg = HapistranoState { _config = cfg
|
||||
, _timestamp = Nothing
|
||||
initialState cfg = HapistranoState { config = cfg
|
||||
, timestamp = Nothing
|
||||
}
|
||||
|
||||
-- | Given a pair of actions, one to perform in case of failure, and
|
||||
@ -93,10 +77,13 @@ runRC errorHandler successHandler initState remoteCmd =
|
||||
successHandler
|
||||
(evalStateT remoteCmd initState)
|
||||
|
||||
-- | Default method to run on deploy failure. Emits a failure message
|
||||
-- and exits with a status code of 1.
|
||||
defaultErrorHandler :: (Int, Maybe String) -> IO ()
|
||||
defaultErrorHandler _ =
|
||||
hPutStrLn stderr "Deploy failed." >> exitWith (ExitFailure 1)
|
||||
|
||||
-- | Default method to run on deploy success.
|
||||
defaultSuccessHandler :: a -> IO ()
|
||||
defaultSuccessHandler _ = putStrLn "Deploy completed successfully."
|
||||
|
||||
@ -104,19 +91,52 @@ 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 :: RC ()
|
||||
setupDirs = do
|
||||
conf <- use config
|
||||
conf <- gets config
|
||||
|
||||
remoteCommand $ intercalate " && "
|
||||
[ "mkdir -p " ++ releasesPath conf
|
||||
, "mkdir -p " ++ cacheRepoPath conf
|
||||
]
|
||||
mapM_ (runCommand (host conf))
|
||||
["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
|
||||
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
|
||||
-> RC (Maybe String)
|
||||
|
||||
runCommand Nothing command = do
|
||||
liftIO $ putStrLn $ "Going to execute " ++ command ++ " locally."
|
||||
|
||||
let (cmd, args) = (head (words command), tail (words command))
|
||||
|
||||
(code, stdout, err) <- liftIO $ readProcessWithExitCode cmd args ""
|
||||
|
||||
case code of
|
||||
ExitSuccess -> do
|
||||
liftIO $
|
||||
putStrLn $ "Command '" ++ command ++ "' was successful on local host."
|
||||
|
||||
unless (null stdout) (liftIO $ putStrLn $ "Output:\n" ++ stdout)
|
||||
|
||||
lift $ right $ maybeString stdout
|
||||
|
||||
ExitFailure int -> do
|
||||
let maybeError = maybeString err
|
||||
liftIO $ printCommandError "localhost" command (int, maybeError)
|
||||
lift $ left (int, maybeError)
|
||||
|
||||
runCommand (Just server) command = do
|
||||
liftIO $ putStrLn $ "Going to execute " ++ command ++ " on host " ++ server
|
||||
++ "."
|
||||
|
||||
@ -137,11 +157,16 @@ remoteCommand command = do
|
||||
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
|
||||
currentTimestamp :: ReleaseFormat -> IO String
|
||||
currentTimestamp format = do
|
||||
curTime <- getCurrentTime
|
||||
return $ formatTime defaultTimeLocale "%Y%m%d%H%M%S" curTime
|
||||
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"
|
||||
|
||||
echoMessage :: String -> RC (Maybe String)
|
||||
echoMessage msg = do
|
||||
@ -157,25 +182,30 @@ printCommandError server cmd (errCode, Just errMsg) =
|
||||
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
|
||||
readCurrentLink :: Maybe String -> FilePath -> IO FilePath
|
||||
readCurrentLink hst path = do
|
||||
let (command, args) = case hst of
|
||||
Just h -> ("ssh", [h, "readlink", path])
|
||||
Nothing -> ("readlink", [path])
|
||||
|
||||
(code, stdout, _) <- readProcessWithExitCode command args ""
|
||||
|
||||
case (code, stdout) of
|
||||
(ExitSuccess, out) -> return $ trim out
|
||||
(ExitFailure _, _) -> error "Unable to read current symlink"
|
||||
|
||||
where trim = reverse . dropWhile (=='\n') . reverse
|
||||
|
||||
-- | 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
|
||||
conf <- gets config
|
||||
res <- liftIO $ directoryExists (host conf) $ joinPath [cacheRepoPath conf, "refs"]
|
||||
|
||||
case res of
|
||||
Nothing -> createCacheRepo
|
||||
Just _ -> lift $ right $ Just "Repo already existed"
|
||||
if res
|
||||
then lift $ right $ Just "Repo already existed"
|
||||
else createCacheRepo
|
||||
|
||||
-- | Returns a Just String or Nothing based on whether the input is null or
|
||||
-- has contents.
|
||||
@ -185,7 +215,7 @@ maybeString possibleString =
|
||||
|
||||
-- | Returns the full path of the folder containing all of the release builds.
|
||||
releasesPath :: Config -> FilePath
|
||||
releasesPath conf = joinPath [conf ^. deployPath, "releases"]
|
||||
releasesPath conf = joinPath [deployPath conf, "releases"]
|
||||
|
||||
-- | Figures out the most recent release if possible, and sets the
|
||||
-- StateT monad with the correct timestamp. This function is used
|
||||
@ -193,10 +223,12 @@ releasesPath conf = joinPath [conf ^. deployPath, "releases"]
|
||||
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
|
||||
conf <- get
|
||||
_ <- put $ conf { timestamp = mostRecentRls }
|
||||
lift $ right $ Just rls
|
||||
|
||||
-- | Activates the previous detected release.
|
||||
@ -207,29 +239,29 @@ rollback = previousReleases >>= detectPrevious >> activateRelease
|
||||
-- timestamp if one doesn't yet exist in the HapistranoState.
|
||||
cloneToRelease :: RC (Maybe String)
|
||||
cloneToRelease = do
|
||||
conf <- use config
|
||||
releaseTimestamp <- use timestamp
|
||||
hs <- get
|
||||
conf <- gets config
|
||||
|
||||
rls <- case releaseTimestamp of
|
||||
rls <- case timestamp hs of
|
||||
Nothing -> do
|
||||
ts <- liftIO currentTimestamp
|
||||
timestamp .= Just ts
|
||||
ts <- liftIO $ currentTimestamp (releaseFormat conf)
|
||||
_ <- put $ hs { timestamp = Just ts }
|
||||
return ts
|
||||
|
||||
Just r -> return r
|
||||
|
||||
remoteCommand $ "git clone " ++ cacheRepoPath conf ++ " " ++
|
||||
joinPath [ releasesPath conf, rls ]
|
||||
runCommand (host conf) $ "git clone " ++ cacheRepoPath (config hs) ++
|
||||
" " ++ joinPath [ releasesPath (config hs), 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"]
|
||||
cacheRepoPath conf = joinPath [deployPath conf, "repo"]
|
||||
|
||||
-- | Returns the full path to the current symlink.
|
||||
currentPath :: Config -> FilePath
|
||||
currentPath conf = joinPath [conf ^. deployPath, "current"]
|
||||
currentPath :: FilePath -> FilePath
|
||||
currentPath depPath = joinPath [depPath, "current"]
|
||||
|
||||
-- | Take the release timestamp from the end of a filepath.
|
||||
pathToRelease :: FilePath -> Release
|
||||
@ -238,25 +270,27 @@ 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"
|
||||
conf <- gets config
|
||||
res <- runCommand (host conf) $ "find " ++ releasesPath conf ++
|
||||
" -type d -maxdepth 1"
|
||||
|
||||
case res of
|
||||
Nothing -> lift $ right []
|
||||
Just s ->
|
||||
lift $ right $ filter isReleaseString . map pathToRelease
|
||||
$ lines s
|
||||
lift $ right $
|
||||
filter (isReleaseString (releaseFormat conf)) . map pathToRelease $
|
||||
lines s
|
||||
|
||||
previousReleases :: RC [Release]
|
||||
previousReleases = do
|
||||
rls <- releases
|
||||
currentRelease <- readCurrentLink
|
||||
conf <- gets config
|
||||
|
||||
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
|
||||
currentRelease <-
|
||||
liftIO $ readCurrentLink (host conf) (currentPath (deployPath conf))
|
||||
|
||||
let currentRel = (head . lines . pathToRelease) currentRelease
|
||||
return $ filter (< currentRel) rls
|
||||
|
||||
releasePath :: Config -> Release -> FilePath
|
||||
releasePath conf rls = joinPath [releasesPath conf, rls]
|
||||
@ -274,66 +308,77 @@ oldReleases conf rs = map mergePath toDelete
|
||||
-- host filesystem.
|
||||
cleanReleases :: RC (Maybe String)
|
||||
cleanReleases = do
|
||||
conf <- use config
|
||||
conf <- gets config
|
||||
allReleases <- releases
|
||||
|
||||
case allReleases of
|
||||
[] -> echoMessage "There are no old releases to prune."
|
||||
xs -> do
|
||||
let deletable = oldReleases conf xs
|
||||
let deletable = oldReleases conf allReleases
|
||||
|
||||
remoteCommand $ "rm -rf -- " ++ foldr (\a b -> a ++ " " ++ b) ""
|
||||
deletable
|
||||
if null deletable
|
||||
then
|
||||
echoMessage "There are no old releases to prune."
|
||||
|
||||
else
|
||||
runCommand (host conf) $
|
||||
"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
|
||||
isReleaseString :: ReleaseFormat -> String -> Bool
|
||||
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 :: RC (Maybe String)
|
||||
createCacheRepo = do
|
||||
conf <- use config
|
||||
remoteCommand $ "git clone --bare " ++ conf ^. repository ++ " " ++
|
||||
conf <- gets config
|
||||
|
||||
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 [conf ^. deployPath, "current"]
|
||||
currentSymlinkPath conf = joinPath [deployPath conf, "current"]
|
||||
|
||||
currentTempSymlinkPath :: Config -> FilePath
|
||||
currentTempSymlinkPath conf = joinPath [conf ^. deployPath, "current_tmp"]
|
||||
currentTempSymlinkPath conf = joinPath [deployPath conf, "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
|
||||
conf <- gets config
|
||||
|
||||
runCommand (host conf) $ "rm -rf " ++ currentSymlinkPath conf
|
||||
|
||||
-- | Determines whether the target host OS is Linux
|
||||
remoteIsLinux :: RC Bool
|
||||
remoteIsLinux = do
|
||||
st <- get
|
||||
res <- remoteCommand "uname"
|
||||
targetIsLinux :: RC Bool
|
||||
targetIsLinux = do
|
||||
conf <- gets config
|
||||
res <- runCommand (host conf) "uname"
|
||||
|
||||
case res of
|
||||
Just output -> lift $ right $ "Linux" `isInfixOf` output
|
||||
_ -> lift $ left (1, Just "Unable to determine remote host type")
|
||||
|
||||
-- | Runs a command to restart a server if a command is provided.
|
||||
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
|
||||
conf <- gets config
|
||||
|
||||
case restartCommand conf of
|
||||
Nothing -> return $ Just "No command given for restart action."
|
||||
Just cmd -> runCommand (host conf) cmd
|
||||
|
||||
-- | Runs a build script if one is provided.
|
||||
runBuild :: RC (Maybe String)
|
||||
runBuild = do
|
||||
conf <- use config
|
||||
case conf ^. buildScript of
|
||||
conf <- gets config
|
||||
|
||||
case buildScript conf of
|
||||
Nothing -> do
|
||||
liftIO $ putStrLn "No build script specified, skipping build step."
|
||||
return Nothing
|
||||
@ -344,51 +389,65 @@ runBuild = do
|
||||
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 :: 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 :: RC (Maybe String)
|
||||
symlinkCurrent = do
|
||||
conf <- use config
|
||||
releaseTimestamp <- use timestamp
|
||||
conf <- gets config
|
||||
releaseTimestamp <- gets timestamp
|
||||
|
||||
case releaseTimestamp of
|
||||
Nothing -> lift $ left (1, Just "No releases to symlink!")
|
||||
Just rls -> do
|
||||
isLnx <- remoteIsLinux
|
||||
isLnx <- targetIsLinux
|
||||
|
||||
let tmpLnCmd =
|
||||
lnCommand (releasePath conf rls) (currentTempSymlinkPath conf)
|
||||
|
||||
_ <- runCommand (host conf) $ tmpLnCmd
|
||||
|
||||
runCommand (host conf) $ unwords [ mvCommand isLnx
|
||||
, currentTempSymlinkPath conf
|
||||
, currentSymlinkPath conf ]
|
||||
|
||||
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 :: RC ()
|
||||
updateCacheRepo = do
|
||||
conf <- use config
|
||||
remoteCommand $ intercalate " && "
|
||||
conf <- gets config
|
||||
|
||||
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 :: RC (Maybe String)
|
||||
setReleaseRevision :: RC ()
|
||||
setReleaseRevision = do
|
||||
conf <- use config
|
||||
releaseTimestamp <- use timestamp
|
||||
conf <- gets config
|
||||
releaseTimestamp <- gets 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
|
||||
]
|
||||
Just rls -> do
|
||||
void $ runCommand (host conf) $ intercalate " && "
|
||||
[ "cd " ++ releasePath conf rls
|
||||
, "git fetch --all"
|
||||
, "git reset --hard " ++ revision conf
|
||||
]
|
||||
|
||||
-- | Returns a command that builds this application. Sets the context
|
||||
-- of the build by switching to the release directory before running
|
||||
@ -398,13 +457,14 @@ buildRelease :: [String] -- ^ Commands to be run. List intercalated
|
||||
-- sequence.
|
||||
-> RC (Maybe String)
|
||||
buildRelease commands = do
|
||||
conf <- use config
|
||||
releaseTimestamp <- use timestamp
|
||||
conf <- gets config
|
||||
releaseTimestamp <- gets 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
|
||||
runCommand (host conf) $ intercalate " && " $ cdCmd : commands
|
||||
|
||||
-- | A safe version of the `maximum` function in Data.List.
|
||||
biggest :: Ord a => [a] -> Maybe a
|
||||
46
src/System/Hapistrano/Types.hs
Normal file
46
src/System/Hapistrano/Types.hs
Normal file
@ -0,0 +1,46 @@
|
||||
module System.Hapistrano.Types
|
||||
( Config(..)
|
||||
, HapistranoState(..)
|
||||
, RC
|
||||
, Release
|
||||
, ReleaseFormat(..)
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.State (StateT)
|
||||
|
||||
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
|
||||
| Long -- ^ Long release path including picoseconds for testing or people seriously into continuous deployment
|
||||
deriving (Show)
|
||||
|
||||
data HapistranoState = HapistranoState { config :: Config
|
||||
, timestamp :: Maybe String
|
||||
} deriving Show
|
||||
|
||||
type Release = String
|
||||
|
||||
type RC a = StateT HapistranoState (EitherT (Int, Maybe String) IO) a
|
||||
Loading…
Reference in New Issue
Block a user