diff --git a/hapistrano.cabal b/hapistrano.cabal index b3f889a..034722a 100644 --- a/hapistrano.cabal +++ b/hapistrano.cabal @@ -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 , + 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 diff --git a/spec/Spec.hs b/spec/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/spec/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/spec/System/HapistranoSpec.hs b/spec/System/HapistranoSpec.hs new file mode 100644 index 0000000..6597985 --- /dev/null +++ b/spec/System/HapistranoSpec.hs @@ -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 diff --git a/src/Hapistrano.hs b/src/System/Hapistrano.hs similarity index 57% rename from src/Hapistrano.hs rename to src/System/Hapistrano.hs index 60f4944..0e06f85 100644 --- a/src/Hapistrano.hs +++ b/src/System/Hapistrano.hs @@ -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 diff --git a/src/System/Hapistrano/Types.hs b/src/System/Hapistrano/Types.hs new file mode 100644 index 0000000..7a8e6d2 --- /dev/null +++ b/src/System/Hapistrano/Types.hs @@ -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