diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/hapistrano.cabal b/hapistrano.cabal --- a/hapistrano.cabal +++ b/hapistrano.cabal @@ -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 diff --git a/spec/System/HapistranoSpec.hs b/spec/System/HapistranoSpec.hs new file mode 100644 --- /dev/null +++ b/spec/System/HapistranoSpec.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 diff --git a/src/System/Hapistrano.hs b/src/System/Hapistrano.hs --- a/src/System/Hapistrano.hs +++ b/src/System/Hapistrano.hs @@ -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