hapistrano 0.2.0.2 → 0.2.1
raw patch · 5 files changed
+328/−127 lines, 5 filesdep +hapistranodep −old-localedep ~basenew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: hapistrano
Dependencies removed: old-locale
Dependency ranges changed: base
API changes (from Hackage documentation)
+ System.Hapistrano: Long :: ReleaseFormat
+ System.Hapistrano: Short :: ReleaseFormat
+ System.Hapistrano: data ReleaseFormat
Files
- app/Main.hs +74/−0
- hapistrano.cabal +35/−52
- spec/System/HapistranoSpec.hs +195/−0
- src/Main.hs +0/−74
- src/System/Hapistrano.hs +24/−1
+ app/Main.hs view
@@ -0,0 +1,74 @@+module Main where++import qualified System.Hapistrano as Hap+import Control.Monad (void)+import System.Environment (getArgs, getEnv)+import System.Environment.Compat (lookupEnv)+import System.IO (hPutStrLn, stderr)+import System.Exit (exitFailure)++import System.Hapistrano (ReleaseFormat(..))++-- | Rolls back to previous release.+rollback :: Hap.Config -> 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.+deploy :: Hap.Config -> IO ()+deploy cfg =+ Hap.runRC errorHandler successHandler 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"+ 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.releaseFormat = Short+ , 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
hapistrano.cabal view
@@ -1,5 +1,5 @@ name: hapistrano-version: 0.2.0.2+version: 0.2.1 synopsis: A deployment library for Haskell applications description: .@@ -24,68 +24,51 @@ maintainer: justin@stackbuilders.com copyright: 2015 Stack Builders Inc. category: System-Homepage: https://github.com/stackbuilders/hapistrano-Bug-reports: https://github.com/stackbuilders/hapistrano/issues+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.5 && <4.9- , time-locale-compat- , time- , old-locale- , process- , either- , transformers- , mtl- , filepath- , base-compat-- default-language: Haskell2010- ghc-options: -Wall- library+ hs-source-dirs: src exposed-modules: System.Hapistrano other-modules: System.Hapistrano.Types-- build-depends: base >=4.5 && <4.9- , time-locale-compat- , time- , old-locale- , process- , either- , transformers- , mtl- , filepath- , base-compat+ build-depends: base >=4.5 && <4.9+ , either+ , filepath+ , mtl+ , process+ , time-locale-compat+ , time+ , transformers+ ghc-options: -Wall+ default-language: Haskell2010 - hs-source-dirs: src+executable hap+ hs-source-dirs: app+ main-is: Main.hs+ build-depends: base+ , hapistrano+ , base-compat+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 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.9- , time-locale-compat- , time- , old-locale- , process- , either- , transformers- , mtl- , filepath- , base-compat- , hspec- , temporary- , directory-+ type: exitcode-stdio-1.0+ hs-source-dirs: spec+ main-is: Spec.hs+ other-modules: System.HapistranoSpec+ build-depends: base+ , hapistrano+ , directory+ , either+ , filepath+ , hspec+ , mtl+ , process+ , temporary+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010- ghc-options: -Wall source-repository head type: git
+ spec/System/HapistranoSpec.hs view
@@ -0,0 +1,195 @@+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 Control.Monad.Trans.Either (runEitherT)++import Control.Monad.Reader (ReaderT(..))++import System.FilePath.Posix (joinPath)++import qualified System.Hapistrano as Hap+import Data.List (sort)++import qualified System.IO as IO+import qualified System.Process as Process++runCommand :: String -> IO ()+runCommand command = do+ putStrLn ("GIT running: " ++ command)+ let process = Process.shell command+ (_, Just outHandle, Just errHandle, processHandle) <-+ Process.createProcess process { Process.std_err = Process.CreatePipe+ , Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ }+ exitCode <- fmap show (Process.waitForProcess processHandle)+ out <- IO.hGetContents outHandle+ err <- IO.hGetContents errHandle+ putStrLn ("GIT res: " ++ show (exitCode, out, err))++-- | Generate a source git repo as test fixture. Push an initial commit+-- to the bare repo by making a clone and committing a trivial change and+-- pushing to the bare repo.+genSourceRepo :: FilePath -> IO FilePath+genSourceRepo path = do+ let fullRepoPath = joinPath [path, "testRepo"]+ clonePath = joinPath [path, "testRepoClone"]++ commands =+ [ "mkdir -p " ++ fullRepoPath+ , "git init --bare " ++ fullRepoPath+ , "git clone " ++ fullRepoPath ++ " " ++ clonePath+ , "echo testing > " ++ joinPath [clonePath, "README"]+ , "cd " ++ clonePath ++ " && git add -A"+ , "cd " ++ clonePath ++ " && git commit -m\"First commit\""+ , "cd " ++ clonePath ++ " && git push"+ ]++ mapM_ runCommand commands++ return fullRepoPath++rollback :: Hap.Config -> 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 :: Hap.Config -> 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 :: Hap.Config -> IO ()+deployAndActivate cfg =+ Hap.runRC errorHandler successHandler cfg $ do+ rel <- Hap.pushRelease+ _ <- Hap.runBuild rel++ void $ Hap.activateRelease rel++ where+ errorHandler = Hap.defaultErrorHandler+ successHandler = Hap.defaultSuccessHandler++defaultState :: FilePath -> FilePath -> Hap.Config+defaultState tmpDir testRepo =+ Hap.Config { Hap.deployPath = tmpDir+ , Hap.host = Nothing+ , Hap.repository = testRepo+ , Hap.releaseFormat = Hap.Long+ , Hap.revision = "master"+ , Hap.buildScript = Nothing+ , Hap.restartCommand = Nothing+ }++-- | The 'fromRight' function extracts the element out of a 'Right' and+-- throws an error if its argument take the form @Left _@.+fromRight :: Either a b -> b+fromRight (Left _) = error "fromRight: Argument takes form 'Left _'" -- yuck+fromRight (Right x) = x++spec :: Spec+spec = describe "hapistrano" $ do+ describe "readCurrentLink" $+ it "trims trailing whitespace" $+ withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do++ testRepoPath <- genSourceRepo tmpDir++ deployAndActivate $ defaultState tmpDir testRepoPath++ ltarget <-+ runReaderT (runEitherT Hap.readCurrentLink) $+ defaultState tmpDir testRepoPath++ last (fromRight ltarget) /= '\n' `shouldBe` True++ describe "deploying" $ do+ it "a simple deploy" $+ withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do++ testRepoPath <- genSourceRepo tmpDir++ deployOnly $ defaultState tmpDir testRepoPath++ contents <- getDirectoryContents (joinPath [tmpDir, "releases"])+ length (filter (Hap.isReleaseString Hap.Long) contents) `shouldBe` 1++ it "activates the release" $+ withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do++ testRepoPath <- genSourceRepo tmpDir++ deployAndActivate $ defaultState tmpDir testRepoPath++ contents <- getDirectoryContents (joinPath [tmpDir, "releases"])+ length (filter (Hap.isReleaseString Hap.Long) contents) `shouldBe` 1++ it "cleans up old releases" $+ withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do+ testRepoPath <- genSourceRepo tmpDir++ replicateM_ 7 $ deployAndActivate $ defaultState tmpDir testRepoPath++ contents <- getDirectoryContents (joinPath [tmpDir, "releases"])+ length (filter (Hap.isReleaseString Hap.Long) contents) `shouldBe` 5++ describe "rollback" $+ it "rolls back to the previous release" $+ withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do++ testRepoPath <- genSourceRepo tmpDir+ let deployState = defaultState tmpDir testRepoPath++ deployAndActivate deployState++ -- current symlink should point to the last release directory+ contents <- getDirectoryContents (joinPath [tmpDir, "releases"])++ let firstRelease = head $ filter (Hap.isReleaseString Hap.Long) contents++ firstReleaseLinkTarget <-+ runReaderT (runEitherT Hap.readCurrentLink) deployState++ firstRelease `shouldBe` Hap.pathToRelease (fromRight 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 Hap.Long) conts) !! 1++ secondReleaseLinkTarget <-+ runReaderT (runEitherT Hap.readCurrentLink) deployState++ secondRelease `shouldBe` Hap.pathToRelease (fromRight secondReleaseLinkTarget)++ -- roll back, and current symlink should point to first release again++ rollback deployState++ afterRollbackLinkTarget <-+ runReaderT (runEitherT Hap.readCurrentLink) deployState++ Hap.pathToRelease (fromRight afterRollbackLinkTarget) `shouldBe` firstRelease
− src/Main.hs
@@ -1,74 +0,0 @@-module Main where--import qualified System.Hapistrano as Hap-import Control.Monad (void)-import System.Environment (getArgs, getEnv)-import System.Environment.Compat (lookupEnv)-import System.IO (hPutStrLn, stderr)-import System.Exit (exitFailure)--import System.Hapistrano.Types (ReleaseFormat(..))---- | Rolls back to previous release.-rollback :: Hap.Config -> 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.-deploy :: Hap.Config -> IO ()-deploy cfg =- Hap.runRC errorHandler successHandler 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"- 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.releaseFormat = Short- , 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
src/System/Hapistrano.hs view
@@ -4,6 +4,7 @@ -- applications. module System.Hapistrano ( Config(..)+ , ReleaseFormat(..) , activateRelease , currentPath@@ -44,6 +45,9 @@ import System.IO (hPutStrLn, stderr) import System.Process (readProcessWithExitCode) +import qualified System.IO as IO+import qualified System.Process as Process+ -- | 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.@@ -106,10 +110,29 @@ -> String -- ^ The command to run, either on the local or remote host -> Hapistrano String -runCommand Nothing command = execCommand command+runCommand Nothing command = execShellCommand command runCommand (Just server) command = execCommand $ unwords ["ssh", server, command] +execShellCommand :: String -> Hapistrano String+execShellCommand command = do+ liftIO $ putStrLn ("Executing: " ++ command)+ let process = Process.shell command+ (_, Just outHandle, Just errHandle, processHandle) <-+ liftIO $+ Process.createProcess process { Process.std_err = Process.CreatePipe+ , Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ }+ exitCode <- liftIO $ Process.waitForProcess processHandle+ case exitCode of+ ExitFailure code -> do+ err <- liftIO $ IO.hGetContents errHandle+ left (code, trim err)+ ExitSuccess -> do+ out <- liftIO $ IO.hGetContents outHandle+ unless (null out) (liftIO $ putStrLn ("Output: " ++ out))+ right (trim out) execCommand :: String -> Hapistrano String execCommand cmd = do