diff --git a/.travis.yml b/.travis.yml index 45ed96b..4230250 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,10 +4,6 @@ sudo: false matrix: include: - - env: CABALVER=1.24 GHCVER=7.6.3 - addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=7.8.4 - addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.10.3 addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3],sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=8.0.2 @@ -28,17 +24,11 @@ install: - cabal install --only-dependencies --enable-tests script: - - case "$GHCVER" in - "7.6.3") cabal configure --enable-tests -v2 -f dev ;; - *) cabal configure --enable-tests --enable-coverage -v2 -f dev ;; - esac + - cabal configure --enable-tests --enable-coverage -v2 -f dev - cabal build - - case "$GHCVER" in - "7.6.3") true ;; - *) cabal test --show-details=always ;; - esac + - cabal test --show-details=always - cabal sdist - - cabal haddock | grep "100%" | wc -l | grep "2" + - cabal haddock | grep "100%" | wc -l | grep "4" notifications: email: false diff --git a/CHANGELOG.md b/CHANGELOG.md index a0c52c4..3d587fd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,8 @@ * Use `optparse-applicative` to parse arguments. * Add support for comments and empty lines to scripts. * Parse ssh port from `PORT` environment variable. +* Drop support for GHCs older than 7.10 (because Chris Done's `path` does + not compile with them, see: https://github.com/chrisdone/path/issues/46). ## 0.2.1.2 diff --git a/app/Command.hs b/app/Command.hs deleted file mode 100644 index 1ead3fc..0000000 --- a/app/Command.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Command where - -import Data.Monoid ((<>)) -import Options.Applicative - -data Command - = Deploy - | Rollback - deriving Show - -addCommand :: Command -> String -> String -> Mod CommandFields Command -addCommand command' name description = - command name (info (pure command') (progDesc description)) - -commands :: Parser Command -commands - = subparser - ( - addCommand Deploy "deploy" "Deploys the current release with the configure options" - <> addCommand Rollback "rollback" "Rolls back to the previous release" - ) diff --git a/app/Flag.hs b/app/Flag.hs deleted file mode 100644 index 5eb77e8..0000000 --- a/app/Flag.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Flag where - -import Data.Monoid ((<>)) -import Options.Applicative - -data Flag - = Version - deriving Show - -flags :: Parser Flag -flags = - flag' Version (long "version" <> short 'v' <> help "Diplay the version of Hapistrano") diff --git a/app/Main.hs b/app/Main.hs index 4d67690..d1f4f48 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,96 +1,123 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} module Main (main) where -import qualified System.Hapistrano as Hap -import Control.Monad (void) -import System.Environment.Compat (lookupEnv) - -import System.Hapistrano (ReleaseFormat(..)) - -import System.Exit - -import Options - -import Paths_hapistrano (version) +import Control.Monad +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import Data.Version (showVersion) - -import qualified Text.Read as Read +import Numeric.Natural +import Options.Applicative +import Path +import Path.IO +import Paths_hapistrano (version) +import System.Environment.Compat (lookupEnv, getEnv) +import System.Exit +import System.Hapistrano.Types +import Text.Read (readMaybe) +import qualified System.Hapistrano as Hap +import qualified System.Hapistrano.Commands as Hap +import qualified System.Hapistrano.Core as Hap #if !MIN_VERSION_base(4,8,0) import Control.Applicative -import System.IO - -die :: String -> IO a -die err = hPutStrLn stderr err >> exitFailure #endif --- | Rolls back to previous release. -rollback :: Hap.Config -> IO () -rollback cfg = - Hap.runRC errorHandler successHandler cfg $ do +---------------------------------------------------------------------------- +-- Command line options - _ <- Hap.rollback - void Hap.restartServerCommand +-- | Command line options. - where - errorHandler = Hap.defaultErrorHandler - successHandler = Hap.defaultSuccessHandler +data Opts = Opts + { optsCommand :: Command + , optsVersion :: Bool + } --- | 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 +-- | Command to execute and command-specific options. - void Hap.restartServerCommand +data Command + = Deploy ReleaseFormat Natural -- ^ Deploy a new release (with timestamp + -- format and how many releases to keep) + | Rollback Natural -- ^ Rollback to Nth previous release - where - errorHandler = Hap.defaultErrorHandler - successHandler = Hap.defaultSuccessHandler +parserInfo :: ParserInfo Opts +parserInfo = info (helper <*> optionParser) + ( fullDesc <> + progDesc "Deploy tool for Haskell applications" <> + header "Hapistrano - A deployment library for Haskell applications" ) --- | Retrieves the configuration from environment variables. -configFromEnv :: IO Hap.Config -configFromEnv = do - maybeDeployPath <- lookupEnv "DEPLOY_PATH" - maybeRepository <- lookupEnv "REPOSITORY" - maybeRevision <- lookupEnv "REVISION" +optionParser :: Parser Opts +optionParser = Opts + <$> subparser + ( command "deploy" + (info deployParser (progDesc "Deploy a new release")) <> + command "rollback" + (info rollbackParser (progDesc "Roll back to Nth previous release")) ) + <*> switch + ( long "version" + <> short 'v' + <> help "Show version of the program" ) - deployPath <- maybe (die (noEnv "DEPLOY_PATH")) return maybeDeployPath - repository <- maybe (die (noEnv "REPOSITORY")) return maybeRepository - revision <- maybe (die (noEnv "REVISION")) return maybeRevision +deployParser :: Parser Command +deployParser = Deploy + <$> option pReleaseFormat + ( long "release-format" + <> short 'r' + <> value ReleaseShort + <> help "Which format release timestamp format to use: ‘long’ or ‘short’, default is ‘short’." ) + <*> option auto + ( long "keep-releases" + <> short 'k' + <> value 5 + <> help "How many releases to keep. Default is 5." ) - port <- lookupEnv "PORT" - host <- lookupEnv "HOST" - buildScript <- lookupEnv "BUILD_SCRIPT" - restartCommand <- lookupEnv "RESTART_COMMAND" +rollbackParser :: Parser Command +rollbackParser = Rollback + <$> option auto + ( long "use-nth" + <> short 'n' + <> value 1 + <> help "How many deployments back to go? Default is 1." ) - return Hap.Config { Hap.deployPath = deployPath - , Hap.host = host - , Hap.releaseFormat = Short - , Hap.repository = repository - , Hap.revision = revision - , Hap.buildScript = buildScript - , Hap.restartCommand = restartCommand - , Hap.port = parsePort port - } - where - noEnv env = env ++ " environment variable does not exist" - parsePort maybePort = maybePort >>= Read.readMaybe +pReleaseFormat :: ReadM ReleaseFormat +pReleaseFormat = eitherReader $ \s -> + case s of + "long" -> Right ReleaseLong + "short" -> Right ReleaseShort + _ -> Left ("Unknown format: " ++ s ++ ", try ‘long’ or ‘short’.") + +---------------------------------------------------------------------------- +-- Main main :: IO () -main = execParser (info (helper <*> opts) hapistranoDesc) >>= runOption +main = do + Opts {..} <- execParser parserInfo + when optsVersion $ do + putStrLn $ "Hapistrano " ++ showVersion version + exitSuccess -runOption :: Option -> IO () -runOption (Command command) = runCommand command -runOption (Flag flag) = runFlag flag + deployPath <- getEnv "DEPLOY_PATH" >>= parseAbsDir + repository <- getEnv "REPOSITORY" + revision <- getEnv "REVISION" + port <- fromMaybe 22 . (>>= readMaybe) <$> lookupEnv "PORT" + mhost <- lookupEnv "HOST" + buildScript <- lookupEnv "BUILD_SCRIPT" + mrestartCmd <- (>>= Hap.mkGenericCommand) <$> lookupEnv "RESTART_COMMAND" -runCommand :: Command -> IO () -runCommand Deploy = configFromEnv >>= deploy -runCommand Rollback = configFromEnv >>= rollback - -runFlag :: Flag -> IO () -runFlag Version = printVersion - -printVersion :: IO () -printVersion = putStrLn $ "Hapistrano " ++ showVersion version + Hap.runHapistrano (SshOptions <$> mhost <*> pure port) $ case optsCommand of + Deploy releaseFormat n -> do + release <- Hap.pushRelease Task + { taskDeployPath = deployPath + , taskRepository = repository + , taskRevision = revision + , taskReleaseFormat = releaseFormat } + forM_ buildScript $ \spath' -> do + spath <- resolveFile' spath' + script <- Hap.readScript spath + Hap.playScript script deployPath release + Hap.activateRelease deployPath release + Hap.dropOldReleases deployPath n + Rollback n -> do + Hap.rollback deployPath n + forM_ mrestartCmd Hap.exec diff --git a/app/Options.hs b/app/Options.hs deleted file mode 100644 index 55acbf9..0000000 --- a/app/Options.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Options ( - Option(..) - , opts - , hapistranoDesc - -- | Imports from Options.Applicative - , execParser - , info - , helper - -- | Imports from other internal modules - , module Command - , module Flag - ) - where - -import Command -import Flag - -import Data.Monoid ((<>)) -import Options.Applicative - --- | Flags and commands -opts :: Parser Option -opts - = fmap Flag flags - <|> fmap Command commands - -data Option - = Command Command.Command - | Flag Flag.Flag - deriving Show - -hapistranoDesc :: InfoMod a -hapistranoDesc = - fullDesc - <> header "Hapistrano - A deployment library for Haskell applications" - <> progDesc "Deploy tool for Haskell applications" - <> footer "Run 'hap -h' for available commands" diff --git a/hapistrano.cabal b/hapistrano.cabal index 2c3d3df..b0a1b90 100644 --- a/hapistrano.cabal +++ b/hapistrano.cabal @@ -30,6 +30,7 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md , README.md +data-files: script/clean-build.sh flag dev description: Turn on development settings. @@ -39,11 +40,13 @@ flag dev library hs-source-dirs: src exposed-modules: System.Hapistrano - other-modules: System.Hapistrano.Types + , System.Hapistrano.Commands + , System.Hapistrano.Core + , System.Hapistrano.Types build-depends: base >= 4.6 && < 5.0 - , either >= 4.0 && < 4.6 , filepath >= 1.2 && < 1.5 , mtl >= 2.0 && < 3.0 + , path >= 0.5 && < 6.0 , process >= 1.4 && < 1.5 , time >= 1.5 && < 1.8 , transformers >= 0.4 && < 0.6 @@ -56,31 +59,31 @@ library executable hap hs-source-dirs: app main-is: Main.hs - other-modules: Options - , Command - , Flag build-depends: base >= 4.6 && < 5.0 , base-compat >= 0.6 && < 1.0 , hapistrano , optparse-applicative >= 0.11 && < 0.14 + , path >= 0.5 && < 6.0 + , path-io >= 1.2 && < 1.3 if flag(dev) ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror else ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall default-language: Haskell2010 -test-suite hapistrano-test +test-suite test type: exitcode-stdio-1.0 hs-source-dirs: spec main-is: Spec.hs other-modules: System.HapistranoSpec build-depends: base >= 4.5 && < 5.0 , directory >= 1.2.2 && < 1.4 - , either >= 4.0 && < 4.6 , filepath >= 1.2 && < 1.5 , hapistrano , hspec >= 2.0 && < 3.0 , mtl >= 2.0 && < 3.0 + , path >= 0.5 && < 6.0 + , path-io >= 1.2 && < 1.3 , process >= 1.4 && < 1.5 , temporary >= 1.1 && < 1.3 if flag(dev) @@ -91,4 +94,4 @@ test-suite hapistrano-test source-repository head type: git - location: https://github.com/stackbuilders/hapistrano + location: https://github.com/stackbuilders/hapistrano.git diff --git a/script/clean-build.sh b/script/clean-build.sh index 34d7d17..139a0c7 100644 --- a/script/clean-build.sh +++ b/script/clean-build.sh @@ -1,7 +1,7 @@ # This is a comment export PATH=~/.cabal/bin:/usr/local/bin:$PATH -cabal sandbox delete +cabal sandbox delete # kill it with fire! cabal sandbox init cabal clean cabal update diff --git a/spec/System/HapistranoSpec.hs b/spec/System/HapistranoSpec.hs index 83b5634..387e066 100644 --- a/spec/System/HapistranoSpec.hs +++ b/spec/System/HapistranoSpec.hs @@ -1,219 +1,139 @@ -module System.HapistranoSpec (spec) where +{-# LANGUAGE TemplateHaskell #-} -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) +module System.HapistranoSpec + ( spec ) +where +import Control.Monad +import Control.Monad.Reader +import Path +import Path.IO +import System.Hapistrano.Types +import Test.Hspec hiding (shouldBe, shouldReturn) import qualified System.Hapistrano as Hap -import Data.List (intercalate, 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"] - - gitConfigReplace = - intercalate - " && " - [ "git config --local --replace-all push.default simple" - , "git config --local --replace-all user.email hap@hap" - , "git config --local --replace-all user.name Hap" - ] - - gitConfigUnset = - intercalate - " && " - [ "git config --local --unset push.default" - , "git config --local --unset user.email" - , "git config --local --unset user.name" - ] - - commands = - [ "mkdir -p " ++ fullRepoPath - , "git init --bare " ++ fullRepoPath - , "git clone " ++ fullRepoPath ++ " " ++ clonePath - , "echo testing > " ++ joinPath [clonePath, "README"] - , "cd " ++ clonePath ++ " && " ++ gitConfigReplace - , "cd " ++ clonePath ++ " && git add -A" - , "cd " ++ clonePath ++ " && git commit -m\"First commit\"" - , "cd " ++ clonePath ++ " && git push" - , "cd " ++ clonePath ++ " && " ++ gitConfigUnset - ] - - 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 - , Hap.port = 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 +import qualified System.Hapistrano.Commands as Hap +import qualified System.Hapistrano.Core as Hap +import qualified Test.Hspec as Hspec spec :: Spec -spec = describe "hapistrano" $ do - describe "readCurrentLink" $ - it "trims trailing whitespace" $ - withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do +spec = do + describe "readScript" $ + it "preforms all the necessary normalizations correctly" $ do + spath <- makeAbsolute $(mkRelFile "script/clean-build.sh") + (fmap Hap.unGenericCommand <$> Hap.readScript spath) + `Hspec.shouldReturn` + [ "export PATH=~/.cabal/bin:/usr/local/bin:$PATH" + , "cabal sandbox delete" + , "cabal sandbox init" + , "cabal clean" + , "cabal update" + , "cabal install --only-dependencies -j" + , "cabal build -j" ] - testRepoPath <- genSourceRepo tmpDir + around withSandbox $ do + describe "pushRelease" $ + it "sets up repo all right" $ \(deployPath, repoPath) -> runHap $ do + let task = mkTask deployPath repoPath + release <- Hap.pushRelease task + rpath <- Hap.releasePath deployPath release + -- let's check that the dir exists and contains the right files + (liftIO . readFile . fromAbsFile) (rpath $(mkRelFile "foo.txt")) + `shouldReturn` "Foo!\n" - deployAndActivate $ defaultState tmpDir testRepoPath + describe "activateRelease" $ + it "creates the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> runHap $ do + let task = mkTask deployPath repoPath + release <- Hap.pushRelease task + Hap.activateRelease deployPath release + rpath <- Hap.releasePath deployPath release + let rc :: Hap.Readlink Dir + rc = Hap.Readlink (Hap.currentSymlinkPath deployPath) + Hap.exec rc `shouldReturn` rpath + doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False - ltarget <- - runReaderT (runEitherT Hap.readCurrentLink) $ - defaultState tmpDir testRepoPath + describe "rollback" $ + it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> runHap $ do + let task = mkTask deployPath repoPath + rs <- replicateM 5 (Hap.pushRelease task) + Hap.rollback deployPath 2 + rpath <- Hap.releasePath deployPath (rs !! 2) + let rc :: Hap.Readlink Dir + rc = Hap.Readlink (Hap.currentSymlinkPath deployPath) + Hap.exec rc `shouldReturn` rpath + doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False - last (fromRight ltarget) /= '\n' `shouldBe` True + describe "dropOldReleases" $ + it "works" $ \(deployPath, repoPath) -> runHap $ do + let task = mkTask deployPath repoPath + rs <- replicateM 7 (Hap.pushRelease task) + Hap.dropOldReleases deployPath 5 + -- two oldest releases should not survive: + forM_ (take 2 rs) $ \r -> + (Hap.releasePath deployPath r >>= doesDirExist) + `shouldReturn` False + -- 5 most recent releases should stay alive: + forM_ (drop 2 rs) $ \r -> + (Hap.releasePath deployPath r >>= doesDirExist) + `shouldReturn` True - describe "deploying" $ do - it "reads a common build script with comments and new lines" $ do - scriptLines <- lines `fmap` IO.readFile "./script/clean-build.sh" - let validBBuildScriptLines = Hap.cleanBuildScript scriptLines - length validBBuildScriptLines `shouldBe` 7 +---------------------------------------------------------------------------- +-- Helpers - it "a simple deploy" $ - withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do +infix 1 `shouldBe`, `shouldReturn` - testRepoPath <- genSourceRepo tmpDir +-- | Lifted 'Hspec.shouldBe'. - deployOnly $ defaultState tmpDir testRepoPath +shouldBe :: (MonadIO m, Show a, Eq a) => a -> a -> m () +shouldBe x y = liftIO (x `Hspec.shouldBe` y) - contents <- getDirectoryContents (joinPath [tmpDir, "releases"]) - length (filter (Hap.isReleaseString Hap.Long) contents) `shouldBe` 1 +-- | Lifted 'Hspec.shouldReturn'. - it "activates the release" $ - withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do +shouldReturn :: (MonadIO m, Show a, Eq a) => m a -> a -> m () +shouldReturn m y = m >>= (`shouldBe` y) - testRepoPath <- genSourceRepo tmpDir +-- | The sandbox prepares the environment for an independent round of +-- testing. It provides two paths: deploy path and path where git repo is +-- located. - deployAndActivate $ defaultState tmpDir testRepoPath +withSandbox :: ActionWith (Path Abs Dir, Path Abs Dir) -> IO () +withSandbox action = withSystemTempDir "hap-test" $ \dir -> do + let dpath = dir $(mkRelDir "deploy") + rpath = dir $(mkRelDir "repo") + ensureDir dpath + ensureDir rpath + populateTestRepo rpath + action (dpath, rpath) - contents <- getDirectoryContents (joinPath [tmpDir, "releases"]) - length (filter (Hap.isReleaseString Hap.Long) contents) `shouldBe` 1 +-- | Given path where to put the repo, generate it for testing. - it "cleans up old releases" $ - withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do - testRepoPath <- genSourceRepo tmpDir +populateTestRepo :: Path Abs Dir -> IO () +populateTestRepo path = runHap $ do + justExec path "git init" + justExec path "git config --local --replace-all push.default simple" + justExec path "git config --local --replace-all user.email hap@hap" + justExec path "git config --local --replace-all user.name Hap" + justExec path "echo 'Foo!' > foo.txt" + justExec path "git add -A" + justExec path "git commit -m 'Initial commit'" - replicateM_ 7 $ deployAndActivate $ defaultState tmpDir testRepoPath +-- | Execute arbitrary commands in the specified directory. - contents <- getDirectoryContents (joinPath [tmpDir, "releases"]) - length (filter (Hap.isReleaseString Hap.Long) contents) `shouldBe` 5 +justExec :: Path Abs Dir -> String -> Hapistrano () +justExec path cmd' = + case Hap.mkGenericCommand cmd' of + Nothing -> Hap.failWith 1 (Just $ "Failed to parse the command: " ++ cmd') + Just cmd -> Hap.exec (Hap.Cd path cmd) - describe "rollback" $ - it "rolls back to the previous release" $ - withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do +-- | Run 'Hapistrano' monad locally. - testRepoPath <- genSourceRepo tmpDir - let deployState = defaultState tmpDir testRepoPath +runHap :: Hapistrano a -> IO a +runHap = Hap.runHapistrano Nothing - deployAndActivate deployState +-- | Make a 'Task' given deploy path and path to the repo. - -- 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 +mkTask :: Path Abs Dir -> Path Abs Dir -> Task +mkTask deployPath repoPath = Task + { taskDeployPath = deployPath + , taskRepository = fromAbsDir repoPath + , taskRevision = "master" + , taskReleaseFormat = ReleaseLong } diff --git a/src/System/Hapistrano.hs b/src/System/Hapistrano.hs index 92c67e6..98d5857 100644 --- a/src/System/Hapistrano.hs +++ b/src/System/Hapistrano.hs @@ -1,6 +1,6 @@ -- | -- Module : System.Hapistrano --- Copyright : © 2017 Stack Builders +-- Copyright : © 2015-2017 Stack Builders -- License : MIT -- -- Maintainer : Justin Leitgeb @@ -9,433 +9,210 @@ -- -- A module for creating reliable deploy processes for Haskell applications. -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module System.Hapistrano - ( Config(..) - , ReleaseFormat(..) + ( pushRelease + , activateRelease + , rollback + , dropOldReleases + , playScript + -- * Path helpers + , releasePath + , currentSymlinkPath + , tempSymlinkPath ) +where - , activateRelease - , currentPath - , cleanBuildScript - , defaultSuccessHandler - , defaultErrorHandler - , directoryExists - , isReleaseString - , pathToRelease - , pushRelease - , readCurrentLink - , restartServerCommand - , rollback - , runRC - , runBuild - - ) where - -import Control.Monad.Reader (ReaderT(..), ask) - -import System.Hapistrano.Types - (Config(..), FailureResult, Hapistrano, Release, ReleaseFormat(..)) - -import Control.Monad (unless, void) -import System.Exit (ExitCode(..), exitWith) - -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Either ( left - , right - , eitherT ) - -import Data.Char (isNumber, isSpace) -import Data.List (intercalate, sortBy, isInfixOf, dropWhileEnd) +import Control.Monad +import Control.Monad.Except +import Data.List (genericDrop, dropWhileEnd, sortBy) +import Data.Maybe (mapMaybe) +import Data.Ord (comparing, Down (..)) import Data.Time -import System.FilePath (joinPath, splitPath) -import System.IO (hPutStrLn, stderr) -import System.Process (readProcessWithExitCode) +import Numeric.Natural +import Path +import System.Hapistrano.Commands +import System.Hapistrano.Core +import System.Hapistrano.Types -import qualified System.IO as IO -import qualified System.Process as Process +---------------------------------------------------------------------------- +-- High-level functionality --- | 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 :: Hapistrano Release -pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >> - cleanReleases >> cloneToRelease >>= setReleaseRevision +-- | Perform basic setup for a project, making sure necessary directories +-- exist and pushing a new release directory with the SHA1 or branch +-- specified in the configuration. Return identifier of the pushed release. --- | Switches the current symlink to point to the release specified in --- the configuration. Maybe used in either deploy or rollback cases. -activateRelease :: Release -> Hapistrano String -activateRelease rel = removeCurrentSymlink >> symlinkCurrent rel +pushRelease :: Task -> Hapistrano Release +pushRelease Task {..} = do + setupDirs taskDeployPath + ensureCacheInPlace taskRepository taskDeployPath + release <- newRelease taskReleaseFormat + cloneToRelease taskDeployPath release + setReleaseRevision taskDeployPath release taskRevision + return release --- | Runs the deploy, along with an optional success or failure function. -runRC :: ((Int, String) -> ReaderT Config IO a) -- ^ Error handler - -> (a -> ReaderT Config IO a) -- ^ Success handler - -> Config -- ^ Hapistrano deployment configuration - -> Hapistrano a -- ^ The remote command to run - -> IO a -runRC errorHandler successHandler config command = - runReaderT (eitherT errorHandler successHandler command) config +-- | Switch the current symlink to point to the specified release. May be +-- used in deploy or rollback cases. --- | Default method to run on deploy failure. Emits a failure message --- and exits with a status code of 1. -defaultErrorHandler :: FailureResult -> ReaderT Config IO () -defaultErrorHandler res = - liftIO $ hPutStrLn stderr - ("Deploy failed with (status, message): " ++ show res) - >> exitWith (ExitFailure 1) +activateRelease + :: Path Abs Dir -- ^ Deploy path + -> Release -- ^ Release identifier to activate + -> Hapistrano () +activateRelease deployPath release = do + rpath <- releasePath deployPath release + let tpath = tempSymlinkPath deployPath + cpath = currentSymlinkPath deployPath + exec (Ln rpath tpath) -- create a symlink for the new candidate + exec (Mv tpath cpath) -- atomically replace the symlink --- | Default method to run on deploy success. -defaultSuccessHandler :: a -> ReaderT Config IO () -defaultSuccessHandler _ = - liftIO $ putStrLn "Deploy completed successfully." +-- | Activates one of already deployed releases. --- | Creates necessary directories for the hapistrano project. Should --- only need to run the first time the project is deployed on a given --- system. -setupDirs :: Hapistrano () -setupDirs = do - conf <- ask +rollback + :: Path Abs Dir -- ^ Deploy path + -> Natural -- ^ How many releases back to go, 0 re-activates current + -> Hapistrano () +rollback deployPath n = do + xs <- genericDrop n <$> deployedReleases deployPath + case xs of + [] -> failWith 1 (Just "Could not find the requested release to rollback to.") + (x:_) -> activateRelease deployPath x - mapM_ (runCommand (host conf) (port conf)) - ["mkdir -p " ++ releasesPath conf, "mkdir -p " ++ cacheRepoPath conf] +-- | Remove older releases to avoid filling up the target host filesystem. --- | TODO +dropOldReleases + :: Path Abs Dir -- ^ Deploy path + -> Natural -- ^ How many releases to keep + -> Hapistrano () -- ^ Deleted Releases +dropOldReleases deployPath n = do + releases <- deployedReleases deployPath + forM_ (genericDrop n releases) $ \release -> do + rpath <- releasePath deployPath release + exec (Rm rpath) -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]) +-- | Play the given script switching to diroctory of given release. - (code, _, _) <- readProcessWithExitCode command args "" +playScript + :: [GenericCommand] -- ^ Commands to execute + -> Path Abs Dir -- ^ Deploy path + -> Release -- ^ Release identifier + -> Hapistrano () +playScript cmds deployDir release = do + rpath <- releasePath deployDir release + forM_ cmds (exec . Cd rpath) - return $ case code of - ExitSuccess -> True - ExitFailure _ -> False +---------------------------------------------------------------------------- +-- Helpers --- | Runs the given command either locally or on the local machine. -runCommand :: Maybe String -- ^ The host on which to run the command - -> Maybe Integer -- ^ The port on which to run the command - -> String -- ^ The command to run, either on the local or remote host - -> Hapistrano String +-- | Ensure that necessary directories exist. Idempotent. -runCommand Nothing _ command = execShellCommand command -runCommand (Just server) Nothing command = - execCommand $ unwords ["ssh", server, command] -runCommand (Just server) (Just port') command = - execCommand $ unwords ["ssh", server, "-p", show port', command] +setupDirs + :: Path Abs Dir -- ^ Deploy path + -> Hapistrano () +setupDirs deployPath = do + (exec . MkDir . releasesPath) deployPath + (exec . MkDir . cacheRepoPath) deployPath -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) +-- | Ensure that the specified repo is cloned and checked out on the given +-- revision. Idempotent. -execCommand :: String -> Hapistrano String -execCommand cmd = do - let wds = words cmd - (cmd', args) = (head wds, tail wds) +ensureCacheInPlace + :: String -- ^ Repo URL + -> Path Abs Dir -- ^ Deploy path + -> Hapistrano () +ensureCacheInPlace repo deployPath = do + let cpath = cacheRepoPath deployPath + refs = cpath $(mkRelDir "refs") + exists <- (exec (Ls refs) >> return True) + `catchError` const (return False) + unless exists $ + exec (GitClone True (Left repo) cpath) + exec (Cd cpath (GitFetch "origin")) -- TODO store this in task description? - liftIO $ putStrLn $ "Executing: " ++ cmd +-- | Create a new realese identifier based on current timestamp. - (code, stdout, err) <- liftIO $ readProcessWithExitCode cmd' args "" +newRelease :: ReleaseFormat -> Hapistrano Release +newRelease releaseFormat = + mkRelease releaseFormat <$> liftIO getCurrentTime - case code of - ExitSuccess -> do - unless (null stdout) (liftIO $ putStrLn $ "Output: " ++ stdout) +-- | Clone the repository to create the specified 'Release'. - right $ trim stdout +cloneToRelease + :: Path Abs Dir -- ^ Deploy path + -> Release -- ^ 'Release' to create + -> Hapistrano () +cloneToRelease deployPath release = do + rpath <- releasePath deployPath release + let cpath = cacheRepoPath deployPath + exec (GitClone False (Right cpath) rpath) - ExitFailure int -> left (int, trim err) +-- | Set the release to the correct revision by resetting the head of the +-- git repo. --- | Returns a timestamp in the default format for build directories. -currentTimestamp :: ReleaseFormat -> IO String -currentTimestamp format = do - curTime <- getCurrentTime - return $ formatTime defaultTimeLocale fstring curTime +setReleaseRevision + :: Path Abs Dir -- ^ Deploy path + -> Release -- ^ 'Release' to reset + -> String -- ^ Revision to reset to + -> Hapistrano () +setReleaseRevision deployPath release revision = do + rpath <- releasePath deployPath release + exec (Cd rpath (GitReset revision)) - where fstring = case format of - Short -> "%Y%m%d%H%M%S" - Long -> "%Y%m%d%H%M%S%q" +-- | Return a list of all currently deployed releases sorted newest first. --- | Returns the FilePath pointed to by the current symlink. -readCurrentLink :: Hapistrano FilePath -- ^ The target of the symlink in the Hapistrano monad -readCurrentLink = do - conf <- ask - runCommand (host conf) (port conf) $ "readlink " ++ currentPath (deployPath conf) +deployedReleases + :: Path Abs Dir -- ^ Deploy path + -> Hapistrano [Release] +deployedReleases deployPath = do + let rpath = releasesPath deployPath + xs <- exec (FindDir 1 rpath) + ps <- mapM (stripDir rpath) (filter (/= rpath) xs) + (return . sortBy (comparing Down) . mapMaybe parseRelease) + (dropWhileEnd (== '/') . fromRelDir <$> ps) --- ^ Trims any newlines from the given String -trim :: String -- ^ String to have trailing newlines stripped - -> String -- ^ String with trailing newlines removed -trim = dropWhileEnd isSpace . dropWhile isSpace +---------------------------------------------------------------------------- +-- Path helpers --- | Ensure that the initial bare repo exists in the repo directory. Idempotent. -ensureRepositoryPushed :: Hapistrano String -ensureRepositoryPushed = do - conf <- ask - res <- - liftIO $ directoryExists (host conf) $ joinPath [cacheRepoPath conf, "refs"] +-- | Return the full path to the directory containing all of the release +-- builds. - if res - then right "Repo already existed" - else createCacheRepo +releasesPath + :: Path Abs Dir -- ^ Deploy path + -> Path Abs Dir +releasesPath deployPath = deployPath $(mkRelDir "releases") --- | Returns the full path of the folder containing all of the release builds. -releasesPath :: Config -> FilePath -releasesPath conf = joinPath [deployPath conf, "releases"] +-- | Construct path to a particular 'Release'. --- | Figures out the most recent release if possible. -detectPrevious :: [String] -- ^ The releases in `releases` path - -> Hapistrano String -- ^ The previous release in the Hapistrano monad -detectPrevious rs = - case biggest rs of - Nothing -> left (1, "No previous releases detected!") - Just rls -> right rls +releasePath + :: Path Abs Dir -- ^ Deploy path + -> Release -- ^ 'Release' identifier + -> Hapistrano (Path Abs Dir) +releasePath deployPath release = do + let rendered = renderRelease release + case parseRelDir rendered of + Nothing -> failWith 1 (Just $ "Could not append path: " ++ rendered) + Just rpath -> return (releasesPath deployPath rpath) --- | Activates the previous detected release. -rollback :: Hapistrano String -- ^ The current Release in the Hapistrano monad -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. Returns the --- timestamp of the release that we cloned to. -cloneToRelease :: Hapistrano Release -- ^ The newly-cloned Release, in the Hapistrano monad -cloneToRelease = do - conf <- ask - rls <- liftIO $ currentTimestamp (releaseFormat conf) - - void $ runCommand (host conf) (port conf) $ "git clone " ++ cacheRepoPath conf ++ - " " ++ joinPath [ releasesPath conf, rls ] - - return rls - --- | Returns the full path to the git repo used for cache purposes on the +-- | Return the full path to the git repo used for cache purposes on the -- target host filesystem. -cacheRepoPath :: Config -- ^ The Hapistrano configuration - -> FilePath -- ^ The full path to the git cache repo used for speeding up deploys -cacheRepoPath conf = joinPath [deployPath conf, "repo"] --- | Returns the full path to the current symlink. -currentPath :: FilePath -- ^ The full path of the deploy folder root - -> FilePath -- ^ The full path to the `current` symlink -currentPath depPath = joinPath [depPath, "current"] +cacheRepoPath + :: Path Abs Dir -- ^ Deploy path + -> Path Abs Dir +cacheRepoPath deployPath = deployPath $(mkRelDir "repo") --- | Take the release timestamp from the end of a filepath. -pathToRelease :: FilePath -- ^ The entire FilePath to a Release directory - -> Release -- ^ The Release number. -pathToRelease = last . splitPath +-- | Get full path to current symlink. --- | Returns a list of Strings representing the currently deployed releases. -releases :: Hapistrano [Release] -- ^ A list of all found Releases on the target host -releases = do - conf <- ask - res <- runCommand (host conf) (port conf) $ "find " ++ releasesPath conf ++ - " -type d -maxdepth 1" +currentSymlinkPath + :: Path Abs Dir -- ^ Deploy path + -> Path Abs File +currentSymlinkPath deployPath = deployPath $(mkRelFile "current") - right $ - filter (isReleaseString (releaseFormat conf)) . map pathToRelease $ - lines res +-- | Get full path to temp symlink. -previousReleases :: Hapistrano [Release] -- ^ All non-current releases on the target host -previousReleases = do - rls <- releases - currentRelease <- readCurrentLink - - let currentRel = (head . lines . pathToRelease) currentRelease - 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 :: Hapistrano [String] -- ^ Deleted Release directories -cleanReleases = do - conf <- ask - allReleases <- releases - - let deletable = oldReleases conf allReleases - - if null deletable - then do - liftIO $ putStrLn "There are no old releases to prune." - return [] - - else do - _ <- runCommand (host conf) (port conf) $ "rm -rf -- " ++ unwords deletable - return deletable - --- | Returns a Bool indicating if the given String is in the proper release --- format. -isReleaseString :: ReleaseFormat -- ^ Format of Release directories - -> String -- ^ String to check against Release format - -> Bool -- ^ Whether the given String adheres to the specified Release format -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 :: Hapistrano String -- ^ Output of the git command used to create the bare cache repo -createCacheRepo = do - conf <- ask - - runCommand (host conf) (port 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 [deployPath conf, "current"] - -currentTempSymlinkPath :: Config -> FilePath -currentTempSymlinkPath conf = joinPath [deployPath conf, "current_tmp"] - --- | Removes the current symlink in preparation for a new release being --- activated. -removeCurrentSymlink :: Hapistrano () -removeCurrentSymlink = do - conf <- ask - - void $ runCommand (host conf) (port conf) $ "rm -rf " ++ currentSymlinkPath conf - --- | Determines whether the target host OS is Linux -targetIsLinux :: Hapistrano Bool -targetIsLinux = do - conf <- ask - res <- runCommand (host conf) (port conf) "uname" - - right $ "Linux" `isInfixOf` res - --- | Runs a command to restart a server if a command is provided. -restartServerCommand :: Hapistrano String -restartServerCommand = do - conf <- ask - - case restartCommand conf of - Nothing -> return "No command given for restart action." - Just cmd -> runCommand (host conf) (port conf) cmd - --- | TODO - -cleanBuildScript :: [String] -> [String] -cleanBuildScript allScriptLines = filter (not . isCommentOrEmpty) allScriptLines - where - isCommentOrEmpty line = isEmpty line || isComment line - isComment line = (head $ trim line) == '#' - isEmpty line = (trim line) == "" - --- | Runs a build script if one is provided. -runBuild :: Release -> Hapistrano Release -runBuild rel = do - conf <- ask - - case buildScript conf of - Nothing -> - liftIO $ putStrLn "No build script specified, skipping build step." - - Just scr -> do - fl <- liftIO $ readFile scr - buildRelease rel $ cleanBuildScript $ lines fl - - right rel - --- | 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 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 :: Release -> Hapistrano String -symlinkCurrent rel = do - conf <- ask - - isLnx <- targetIsLinux - - let tmpLnCmd = - lnCommand (releasePath conf rel) (currentTempSymlinkPath conf) - - _ <- runCommand (host conf) (port conf) tmpLnCmd - - runCommand (host conf) (port conf) $ unwords [ mvCommand isLnx - , currentTempSymlinkPath conf - , currentSymlinkPath conf ] - --- | Updates the git repo used as a cache in the target host filesystem. -updateCacheRepo :: Hapistrano () -updateCacheRepo = do - conf <- ask - - void $ runCommand (host conf) (port 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 :: Release -> Hapistrano Release -setReleaseRevision rel = do - conf <- ask - - liftIO $ putStrLn "Setting revision in release path." - - void $ runCommand (host conf) (port conf) $ intercalate " && " - [ "cd " ++ releasePath conf rel - , "git fetch --all" - , "git reset --hard " ++ revision conf - ] - - return rel - --- | Returns a command that builds this application. Sets the context --- of the build by switching to the release directory before running --- the script. -buildRelease :: Release -- ^ The Release to build - -> [String] -- ^ Commands to be run. List intercalated - -- with "&&" so that failure aborts the - -- sequence. - -> Hapistrano () -buildRelease rel commands = do - conf <- ask - let cdCmd = "cd " ++ releasePath conf rel - void $ runCommand (host conf) (port conf) $ 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 +tempSymlinkPath + :: Path Abs Dir -- ^ Deploy path + -> Path Abs File +tempSymlinkPath deployPath = deployPath $(mkRelFile "current_tmp") diff --git a/src/System/Hapistrano/Commands.hs b/src/System/Hapistrano/Commands.hs new file mode 100644 index 0000000..f280dce --- /dev/null +++ b/src/System/Hapistrano/Commands.hs @@ -0,0 +1,273 @@ +-- | +-- Module : System.Hapistrano.Commands +-- Copyright : © 2015-2017 Stack Builders +-- License : MIT +-- +-- Maintainer : Justin Leitgeb +-- Stability : experimental +-- Portability : portable +-- +-- Collection of type safe shell commands that can be fed into +-- 'System.Hapistrano.Core.runCommand'. + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module System.Hapistrano.Commands + ( Command (..) + , Whoami (..) + , Cd (..) + , MkDir (..) + , Rm (..) + , Mv (..) + , Ln (..) + , Ls (..) + , Readlink (..) + , FindDir (..) + , GitClone (..) + , GitFetch (..) + , GitReset (..) + , GenericCommand + , mkGenericCommand + , unGenericCommand + , readScript ) +where + +import Control.Monad.IO.Class +import Data.Char (isSpace) +import Data.List (dropWhileEnd) +import Data.Maybe (catMaybes, mapMaybe, fromJust) +import Data.Proxy +import Numeric.Natural +import Path + +---------------------------------------------------------------------------- +-- Commands + +-- | Class for data types that represent shell commands in typed way. + +class Command a where + + -- | Type of result. + + type Result a :: * + + -- | How to render the command before feeding it into shell (possibly via + -- SSH). + + renderCommand :: a -> String + + -- | How to parse the result from stdout. + + parseResult :: Proxy a -> String -> Result a + +-- | Unix @whoami@. + +data Whoami = Whoami + deriving (Show, Eq, Ord) + +instance Command Whoami where + type Result Whoami = String + renderCommand Whoami = "whoami" + parseResult Proxy = trim + +-- | Specify directory in which to perform another command. + +data Cd cmd = Cd (Path Abs Dir) cmd + +instance Command cmd => Command (Cd cmd) where + type Result (Cd cmd) = Result cmd + renderCommand (Cd path cmd) = "(cd " ++ quote (fromAbsDir path) ++ + " && " ++ renderCommand cmd ++ ")" + parseResult Proxy = parseResult (Proxy :: Proxy cmd) + +-- | Create a directory. Does not fail if the directory already exists. + +data MkDir = MkDir (Path Abs Dir) + +instance Command MkDir where + type Result MkDir = () + renderCommand (MkDir path) = formatCmd "mkdir" + [ Just "-pv" + , Just (fromAbsDir path) ] + parseResult Proxy _ = () + +-- | Delete file or directory. + +data Rm where + Rm :: Path Abs t -> Rm + +instance Command Rm where + type Result Rm = () + renderCommand (Rm path) = formatCmd "rm" + [ Just "-rfv" + , Just (toFilePath path) ] + parseResult Proxy _ = () + +-- | Move or rename files or directories. + +data Mv t = Mv (Path Abs t) (Path Abs t) + +instance Command (Mv File) where + type Result (Mv File) = () + renderCommand (Mv old new) = formatCmd "mv" + [ Just "-fvT" + , Just (fromAbsFile old) + , Just (fromAbsFile new) ] + parseResult Proxy _ = () + +instance Command (Mv Dir) where + type Result (Mv Dir) = () + renderCommand (Mv old new) = formatCmd "mv" + [ Just "-fv" + , Just (fromAbsDir old) + , Just (fromAbsDir new) ] + parseResult Proxy _ = () + +-- | Create symlinks. + +data Ln where + Ln :: Path Abs t -> Path Abs File -> Ln + +instance Command Ln where + type Result Ln = () + renderCommand (Ln target linkName) = formatCmd "ln" + [ Just "-svT" + , Just (toFilePath target) + , Just (fromAbsFile linkName) ] + parseResult Proxy _ = () + +-- | Read link. + +data Readlink t = Readlink (Path Abs File) + +instance Command (Readlink File) where + type Result (Readlink File) = Path Abs File + renderCommand (Readlink path) = formatCmd "readlink" + [ Just "-f" + , Just (toFilePath path) ] + parseResult Proxy = fromJust . parseAbsFile . trim + +instance Command (Readlink Dir) where + type Result (Readlink Dir) = Path Abs Dir + renderCommand (Readlink path) = formatCmd "readlink" + [ Just "-f" + , Just (toFilePath path) ] + parseResult Proxy = fromJust . parseAbsDir . trim + +-- | @ls@, so far used only to check existence of directories, so it's not +-- very functional right now. + +data Ls = Ls (Path Abs Dir) + +instance Command Ls where + type Result Ls = () + renderCommand (Ls path) = formatCmd "ls" + [ Just (fromAbsDir path) ] + parseResult Proxy _ = () + +-- | Find (a very limited version, only finds directories). + +data FindDir = FindDir Natural (Path Abs Dir) + +instance Command FindDir where + type Result FindDir = [Path Abs Dir] + renderCommand (FindDir maxDepth dir) = formatCmd "find" + [ Just (fromAbsDir dir) + , Just "-maxdepth" + , Just (show maxDepth) + , Just "-type" + , Just "d" ] + parseResult Proxy = mapMaybe parseAbsDir . fmap trim . lines + +-- | Git clone. + +data GitClone = GitClone Bool (Either String (Path Abs Dir)) (Path Abs Dir) + +instance Command GitClone where + type Result GitClone = () + renderCommand (GitClone bare src dest) = formatCmd "git" + [ Just "clone" + , if bare then Just "--bare" else Nothing + , Just (case src of + Left repoUrl -> repoUrl + Right srcPath -> fromAbsDir srcPath) + , Just (fromAbsDir dest) ] + parseResult Proxy _ = () + +-- | Git fetch (simplified). + +data GitFetch = GitFetch String + +instance Command GitFetch where + type Result GitFetch = () + renderCommand (GitFetch remote) = formatCmd "git" + [ Just "fetch" + , Just remote ] + parseResult Proxy _ = () + +-- | Git reset. + +data GitReset = GitReset String + +instance Command GitReset where + type Result GitReset = () + renderCommand (GitReset revision) = formatCmd "git" + [ Just "reset" + , Just revision ] + parseResult Proxy _ = () + +-- | Weakly-typed generic command, avoid using it directly. + +data GenericCommand = GenericCommand String + deriving (Show, Eq, Ord) + +instance Command GenericCommand where + type Result GenericCommand = () + renderCommand (GenericCommand cmd) = cmd + parseResult Proxy _ = () + +-- | Smart constructor that allows to create 'GenericCommand's. Just a +-- little bit more safety. + +mkGenericCommand :: String -> Maybe GenericCommand +mkGenericCommand str = + if '\n' `elem` str' || null str' + then Nothing + else Just (GenericCommand str') + where + str' = trim (takeWhile (/= '#') str) + +-- | Get the raw command back from 'GenericCommand'. + +unGenericCommand :: GenericCommand -> String +unGenericCommand (GenericCommand x) = x + +-- | Read commands from a file. + +readScript :: MonadIO m => Path Abs File -> m [GenericCommand] +readScript path = liftIO $ catMaybes . fmap mkGenericCommand . lines + <$> readFile (fromAbsFile path) + +---------------------------------------------------------------------------- +-- Helpers + +-- | Format a command. + +formatCmd :: String -> [Maybe String] -> String +formatCmd cmd args = unwords (quote <$> (cmd : catMaybes args)) + +-- | Simple-minded quoter. + +quote :: String -> String +quote str = + if any isSpace str + then "\"" ++ str ++ "\"" + else str + +-- | Trim whitespace from beginning and end. + +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace diff --git a/src/System/Hapistrano/Core.hs b/src/System/Hapistrano/Core.hs new file mode 100644 index 0000000..9d68c19 --- /dev/null +++ b/src/System/Hapistrano/Core.hs @@ -0,0 +1,98 @@ +-- | +-- Module : System.Hapistrano.Core +-- Copyright : © 2015-2017 Stack Builders +-- License : MIT +-- +-- Maintainer : Justin Leitgeb +-- Stability : experimental +-- Portability : portable +-- +-- Core Hapistrano functions that provide basis on which all the +-- functionality is built. + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module System.Hapistrano.Core + ( runHapistrano + , failWith + , exec ) +where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Data.Proxy +import System.Exit +import System.Hapistrano.Commands +import System.Hapistrano.Types +import System.IO +import System.Process + +-- | Run the 'Hapistrano' monad. The monad hosts 'exec' actions. + +runHapistrano :: MonadIO m + => Maybe SshOptions -- ^ SSH options to use or 'Nothing' if we run locally + -> Hapistrano a -- ^ The computation to run + -> m a -- ^ IO-enabled monad that hosts the computation +runHapistrano sshOptions m = liftIO $ do + let config = Config + { configSshOptions = sshOptions } + r <- runReaderT (runExceptT m) config + case r of + Left (Failure n msg) -> do + forM_ msg (hPutStrLn stderr) + exitWith (ExitFailure n) + Right x -> + x <$ putStrLn "Success." + +-- | Fail returning the following status code and printing given message to +-- 'stderr'. + +failWith :: Int -> Maybe String -> Hapistrano a +failWith n msg = throwError (Failure n msg) + +-- | Run the given sequence of command. Whether to use SSH or not is +-- determined from settings contained in the 'Hapistrano' monad +-- configuration. Commands that return non-zero exit codes will result in +-- short-cutting of execution. + +exec :: forall a. Command a => a -> Hapistrano (Result a) +exec typedCmd = do + Config {..} <- ask + let (prog, args) = + case configSshOptions of + Nothing -> + ("bash", ["-c", cmd]) + Just SshOptions {..} -> + ("ssh", [sshHost, "-p", show sshPort, cmd]) + cmd = renderCommand typedCmd + hostLabel = + case configSshOptions of + Nothing -> "localhost" + Just SshOptions {..} -> sshHost ++ ":" ++ show sshPort + liftIO $ do + printLine hostLabel + putStrLn ("$ " ++ cmd) + (exitCode, stdout', stderr') <- liftIO + (readProcessWithExitCode prog args "") + unless (null stdout') . liftIO $ + putStrLn stdout' + unless (null stderr') . liftIO $ + hPutStrLn stderr stderr' + case exitCode of + ExitSuccess -> + return (parseResult (Proxy :: Proxy a) stdout') + ExitFailure n -> + failWith n Nothing + +---------------------------------------------------------------------------- +-- Helpers + +-- | Print something “inside” a line, sort-of beautifully. + +printLine :: String -> IO () +printLine str = putStrLn ("*** " ++ str ++ padding) + where + padding = ' ' : replicate (75 - length str) '*' diff --git a/src/System/Hapistrano/Types.hs b/src/System/Hapistrano/Types.hs index 6063f30..4679f4f 100644 --- a/src/System/Hapistrano/Types.hs +++ b/src/System/Hapistrano/Types.hs @@ -1,70 +1,108 @@ -- | -- Module : System.Hapistrano.Types --- Copyright : © 2017 Stack Builders +-- Copyright : © 2015-2017 Stack Builders -- License : MIT -- -- Maintainer : Justin Leitgeb -- Stability : experimental -- Portability : portable -- --- TODO +-- Type definitions for the Hapistrano tool. module System.Hapistrano.Types - ( Config(..) - , FailureResult - , Hapistrano - , Release - , ReleaseFormat(..) - ) where + ( Hapistrano + , Failure (..) + , Config (..) + , Task (..) + , ReleaseFormat(..) + , SshOptions (..) + , Release + , mkRelease + , releaseTime + , renderRelease + , parseRelease ) +where -import Control.Monad.Reader (ReaderT(..)) -import Control.Monad.Trans.Either (EitherT(..)) +import Control.Applicative +import Control.Monad.Except +import Control.Monad.Reader +import Data.Time +import Path --- | 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 +-- | Hapistrano monad. - , repository :: String -- ^ The remote git repo - , revision :: String -- ^ A SHA1 or branch to release +type Hapistrano a = ExceptT Failure (ReaderT Config IO) a - , 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 +-- | Failure with status code and a message. - , buildScript :: Maybe FilePath - -- ^ The local path to a file that should be executed on the remote - -- server to build the application. +data Failure = Failure Int (Maybe String) - , restartCommand :: Maybe String - -- ^ Optional command to restart the server after a successful deploy +-- | Hapistrano configuration options. - , port :: Maybe Integer - -- ^ Optional port to deploy to a different ssh port +data Config = Config + { configSshOptions :: Maybe SshOptions + -- ^ 'Nothing' if we are running locally, or SSH options to use. + } - } deriving (Show) +-- | The records describes deployment task. --- | TODO +data Task = Task + { taskDeployPath :: Path Abs Dir + -- ^ The root of the deploy target on the remote host + , taskRepository :: String + -- ^ The URL of remote Git repo to deploy + , taskRevision :: String + -- ^ A SHA1 or branch to release + , taskReleaseFormat :: ReleaseFormat + -- ^ The 'ReleaseFormat' to use + } deriving (Show, Eq) -data ReleaseFormat = Short - -- ^ Standard release path following Capistrano's format +-- | Release format mode. - | Long - -- ^ Long release path including picoseconds for testing - -- or people seriously into continuous deployment +data ReleaseFormat + = ReleaseShort -- ^ Standard release path following Capistrano's format + | ReleaseLong -- ^ Long release path including picoseconds + deriving (Show, Read, Eq, Ord, Enum, Bounded) - deriving (Show) +-- | SSH options. --- | TODO +data SshOptions = SshOptions + { sshHost :: String -- ^ Host to use + , sshPort :: Word -- ^ Port to use + } deriving (Show, Eq, Ord) -type Release = String +-- | Release indentifier. --- | TODO +data Release = Release ReleaseFormat UTCTime + deriving (Eq, Show, Ord) -type FailureResult = (Int, String) +-- | Create a 'Release' indentifier. --- | TODO +mkRelease :: ReleaseFormat -> UTCTime -> Release +mkRelease = Release -type Hapistrano a = EitherT FailureResult (ReaderT Config IO) a +-- | Extract deployment time from 'Release'. + +releaseTime :: Release -> UTCTime +releaseTime (Release _ time) = time + +-- | Render 'Release' indentifier as a 'String'. + +renderRelease :: Release -> String +renderRelease (Release rfmt time) = formatTime defaultTimeLocale fmt time + where + fmt = case rfmt of + ReleaseShort -> releaseFormatShort + ReleaseLong -> releaseFormatLong + +-- | Parse 'Release' identifier from a 'String'. + +parseRelease :: String -> Maybe Release +parseRelease s = (Release ReleaseLong <$> p releaseFormatLong s) + <|> (Release ReleaseShort <$> p releaseFormatShort s) + where + p = parseTimeM False defaultTimeLocale + +releaseFormatShort, releaseFormatLong :: String +releaseFormatShort = "%Y%m%d%H%M%S" +releaseFormatLong = "%Y%m%d%H%M%S%q"