diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +## 0.4.0.0 +### Added +* Copy a directory's contents with `local_directory` instead of using _git_ with `repo` and `revision`. + +### Changed +* Update upper bounds for `path` and `path-io` packages. + +## 0.3.10.1 +### Added +* Update Dockerfile and maintainer. + ## 0.3.10.0 ### Added * Colorize the output in the terminal. diff --git a/Dockerfile b/Dockerfile --- a/Dockerfile +++ b/Dockerfile @@ -1,23 +1,22 @@ # Build Hapistrano FROM alpine:3.9 as build-env -MAINTAINER Javier Casas +MAINTAINER Nicolas Vivar -RUN echo '@testing http://dl-cdn.alpinelinux.org/alpine/edge/testing' >> /etc/apk/repositories RUN apk update \ && apk add \ alpine-sdk \ bash \ ca-certificates \ - cabal@testing \ - ghc-dev@testing \ - ghc@testing \ + cabal \ + ghc-dev \ + ghc \ git \ gmp-dev \ gnupg \ libffi-dev \ linux-headers \ - upx@testing \ + upx \ zlib-dev WORKDIR /hapistrano diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -32,15 +32,18 @@ ## Usage -Hapistrano 0.3.0.0 looks for a configuration file called `hap.yaml` that +Hapistrano 0.4.0.0 looks for a configuration file called `hap.yaml` that typically looks like this: ```yaml deploy_path: '/var/projects/my-project' host: myserver.com port: 2222 +# To perform version control operations repo: 'https://github.com/stackbuilders/hapistrano.git' revision: origin/master +# To copy the contents of the directory +local_directory: '/tmp/my-project' build_script: - stack setup - stack build @@ -50,10 +53,16 @@ The following parameters are required: * `deploy_path` — the root of the deploy target on the remote host. -* `repo` — the origin repository. -* `revision` — the SHA1 or branch to deploy. If a branch, you will need to - specify it as `origin/branch_name` due to the way that the cache repo is - configured. +* Related to the `source` of the repository, you have the following options: + - _Git repository_ **default** — consists of two parameters. When these are set, + hapistrano will perform version control related operations. + **Note:** Only GitHub is supported. + * `repo` — the origin repository. + * `revision` — the SHA1 or branch to deploy. If a branch, you will need to + specify it as `origin/branch_name` due to the way that the cache repo is + configured. + * `local_directory` — when this parameter is set, hapistrano will copy the + contents of the directory. The following parameters are *optional*: @@ -199,6 +208,25 @@ If you would like to use Docker, there is a lightweight image available on [Docker Hub](https://hub.docker.com/r/stackbuilders/hapistrano/). + +## Nix + +If you want to use Nix for building Hapistrano, the required release.nix and default.nix are available. + +For installing the hap binary in your local path: +```bash +nix-env -i hapistrano -f release.nix +``` +For developing Hapistrano with Nix, you can create a development environment using: +```bash +nix-shell --attr env release.nix +``` + +For just building Hapistrano, you just: +```bash +nix-build release.nix +``` + ## License diff --git a/app/Config.hs b/app/Config.hs deleted file mode 100644 --- a/app/Config.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Config - ( Config (..) - , CopyThing (..) - , Target (..)) -where - -import Data.Aeson -import Data.Function (on) -import Data.List (nubBy) -import Data.Maybe (maybeToList) -import Data.Yaml -import Numeric.Natural -import Path -import System.Hapistrano.Commands -import System.Hapistrano.Types (Shell(..), - ReleaseFormat (..), - TargetSystem (..)) - --- | Hapistrano configuration typically loaded from @hap.yaml@ file. - -data Config = Config - { configDeployPath :: !(Path Abs Dir) - -- ^ Top-level deploy directory on target machine - , configHosts :: ![Target] - -- ^ Hosts\/ports\/shell\/ssh args to deploy to. If empty, localhost will be assumed. - , configRepo :: !String - -- ^ Location of repository that contains the source code to deploy - , configRevision :: !String - -- ^ Revision to use - , configRestartCommand :: !(Maybe GenericCommand) - -- ^ The command to execute when switching to a different release - -- (usually after a deploy or rollback). - , configBuildScript :: !(Maybe [GenericCommand]) - -- ^ Build script to execute to build the project - , configCopyFiles :: ![CopyThing] - -- ^ Collection of files to copy over to target machine before building - , configCopyDirs :: ![CopyThing] - -- ^ Collection of directories to copy over to target machine before building - , configLinkedFiles :: ![FilePath] - -- ^ Collection of files to link from each release to _shared_ - , configLinkedDirs :: ![FilePath] - -- ^ Collection of directories to link from each release to _shared_ - , configVcAction :: !Bool - -- ^ Perform version control related actions. By default, it's assumed to be True. - , configRunLocally :: !(Maybe [GenericCommand]) - -- ^ Perform a series of commands on the local machine before communication - -- with target server starts - , configTargetSystem :: !TargetSystem - -- ^ Optional parameter to specify the target system. It's GNU/Linux by - -- default - , configReleaseFormat :: !(Maybe ReleaseFormat) - -- ^ The release timestamp format, the '--release-format' argument passed via - -- the CLI takes precedence over this value. If neither CLI or configuration - -- file value is specified, it defaults to short - , configKeepReleases :: !(Maybe Natural) - -- ^ The number of releases to keep, the '--keep-releases' argument passed via - -- the CLI takes precedence over this value. If neither CLI or configuration - -- file value is specified, it defaults to 5 - } deriving (Eq, Ord, Show) - --- | Information about source and destination locations of a file\/directory --- to copy. - -data CopyThing = CopyThing FilePath FilePath - deriving (Eq, Ord, Show) - -data Target = - Target - { targetHost :: String - , targetPort :: Word - , targetShell :: Shell - , targetSshArgs :: [String] - } deriving (Eq, Ord, Show) - -instance FromJSON Config where - parseJSON = withObject "Hapistrano configuration" $ \o -> do - configDeployPath <- o .: "deploy_path" - let grabPort m = m .:? "port" .!= 22 - grabShell m = m .:? "shell" .!= Bash - grabSshArgs m = m .:? "ssh_args" .!= [] - host <- o .:? "host" - port <- grabPort o - shell <- grabShell o - sshArgs <- grabSshArgs o - hs <- (o .:? "targets" .!= []) >>= mapM (\m -> - Target - <$> m .: "host" - <*> grabPort m - <*> grabShell m - <*> grabSshArgs m) - let first Target{..} = host - configHosts = nubBy ((==) `on` first) - (maybeToList (Target <$> host <*> pure port <*> pure shell <*> pure sshArgs) ++ hs) - configRepo <- o .: "repo" - configRevision <- o .: "revision" - configRestartCommand <- (o .:? "restart_command") >>= - maybe (return Nothing) (fmap Just . mkCmd) - configBuildScript <- o .:? "build_script" >>= - maybe (return Nothing) (fmap Just . mapM mkCmd) - configCopyFiles <- o .:? "copy_files" .!= [] - configCopyDirs <- o .:? "copy_dirs" .!= [] - configLinkedFiles <- o .:? "linked_files" .!= [] - configLinkedDirs <- o .:? "linked_dirs" .!= [] - configVcAction <- o .:? "vc_action" .!= True - configRunLocally <- o .:? "run_locally" >>= - maybe (return Nothing) (fmap Just . mapM mkCmd) - configTargetSystem <- o .:? "linux" .!= GNULinux - configReleaseFormat <- o .:? "release_format" - configKeepReleases <- o .:? "keep_releases" - return Config {..} - -instance FromJSON CopyThing where - parseJSON = withObject "src and dest of a thing to copy" $ \o -> - CopyThing <$> (o .: "src") <*> (o .: "dest") - -instance FromJSON TargetSystem where - parseJSON = withBool "linux" $ - pure . \case - True -> GNULinux - False -> BSD - -mkCmd :: String -> Parser GenericCommand -mkCmd raw = - case mkGenericCommand raw of - Nothing -> fail "invalid restart command" - Just cmd -> return cmd diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -4,7 +4,6 @@ module Main (main) where -import qualified Config as C import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad @@ -21,6 +20,7 @@ import System.Exit import qualified System.Hapistrano as Hap import qualified System.Hapistrano.Commands as Hap +import qualified System.Hapistrano.Config as C import qualified System.Hapistrano.Core as Hap import System.Hapistrano.Types import System.IO @@ -125,8 +125,7 @@ C.Config{..} <- Yaml.loadYamlSettings [optsConfigFile] [] Yaml.useEnv chan <- newTChanIO let task rf = Task { taskDeployPath = configDeployPath - , taskRepository = configRepo - , taskRevision = configRevision + , taskSource = configSource , taskReleaseFormat = rf } let printFnc dest str = atomically $ writeTChan chan (PrintMsg dest str) @@ -141,6 +140,8 @@ then Hap.pushRelease (task releaseFormat) else Hap.pushReleaseWithoutVc (task releaseFormat) rpath <- Hap.releasePath configDeployPath release + forM_ (toMaybePath configSource) $ \src -> + Hap.scpDir src rpath forM_ configCopyFiles $ \(C.CopyThing src dest) -> do srcPath <- resolveFile' src destPath <- parseRelFile dest diff --git a/hapistrano.cabal b/hapistrano.cabal --- a/hapistrano.cabal +++ b/hapistrano.cabal @@ -1,5 +1,5 @@ name: hapistrano -version: 0.3.10.0 +version: 0.4.0.0 synopsis: A deployment library for Haskell applications description: . @@ -28,7 +28,7 @@ bug-reports: https://github.com/stackbuilders/hapistrano/issues build-type: Simple cabal-version: >=1.18 -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 extra-source-files: CHANGELOG.md , README.md , Dockerfile @@ -48,8 +48,10 @@ hs-source-dirs: src exposed-modules: System.Hapistrano , System.Hapistrano.Commands + , System.Hapistrano.Config , System.Hapistrano.Core , System.Hapistrano.Types + , System.Hapistrano.Commands.Internal build-depends: aeson >= 0.11 && < 1.5 , ansi-terminal >= 0.9 && < 0.11 , base >= 4.8 && < 5.0 @@ -58,11 +60,12 @@ , gitrev >= 1.2 && < 1.4 , mtl >= 2.0 && < 3.0 , stm >= 2.0 && < 2.6 - , path >= 0.5 && < 0.7 + , path >= 0.5 && < 0.8 , process >= 1.4 && < 1.7 , typed-process >= 0.2 && < 0.3 , time >= 1.5 && < 1.10 , transformers >= 0.4 && < 0.6 + , yaml >= 0.8.16 && < 0.12 if flag(dev) ghc-options: -Wall -Werror else @@ -72,8 +75,7 @@ executable hap hs-source-dirs: app main-is: Main.hs - other-modules: Config - , Paths_hapistrano + other-modules: Paths_hapistrano build-depends: aeson >= 0.11 && < 1.5 , async >= 2.0.1.6 && < 2.4 , base >= 4.8 && < 5.0 @@ -81,8 +83,8 @@ , gitrev >= 1.2 && < 1.4 , hapistrano , optparse-applicative >= 0.11 && < 0.16 - , path >= 0.5 && < 0.7 - , path-io >= 1.2 && < 1.5 + , path >= 0.5 && < 0.8 + , path-io >= 1.2 && < 1.7 , stm >= 2.4 && < 2.6 , yaml >= 0.8.16 && < 0.12 if flag(dev) @@ -99,18 +101,21 @@ hs-source-dirs: spec main-is: Spec.hs other-modules: System.HapistranoSpec + , System.HapistranoConfigSpec + , System.HapistranoPropsSpec build-depends: base >= 4.8 && < 5.0 , directory >= 1.2.5 && < 1.4 , filepath >= 1.2 && < 1.5 , hapistrano , hspec >= 2.0 && < 3.0 , mtl >= 2.0 && < 3.0 - , path >= 0.5 && < 0.7 - , path-io >= 1.2 && < 1.5 + , path >= 0.5 && < 0.8 + , path-io >= 1.2 && < 1.7 , process >= 1.4 && < 1.7 , QuickCheck >= 2.5.1 && < 3.0 , silently >= 1.2 && < 1.3 , temporary >= 1.1 && < 1.4 + , yaml >= 0.8.16 && < 0.12 build-tools: hspec-discover >= 2.0 && < 3.0 if flag(dev) diff --git a/spec/System/HapistranoConfigSpec.hs b/spec/System/HapistranoConfigSpec.hs new file mode 100644 --- /dev/null +++ b/spec/System/HapistranoConfigSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TemplateHaskell #-} +module System.HapistranoConfigSpec + ( spec + ) where + +import System.Hapistrano.Config (Config (..), Target (..)) +import System.Hapistrano.Types (Shell (..), + Source (..), TargetSystem (..)) + +import qualified Data.Yaml.Config as Yaml +import Path (mkAbsDir) +import Test.Hspec + + +spec :: Spec +spec = + describe "Hapistrano's configuration file" $ do + context "when the key 'local-repository' is present" $ + it "loads LocalRepository as the configuration's source" $ + Yaml.loadYamlSettings ["fixtures/local_directory_config.yaml"] [] Yaml.useEnv + >>= + (`shouldBe` + (defaultConfiguration + { configSource = LocalDirectory { localDirectoryPath = $(mkAbsDir "/") } } + ) + ) + + context "when the keys 'repo' and 'revision' are present" $ + it "loads GitRepository as the configuration's source" $ + Yaml.loadYamlSettings ["fixtures/git_repository_config.yaml"] [] Yaml.useEnv + >>= (`shouldBe` defaultConfiguration) + + +defaultConfiguration :: Config +defaultConfiguration = + Config + { configDeployPath = $(mkAbsDir "/") + , configHosts = + [ Target + { targetHost = "www.example.com" + , targetPort = 22 + , targetShell = Bash + , targetSshArgs = [] + } + ] + + , configSource = GitRepository "my-repo" "my-revision" + , configRestartCommand = Nothing + , configBuildScript = Nothing + , configCopyFiles = [] + , configCopyDirs = [] + , configLinkedFiles = [] + , configLinkedDirs = [] + , configVcAction = True + , configRunLocally = Nothing + , configTargetSystem = GNULinux + , configReleaseFormat = Nothing + , configKeepReleases = Nothing + } diff --git a/spec/System/HapistranoPropsSpec.hs b/spec/System/HapistranoPropsSpec.hs new file mode 100644 --- /dev/null +++ b/spec/System/HapistranoPropsSpec.hs @@ -0,0 +1,85 @@ +module System.HapistranoPropsSpec + ( spec + ) where + +import Data.Char (isSpace) +import System.Hapistrano.Commands.Internal (mkGenericCommand, + quoteCmd, trim, + unGenericCommand) +import Test.Hspec hiding (shouldBe, + shouldReturn) +import Test.QuickCheck + +spec :: Spec +spec = + describe "QuickCheck" $ + context "Properties" $ do + it "property of quote command" $ property propQuote' + it "property of trimming a command" $ + property $ forAll trimGenerator propTrim' + it "property of mkGenericCommand and unGenericCommand" $ + property $ forAll genericCmdGenerator propGenericCmd' + +-- Is quoted determine +isQuoted :: String -> Bool +isQuoted str = head str == '"' && last str == '"' + +-- | Quote function property +propQuote :: String -> Bool +propQuote str = + if any isSpace str + then isQuoted $ quoteCmd str + else quoteCmd str == str + +propQuote' :: String -> Property +propQuote' str = + classify (any isSpace str) "has at least a space" $ propQuote str + +-- | Is trimmed +isTrimmed' :: String -> Bool +isTrimmed' [] = True +isTrimmed' [x] = not $ isSpace x +isTrimmed' str = + let a = not . isSpace $ head str + b = not . isSpace $ last str + in a && b + +-- | Prop trimm +propTrim :: String -> Bool +propTrim = isTrimmed' . trim + +propTrim' :: String -> Property +propTrim' str = + classify (not $ isTrimmed' str) "non trimmed strings" $ propTrim str + +-- | Check that the string is perfect command String +isCmdString :: String -> Bool +isCmdString str = all ($str) [not . null, notElem '#', notElem '\n', isTrimmed'] + +-- | Prop Generic Command +-- If the string does not contain # or \n, is trimmed and non null, the command should be created +propGenericCmd :: String -> Bool +propGenericCmd str = + if isCmdString str + then maybe False ((== str) . unGenericCommand) (mkGenericCommand str) + else maybe True ((/= str) . unGenericCommand) (mkGenericCommand str) -- Either the command cannot be created or the command str is different to the original + +propGenericCmd' :: String -> Property +propGenericCmd' str = + classify (isCmdString str) "perfect command string" propGenericCmd + +-- | Trim String Generator +trimGenerator :: Gen String +trimGenerator = + let strGen = listOf arbitraryUnicodeChar + in frequency + [ (1, suchThat strGen isTrimmed') + , (1, suchThat strGen (not . isTrimmed')) + ] + +-- | Generic Command generator +genericCmdGenerator :: Gen String +genericCmdGenerator = + let strGen = listOf $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ [' ', '#', '*', '/', '.'] + in frequency + [(1, suchThat strGen isCmdString), (1, suchThat strGen (elem '#'))] diff --git a/spec/System/HapistranoSpec.hs b/spec/System/HapistranoSpec.hs --- a/spec/System/HapistranoSpec.hs +++ b/spec/System/HapistranoSpec.hs @@ -1,28 +1,30 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module System.HapistranoSpec - ( spec ) -where + ( spec + ) where -import Control.Monad -import Control.Monad.Reader -import Data.List (isPrefixOf) -import Data.Maybe (mapMaybe) -import Numeric.Natural -import Path -import Path.IO -import System.Directory (listDirectory) -import qualified System.Hapistrano as Hap +import Control.Monad +import Control.Monad.Reader +import Data.Char (isSpace) +import Data.List (isPrefixOf) +import Data.Maybe (mapMaybe) +import Numeric.Natural +import Path +import Path.IO +import System.Directory (listDirectory) +import qualified System.Hapistrano as Hap import qualified System.Hapistrano.Commands as Hap -import qualified System.Hapistrano.Core as Hap -import System.Hapistrano.Types -import System.IO.Silently (capture_) -import System.Info (os) -import System.IO -import Test.Hspec hiding (shouldBe, shouldReturn) -import qualified Test.Hspec as Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck +import qualified System.Hapistrano.Core as Hap +import System.Hapistrano.Types +import System.IO +import System.IO.Silently (capture_) +import System.Info (os) +import Test.Hspec hiding (shouldBe, shouldReturn) +import qualified Test.Hspec as Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck testBranchName :: String testBranchName = "another_branch" @@ -31,296 +33,300 @@ spec = do describe "execWithInheritStdout" $ context "given a command that prints to stdout" $ - it "redirects commands' output to stdout first" $ - let (Just commandTest) = Hap.mkGenericCommand "echo \"hapistrano\"; sleep 2; echo \"onartsipah\"" - commandExecution = Hap.execWithInheritStdout commandTest - expectedOutput = "hapistrano\nonartsipah" - in do - actualOutput <- capture_ (runHap commandExecution) + it "redirects commands' output to stdout first" $ + let (Just commandTest) = + Hap.mkGenericCommand + "echo \"hapistrano\"; sleep 2; echo \"onartsipah\"" + commandExecution = Hap.execWithInheritStdout commandTest + expectedOutput = "hapistrano\nonartsipah" + in do actualOutput <- capture_ (runHap commandExecution) expectedOutput `Hspec.shouldSatisfy` (`isPrefixOf` actualOutput) - describe "readScript" $ it "performs all the necessary normalizations correctly" $ do +#if MIN_VERSION_path_io(1,6,0) + let spath = $(mkRelFile "script/clean-build.sh") +#else spath <- makeAbsolute $(mkRelFile "script/clean-build.sh") - (fmap Hap.unGenericCommand <$> Hap.readScript spath) - `Hspec.shouldReturn` +#endif + (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" ] - + , "cabal build -j" + ] describe "fromMaybeReleaseFormat" $ do context "when the command line value is present" $ do context "and the config file value is present" $ prop "returns the command line value" $ - forAll ((,) <$> arbitraryReleaseFormat <*> arbitraryReleaseFormat) $ - \(rf1, rf2) -> fromMaybeReleaseFormat (Just rf1) (Just rf2) `Hspec.shouldBe` rf1 - + forAll ((,) <$> arbitraryReleaseFormat <*> arbitraryReleaseFormat) $ \(rf1, rf2) -> + fromMaybeReleaseFormat (Just rf1) (Just rf2) `Hspec.shouldBe` rf1 context "and the config file value is not present" $ - prop "returns the command line value" $ forAll arbitraryReleaseFormat $ \rf -> + prop "returns the command line value" $ + forAll arbitraryReleaseFormat $ \rf -> fromMaybeReleaseFormat (Just rf) Nothing `Hspec.shouldBe` rf - context "when the command line value is not present" $ do context "and the config file value is present" $ - prop "returns the config file value" $ forAll arbitraryReleaseFormat $ \rf -> + prop "returns the config file value" $ + forAll arbitraryReleaseFormat $ \rf -> fromMaybeReleaseFormat Nothing (Just rf) `Hspec.shouldBe` rf - context "and the config file value is not present" $ it "returns the default value" $ - fromMaybeReleaseFormat Nothing Nothing `Hspec.shouldBe` ReleaseShort - - + fromMaybeReleaseFormat Nothing Nothing `Hspec.shouldBe` ReleaseShort describe "fromMaybeKeepReleases" $ do context "when the command line value is present" $ do context "and the config file value is present" $ prop "returns the command line value" $ - forAll ((,) <$> arbitraryKeepReleases <*> arbitraryKeepReleases) $ - \(kr1, kr2) -> fromMaybeKeepReleases (Just kr1) (Just kr2) `Hspec.shouldBe` kr1 - + forAll ((,) <$> arbitraryKeepReleases <*> arbitraryKeepReleases) $ \(kr1, kr2) -> + fromMaybeKeepReleases (Just kr1) (Just kr2) `Hspec.shouldBe` kr1 context "and the second value is not present" $ - prop "returns the command line value" $ forAll arbitraryKeepReleases $ \kr -> + prop "returns the command line value" $ + forAll arbitraryKeepReleases $ \kr -> fromMaybeKeepReleases (Just kr) Nothing `Hspec.shouldBe` kr - context "when the command line value is not present" $ do context "and the config file value is present" $ - prop "returns the config file value" $ forAll arbitraryKeepReleases $ \kr -> + prop "returns the config file value" $ + forAll arbitraryKeepReleases $ \kr -> fromMaybeKeepReleases Nothing (Just kr) `Hspec.shouldBe` kr - context "and the config file value is not present" $ it "returns the default value" $ - fromMaybeKeepReleases Nothing Nothing `Hspec.shouldBe` 5 - + fromMaybeKeepReleases Nothing Nothing `Hspec.shouldBe` 5 around withSandbox $ do describe "pushRelease" $ do - it "sets up repo all right in Zsh" $ \(deployPath, repoPath) -> runHapWithShell Zsh $ do - let task = mkTask deployPath repoPath - release <- Hap.pushRelease task - rpath <- Hap.releasePath deployPath release + it "sets up repo all right in Zsh" $ \(deployPath, repoPath) -> + runHapWithShell Zsh $ 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" - - it "sets up repo all right" $ \(deployPath, repoPath) -> runHap $ do - let task = mkTask deployPath repoPath - release <- Hap.pushRelease task - rpath <- Hap.releasePath deployPath release + (liftIO . readFile . fromAbsFile) (rpath $(mkRelFile "foo.txt")) `shouldReturn` + "Foo!\n" + 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" - - it "deploys properly a branch other than master" $ \(deployPath, repoPath) -> runHap $ do - let task = mkTaskWithCustomRevision deployPath repoPath testBranchName - release <- Hap.pushRelease task - rpath <- Hap.releasePath deployPath release + (liftIO . readFile . fromAbsFile) (rpath $(mkRelFile "foo.txt")) `shouldReturn` + "Foo!\n" + it "deploys properly a branch other than master" $ \(deployPath, repoPath) -> + runHap $ do + let task = mkTaskWithCustomRevision deployPath repoPath testBranchName + 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 "bar.txt")) - `shouldReturn` "Bar!\n" + (liftIO . readFile . fromAbsFile) (rpath $(mkRelFile "bar.txt")) `shouldReturn` + "Bar!\n" -- This fails if the opened branch is not testBranchName - justExec rpath ("test `git rev-parse --abbrev-ref HEAD` = " ++ testBranchName) + justExec + rpath + ("test `git rev-parse --abbrev-ref HEAD` = " ++ testBranchName) -- This fails if there are unstaged changes - justExec rpath "git diff --exit-code" - + justExec rpath "git diff --exit-code" describe "registerReleaseAsComplete" $ - it "creates the token all right" $ \(deployPath, repoPath) -> runHap $ do - let task = mkTask deployPath repoPath - release <- Hap.pushRelease task - Hap.registerReleaseAsComplete deployPath release - (Hap.ctokenPath deployPath release >>= doesFileExist) `shouldReturn` True - + it "creates the token all right" $ \(deployPath, repoPath) -> + runHap $ do + let task = mkTask deployPath repoPath + release <- Hap.pushRelease task + Hap.registerReleaseAsComplete deployPath release + (Hap.ctokenPath deployPath release >>= doesFileExist) `shouldReturn` + True describe "activateRelease" $ - it "creates the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> runHap $ do - let task = mkTask deployPath repoPath - release <- Hap.pushRelease task - Hap.activateRelease currentSystem deployPath release - rpath <- Hap.releasePath deployPath release - let rc :: Hap.Readlink Dir - rc = Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath) - Hap.exec rc `shouldReturn` rpath - doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False - - describe "playScriptLocally (successful run)" $ - it "check that local scripts are run and deployment is successful" $ \(deployPath, repoPath) -> runHap $ do - let localCommands = mapMaybe Hap.mkGenericCommand ["pwd", "ls"] - task = mkTask deployPath repoPath - Hap.playScriptLocally localCommands - release <- Hap.pushRelease task - Hap.registerReleaseAsComplete deployPath release - (Hap.ctokenPath deployPath release >>= doesFileExist) `shouldReturn` True - - describe "playScriptLocally (error exit)" $ - it "check that deployment isn't done" $ \(deployPath, repoPath) -> (runHap $ do - let localCommands = mapMaybe Hap.mkGenericCommand ["pwd", "ls", "false"] - task = mkTask deployPath repoPath - Hap.playScriptLocally localCommands - release <- Hap.pushRelease task - Hap.registerReleaseAsComplete deployPath release) `shouldThrow` anyException - - describe "rollback" $ do - context "without completion tokens" $ - it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> runHap $ do + it "creates the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> + runHap $ do let task = mkTask deployPath repoPath - rs <- replicateM 5 (Hap.pushRelease task) - Hap.rollback currentSystem deployPath 2 - rpath <- Hap.releasePath deployPath (rs !! 2) + release <- Hap.pushRelease task + Hap.activateRelease currentSystem deployPath release + rpath <- Hap.releasePath deployPath release let rc :: Hap.Readlink Dir - rc = Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath) + rc = + Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath) Hap.exec rc `shouldReturn` rpath doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False + describe "playScriptLocally (successful run)" $ + it "check that local scripts are run and deployment is successful" $ \(deployPath, repoPath) -> + runHap $ do + let localCommands = mapMaybe Hap.mkGenericCommand ["pwd", "ls"] + task = mkTask deployPath repoPath + Hap.playScriptLocally localCommands + release <- Hap.pushRelease task + Hap.registerReleaseAsComplete deployPath release + (Hap.ctokenPath deployPath release >>= doesFileExist) `shouldReturn` + True + describe "playScriptLocally (error exit)" $ + it "check that deployment isn't done" $ \(deployPath, repoPath) -> + (runHap $ do + let localCommands = + mapMaybe Hap.mkGenericCommand ["pwd", "ls", "false"] + task = mkTask deployPath repoPath + Hap.playScriptLocally localCommands + release <- Hap.pushRelease task + Hap.registerReleaseAsComplete deployPath release) `shouldThrow` + anyException + describe "rollback" $ do + context "without completion tokens" $ + it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> + runHap $ do + let task = mkTask deployPath repoPath + rs <- replicateM 5 (Hap.pushRelease task) + Hap.rollback currentSystem deployPath 2 + rpath <- Hap.releasePath deployPath (rs !! 2) + let rc :: Hap.Readlink Dir + rc = + Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath) + Hap.exec rc `shouldReturn` rpath + doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False context "with completion tokens" $ - it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> runHap $ do - let task = mkTask deployPath repoPath - rs <- replicateM 5 (Hap.pushRelease task) - forM_ (take 3 rs) (Hap.registerReleaseAsComplete deployPath) - Hap.rollback currentSystem deployPath 2 - rpath <- Hap.releasePath deployPath (rs !! 0) - let rc :: Hap.Readlink Dir - rc = Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath) - Hap.exec rc `shouldReturn` rpath - doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False - + it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> + runHap $ do + let task = mkTask deployPath repoPath + rs <- replicateM 5 (Hap.pushRelease task) + forM_ (take 3 rs) (Hap.registerReleaseAsComplete deployPath) + Hap.rollback currentSystem deployPath 2 + rpath <- Hap.releasePath deployPath (rs !! 0) + let rc :: Hap.Readlink Dir + rc = + Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath) + Hap.exec rc `shouldReturn` rpath + doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False describe "dropOldReleases" $ - it "works" $ \(deployPath, repoPath) -> runHap $ do - rs <- replicateM 7 $ do - r <- Hap.pushRelease (mkTask deployPath repoPath) - Hap.registerReleaseAsComplete deployPath r - return r - Hap.dropOldReleases deployPath 5 + it "works" $ \(deployPath, repoPath) -> + runHap $ do + rs <- + replicateM 7 $ do + r <- Hap.pushRelease (mkTask deployPath repoPath) + Hap.registerReleaseAsComplete deployPath r + return r + Hap.dropOldReleases deployPath 5 -- two oldest releases should not survive: - forM_ (take 2 rs) $ \r -> - (Hap.releasePath deployPath r >>= doesDirExist) - `shouldReturn` False + 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 + forM_ (drop 2 rs) $ \r -> + (Hap.releasePath deployPath r >>= doesDirExist) `shouldReturn` True -- two oldest completion tokens should not survive: - forM_ (take 2 rs) $ \r -> - (Hap.ctokenPath deployPath r >>= doesFileExist) - `shouldReturn` False + forM_ (take 2 rs) $ \r -> + (Hap.ctokenPath deployPath r >>= doesFileExist) `shouldReturn` False -- 5 most recent completion tokens should stay alive: - forM_ (drop 2 rs) $ \r -> - (Hap.ctokenPath deployPath r >>= doesFileExist) - `shouldReturn` True - + forM_ (drop 2 rs) $ \r -> + (Hap.ctokenPath deployPath r >>= doesFileExist) `shouldReturn` True describe "linkToShared" $ do context "when the deploy_path/shared directory doesn't exist" $ - it "should create the link anyway" $ \(deployPath, repoPath) -> runHap $ do - let task = mkTask deployPath repoPath - sharedDir = Hap.sharedPath deployPath - release <- Hap.pushRelease task - rpath <- Hap.releasePath deployPath release - Hap.exec $ Hap.Rm sharedDir - Hap.linkToShared currentSystem rpath deployPath "thing" - `shouldReturn` () - - context "when the file/directory to link exists in the respository" $ - it "should throw an error" $ \(deployPath, repoPath) -> runHap (do - let task = mkTask deployPath repoPath - release <- Hap.pushRelease task - rpath <- Hap.releasePath deployPath release - Hap.linkToShared currentSystem rpath deployPath "foo.txt") - `shouldThrow` anyException - - context "when it attemps to link a file" $ do - context "when the file is not at the root of the shared directory" $ - it "should throw an error" $ \(deployPath, repoPath) -> runHap (do + it "should create the link anyway" $ \(deployPath, repoPath) -> + runHap $ do let task = mkTask deployPath repoPath sharedDir = Hap.sharedPath deployPath release <- Hap.pushRelease task - rpath <- Hap.releasePath deployPath release - justExec sharedDir "mkdir foo/" - justExec sharedDir "echo 'Bar!' > foo/bar.txt" - Hap.linkToShared currentSystem rpath deployPath "foo/bar.txt") - `shouldThrow` anyException - + rpath <- Hap.releasePath deployPath release + Hap.exec $ Hap.Rm sharedDir + Hap.linkToShared currentSystem rpath deployPath "thing" `shouldReturn` + () + context "when the file/directory to link exists in the respository" $ + it "should throw an error" $ \(deployPath, repoPath) -> + runHap + (do let task = mkTask deployPath repoPath + release <- Hap.pushRelease task + rpath <- Hap.releasePath deployPath release + Hap.linkToShared currentSystem rpath deployPath "foo.txt") `shouldThrow` + anyException + context "when it attemps to link a file" $ do + context "when the file is not at the root of the shared directory" $ + it "should throw an error" $ \(deployPath, repoPath) -> + runHap + (do let task = mkTask deployPath repoPath + sharedDir = Hap.sharedPath deployPath + release <- Hap.pushRelease task + rpath <- Hap.releasePath deployPath release + justExec sharedDir "mkdir foo/" + justExec sharedDir "echo 'Bar!' > foo/bar.txt" + Hap.linkToShared currentSystem rpath deployPath "foo/bar.txt") `shouldThrow` + anyException context "when the file is at the root of the shared directory" $ - it "should link the file successfully" $ \(deployPath, repoPath) -> runHap $ do - let task = mkTask deployPath repoPath - sharedDir = Hap.sharedPath deployPath - release <- Hap.pushRelease task - rpath <- Hap.releasePath deployPath release - justExec sharedDir "echo 'Bar!' > bar.txt" - Hap.linkToShared currentSystem rpath deployPath "bar.txt" - (liftIO . readFile . fromAbsFile) (rpath $(mkRelFile "bar.txt")) - `shouldReturn` "Bar!\n" - + it "should link the file successfully" $ \(deployPath, repoPath) -> + runHap $ do + let task = mkTask deployPath repoPath + sharedDir = Hap.sharedPath deployPath + release <- Hap.pushRelease task + rpath <- Hap.releasePath deployPath release + justExec sharedDir "echo 'Bar!' > bar.txt" + Hap.linkToShared currentSystem rpath deployPath "bar.txt" + (liftIO . readFile . fromAbsFile) + (rpath $(mkRelFile "bar.txt")) `shouldReturn` + "Bar!\n" context "when it attemps to link a directory" $ do context "when the directory ends in '/'" $ - it "should throw an error" $ \(deployPath, repoPath) -> runHap (do + it "should throw an error" $ \(deployPath, repoPath) -> + runHap + (do let task = mkTask deployPath repoPath + sharedDir = Hap.sharedPath deployPath + release <- Hap.pushRelease task + rpath <- Hap.releasePath deployPath release + justExec sharedDir "mkdir foo/" + justExec sharedDir "echo 'Bar!' > foo/bar.txt" + justExec sharedDir "echo 'Baz!' > foo/baz.txt" + Hap.linkToShared currentSystem rpath deployPath "foo/") `shouldThrow` + anyException + it "should link the file successfully" $ \(deployPath, repoPath) -> + runHap $ do let task = mkTask deployPath repoPath sharedDir = Hap.sharedPath deployPath release <- Hap.pushRelease task - rpath <- Hap.releasePath deployPath release + rpath <- Hap.releasePath deployPath release justExec sharedDir "mkdir foo/" justExec sharedDir "echo 'Bar!' > foo/bar.txt" justExec sharedDir "echo 'Baz!' > foo/baz.txt" - Hap.linkToShared currentSystem rpath deployPath "foo/") - `shouldThrow` anyException - - it "should link the file successfully" $ \(deployPath, repoPath) -> runHap $ do - let task = mkTask deployPath repoPath - sharedDir = Hap.sharedPath deployPath - release <- Hap.pushRelease task - rpath <- Hap.releasePath deployPath release - justExec sharedDir "mkdir foo/" - justExec sharedDir "echo 'Bar!' > foo/bar.txt" - justExec sharedDir "echo 'Baz!' > foo/baz.txt" - Hap.linkToShared currentSystem rpath deployPath "foo" - files <- (liftIO . listDirectory . fromAbsDir) (rpath $(mkRelDir "foo")) - liftIO $ files `shouldMatchList` ["baz.txt","bar.txt"] + Hap.linkToShared currentSystem rpath deployPath "foo" + files <- + (liftIO . listDirectory . fromAbsDir) + (rpath $(mkRelDir "foo")) + liftIO $ files `shouldMatchList` ["baz.txt", "bar.txt"] ---------------------------------------------------------------------------- -- Helpers - infix 1 `shouldBe`, `shouldReturn` -- | Lifted 'Hspec.shouldBe'. - shouldBe :: (MonadIO m, Show a, Eq a) => a -> a -> m () shouldBe x y = liftIO (x `Hspec.shouldBe` y) -- | Lifted 'Hspec.shouldReturn'. - shouldReturn :: (MonadIO m, Show a, Eq a) => m a -> a -> m () shouldReturn m y = m >>= (`shouldBe` y) -- | The sandbox prepares the environment for an independent round of -- testing. It provides two paths: deploy path and path where git repo is -- located. - 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) +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) -- | Given path where to put the repo, generate it for testing. - 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'" +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'" -- Add dummy content to a branch that is not master - justExec path ("git checkout -b " ++ testBranchName) - justExec path "echo 'Bar!' > bar.txt" - justExec path "git add bar.txt" - justExec path "git commit -m 'Added more bars to another branch'" - justExec path "git checkout master" - + justExec path ("git checkout -b " ++ testBranchName) + justExec path "echo 'Bar!' > bar.txt" + justExec path "git add bar.txt" + justExec path "git commit -m 'Added more bars to another branch'" + justExec path "git checkout master" -- | Execute arbitrary commands in the specified directory. - justExec :: Path Abs Dir -> String -> Hapistrano () justExec path cmd' = case Hap.mkGenericCommand cmd' of @@ -328,12 +334,10 @@ Just cmd -> Hap.exec (Hap.Cd path cmd) -- | Run 'Hapistrano' monad locally. - runHap :: Hapistrano a -> IO a runHap = runHapWithShell Bash -- | Run 'Hapistrano' monad setting a particular shell. - runHapWithShell :: Shell -> Hapistrano a -> IO a runHapWithShell shell m = do let printFnc dest str = @@ -349,24 +353,30 @@ Right x -> return x -- | Make a 'Task' given deploy path and path to the repo. - mkTask :: Path Abs Dir -> Path Abs Dir -> Task -mkTask deployPath repoPath = mkTaskWithCustomRevision deployPath repoPath "master" +mkTask deployPath repoPath = + mkTaskWithCustomRevision deployPath repoPath "master" mkTaskWithCustomRevision :: Path Abs Dir -> Path Abs Dir -> String -> Task -mkTaskWithCustomRevision deployPath repoPath revision = Task - { taskDeployPath = deployPath - , taskRepository = fromAbsDir repoPath - , taskRevision = revision - , taskReleaseFormat = ReleaseLong } +mkTaskWithCustomRevision deployPath repoPath revision = + Task + { taskDeployPath = deployPath + , taskSource = + GitRepository + { gitRepositoryURL = fromAbsDir repoPath + , gitRepositoryRevision = revision + } + , taskReleaseFormat = ReleaseLong + } currentSystem :: TargetSystem -currentSystem = if os == "linux" - then GNULinux - else BSD +currentSystem = + if os == "linux" + then GNULinux + else BSD arbitraryReleaseFormat :: Gen ReleaseFormat arbitraryReleaseFormat = elements [ReleaseShort, ReleaseLong] arbitraryKeepReleases :: Gen Natural -arbitraryKeepReleases = fromInteger . getPositive <$> arbitrary +arbitraryKeepReleases = fromInteger . getPositive <$> arbitrary diff --git a/src/System/Hapistrano.hs b/src/System/Hapistrano.hs --- a/src/System/Hapistrano.hs +++ b/src/System/Hapistrano.hs @@ -55,11 +55,18 @@ pushRelease :: Task -> Hapistrano Release pushRelease Task {..} = do setupDirs taskDeployPath - ensureCacheInPlace taskRepository taskDeployPath - release <- newRelease taskReleaseFormat - cloneToRelease taskDeployPath release - setReleaseRevision taskDeployPath release taskRevision - return release + pushReleaseForRepository taskSource + where + -- When the configuration is set for a local directory, it will only create + -- the release directory without any version control operations. + pushReleaseForRepository GitRepository {..} = do + ensureCacheInPlace gitRepositoryURL taskDeployPath + release <- newRelease taskReleaseFormat + cloneToRelease taskDeployPath release + setReleaseRevision taskDeployPath release gitRepositoryRevision + return release + pushReleaseForRepository LocalDirectory {..} = + newRelease taskReleaseFormat -- | Same as 'pushRelease' but doesn't perform any version control -- related operations. diff --git a/src/System/Hapistrano/Commands.hs b/src/System/Hapistrano/Commands.hs --- a/src/System/Hapistrano/Commands.hs +++ b/src/System/Hapistrano/Commands.hs @@ -9,308 +9,31 @@ -- -- Collection of type safe shell commands that can be fed into -- 'System.Hapistrano.Core.runCommand'. - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module System.Hapistrano.Commands - ( Command (..) - , Whoami (..) - , Cd (..) - , MkDir (..) - , Rm (..) - , Mv (..) - , Ln (..) - , Ls (..) - , Readlink (..) - , Find (..) - , Touch (..) - , GitCheckout (..) - , GitClone (..) - , GitFetch (..) - , GitReset (..) + ( Command(..) + , Whoami(..) + , Cd(..) + , MkDir(..) + , Rm(..) + , Mv(..) + , Ln(..) + , Ls(..) + , Readlink(..) + , Find(..) + , Touch(..) + , GitCheckout(..) + , 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, fromJust, mapMaybe) -import Data.Proxy -import Numeric.Natural -import Path - -import System.Hapistrano.Types (TargetSystem (..)) - ----------------------------------------------------------------------------- --- 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 " ++ quoteCmd (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 "-rf" - , Just (toFilePath path) ] - parseResult Proxy _ = () - --- | Move or rename files or directories. - -data Mv t = Mv TargetSystem (Path Abs t) (Path Abs t) - -instance Command (Mv File) where - type Result (Mv File) = () - renderCommand (Mv ts old new) = formatCmd "mv" - [ Just flags - , Just (fromAbsFile old) - , Just (fromAbsFile new) ] - where flags = if isLinux ts then "-fvT" else "-fv" - 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 :: TargetSystem -> Path Abs t -> Path Abs File -> Ln - -instance Command Ln where - type Result Ln = () - renderCommand (Ln ts target linkName) = formatCmd "ln" - [ Just flags - , Just (toFilePath target) - , Just (fromAbsFile linkName) ] - where flags = if isLinux ts then "-svT" else "-sv" - parseResult Proxy _ = () - --- | Read link. - -data Readlink t = Readlink TargetSystem (Path Abs File) - -instance Command (Readlink File) where - type Result (Readlink File) = Path Abs File - renderCommand (Readlink ts path) = formatCmd "readlink" - [ flags - , Just (toFilePath path) ] - where flags = if isLinux ts then Just "-f" else Nothing - parseResult Proxy = fromJust . parseAbsFile . trim - -instance Command (Readlink Dir) where - type Result (Readlink Dir) = Path Abs Dir - renderCommand (Readlink ts path) = formatCmd "readlink" - [ flags - , Just (toFilePath path) ] - where flags = if isLinux ts then Just "-f" else Nothing - 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). - -data Find t = Find Natural (Path Abs Dir) - -instance Command (Find Dir) where - type Result (Find Dir) = [Path Abs Dir] - renderCommand (Find maxDepth dir) = formatCmd "find" - [ Just (fromAbsDir dir) - , Just "-maxdepth" - , Just (show maxDepth) - , Just "-type" - , Just "d" ] - parseResult Proxy = mapMaybe parseAbsDir . fmap trim . lines - -instance Command (Find File) where - type Result (Find File) = [Path Abs File] - renderCommand (Find maxDepth dir) = formatCmd "find" - [ Just (fromAbsDir dir) - , Just "-maxdepth" - , Just (show maxDepth) - , Just "-type" - , Just "f" ] - parseResult Proxy = mapMaybe parseAbsFile . fmap trim . lines - --- | @touch@. - -data Touch = Touch (Path Abs File) - -instance Command Touch where - type Result Touch = () - renderCommand (Touch path) = formatCmd "touch" - [ Just (fromAbsFile path) ] - parseResult Proxy _ = () - --- | Git checkout. - -data GitCheckout = GitCheckout String - -instance Command GitCheckout where - type Result GitCheckout = () - renderCommand (GitCheckout revision) = formatCmd "git" - [ Just "checkout" - , Just revision ] - parseResult Proxy _ = () - --- | 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 - , Just "+refs/heads/\\*:refs/heads/\\*" ] - 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 $ mapMaybe mkGenericCommand . lines - <$> readFile (fromAbsFile path) - ----------------------------------------------------------------------------- --- Helpers - --- | Format a command. - -formatCmd :: String -> [Maybe String] -> String -formatCmd cmd args = unwords (quoteCmd <$> (cmd : catMaybes args)) - --- | Simple-minded quoter. - -quoteCmd :: String -> String -quoteCmd str = - if any isSpace str - then "\"" ++ str ++ "\"" - else str - --- | Trim whitespace from beginning and end. - -trim :: String -> String -trim = dropWhileEnd isSpace . dropWhile isSpace + , readScript + ) where -isLinux :: TargetSystem -> Bool -isLinux = (== GNULinux) +import System.Hapistrano.Commands.Internal diff --git a/src/System/Hapistrano/Commands/Internal.hs b/src/System/Hapistrano/Commands/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Hapistrano/Commands/Internal.hs @@ -0,0 +1,294 @@ +-- | +-- Module : System.Hapistrano.Commands +-- Copyright : © 2015-Present Stack Builders +-- License : MIT +-- +-- Maintainer : Juan Paucar +-- 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.Internal where + +import Control.Monad.IO.Class +import Data.Char (isSpace) +import Data.List (dropWhileEnd) +import Data.Maybe (catMaybes, fromJust, mapMaybe) +import Data.Proxy +import Numeric.Natural +import Path + +import System.Hapistrano.Types (TargetSystem (..)) + +---------------------------------------------------------------------------- +-- 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 " ++ quoteCmd (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 "-rf", Just (toFilePath path)] + parseResult Proxy _ = () + +-- | Move or rename files or directories. +data Mv t = + Mv TargetSystem (Path Abs t) (Path Abs t) + +instance Command (Mv File) where + type Result (Mv File) = () + renderCommand (Mv ts old new) = + formatCmd "mv" [Just flags, Just (fromAbsFile old), Just (fromAbsFile new)] + where + flags = + if isLinux ts + then "-fvT" + else "-fv" + 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 :: TargetSystem -> Path Abs t -> Path Abs File -> Ln + +instance Command Ln where + type Result Ln = () + renderCommand (Ln ts target linkName) = + formatCmd + "ln" + [Just flags, Just (toFilePath target), Just (fromAbsFile linkName)] + where + flags = + if isLinux ts + then "-svT" + else "-sv" + parseResult Proxy _ = () + +-- | Read link. +data Readlink t = + Readlink TargetSystem (Path Abs File) + +instance Command (Readlink File) where + type Result (Readlink File) = Path Abs File + renderCommand (Readlink ts path) = + formatCmd "readlink" [flags, Just (toFilePath path)] + where + flags = + if isLinux ts + then Just "-f" + else Nothing + parseResult Proxy = fromJust . parseAbsFile . trim + +instance Command (Readlink Dir) where + type Result (Readlink Dir) = Path Abs Dir + renderCommand (Readlink ts path) = + formatCmd "readlink" [flags, Just (toFilePath path)] + where + flags = + if isLinux ts + then Just "-f" + else Nothing + 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). +data Find t = + Find Natural (Path Abs Dir) + +instance Command (Find Dir) where + type Result (Find Dir) = [Path Abs Dir] + renderCommand (Find maxDepth dir) = + formatCmd + "find" + [ Just (fromAbsDir dir) + , Just "-maxdepth" + , Just (show maxDepth) + , Just "-type" + , Just "d" + ] + parseResult Proxy = mapMaybe (parseAbsDir . trim) . lines + +instance Command (Find File) where + type Result (Find File) = [Path Abs File] + renderCommand (Find maxDepth dir) = + formatCmd + "find" + [ Just (fromAbsDir dir) + , Just "-maxdepth" + , Just (show maxDepth) + , Just "-type" + , Just "f" + ] + parseResult Proxy = mapMaybe (parseAbsFile . trim) . lines + +-- | @touch@. +data Touch = + Touch (Path Abs File) + +instance Command Touch where + type Result Touch = () + renderCommand (Touch path) = formatCmd "touch" [Just (fromAbsFile path)] + parseResult Proxy _ = () + +-- | Git checkout. +data GitCheckout = + GitCheckout String + +instance Command GitCheckout where + type Result GitCheckout = () + renderCommand (GitCheckout revision) = + formatCmd "git" [Just "checkout", Just revision] + parseResult Proxy _ = () + +-- | 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, Just "+refs/heads/\\*:refs/heads/\\*"] + 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 $ mapMaybe mkGenericCommand . lines <$> readFile (fromAbsFile path) + +---------------------------------------------------------------------------- +-- Helpers +-- | Format a command. +formatCmd :: String -> [Maybe String] -> String +formatCmd cmd args = unwords (quoteCmd <$> (cmd : catMaybes args)) + +-- | Simple-minded quoter. +quoteCmd :: String -> String +quoteCmd str = + if any isSpace str + then "\"" ++ str ++ "\"" + else str + +-- | Trim whitespace from beginning and end. +trim :: String -> String +trim = dropWhileEnd isSpace . dropWhile isSpace + +-- | Determines whether or not the target system is a Linux machine. +isLinux :: TargetSystem -> Bool +isLinux = (== GNULinux) diff --git a/src/System/Hapistrano/Config.hs b/src/System/Hapistrano/Config.hs new file mode 100644 --- /dev/null +++ b/src/System/Hapistrano/Config.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module System.Hapistrano.Config + ( Config (..) + , CopyThing (..) + , Target (..)) +where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Function (on) +import Data.List (nubBy) +import Data.Maybe (maybeToList) +import Data.Yaml +import Numeric.Natural +import Path +import System.Hapistrano.Commands +import System.Hapistrano.Types (Shell(..), + ReleaseFormat (..), + Source(..), + TargetSystem (..)) + +-- | Hapistrano configuration typically loaded from @hap.yaml@ file. + +data Config = Config + { configDeployPath :: !(Path Abs Dir) + -- ^ Top-level deploy directory on target machine + , configHosts :: ![Target] + -- ^ Hosts\/ports\/shell\/ssh args to deploy to. If empty, localhost will be assumed. + , configSource :: !Source + -- ^ Location of the 'Source' that contains the code to deploy + , configRestartCommand :: !(Maybe GenericCommand) + -- ^ The command to execute when switching to a different release + -- (usually after a deploy or rollback). + , configBuildScript :: !(Maybe [GenericCommand]) + -- ^ Build script to execute to build the project + , configCopyFiles :: ![CopyThing] + -- ^ Collection of files to copy over to target machine before building + , configCopyDirs :: ![CopyThing] + -- ^ Collection of directories to copy over to target machine before building + , configLinkedFiles :: ![FilePath] + -- ^ Collection of files to link from each release to _shared_ + , configLinkedDirs :: ![FilePath] + -- ^ Collection of directories to link from each release to _shared_ + , configVcAction :: !Bool + -- ^ Perform version control related actions. By default, it's assumed to be True. + , configRunLocally :: !(Maybe [GenericCommand]) + -- ^ Perform a series of commands on the local machine before communication + -- with target server starts + , configTargetSystem :: !TargetSystem + -- ^ Optional parameter to specify the target system. It's GNU/Linux by + -- default + , configReleaseFormat :: !(Maybe ReleaseFormat) + -- ^ The release timestamp format, the '--release-format' argument passed via + -- the CLI takes precedence over this value. If neither CLI or configuration + -- file value is specified, it defaults to short + , configKeepReleases :: !(Maybe Natural) + -- ^ The number of releases to keep, the '--keep-releases' argument passed via + -- the CLI takes precedence over this value. If neither CLI or configuration + -- file value is specified, it defaults to 5 + } deriving (Eq, Ord, Show) + +-- | Information about source and destination locations of a file\/directory +-- to copy. + +data CopyThing = CopyThing FilePath FilePath + deriving (Eq, Ord, Show) + +data Target = + Target + { targetHost :: String + , targetPort :: Word + , targetShell :: Shell + , targetSshArgs :: [String] + } deriving (Eq, Ord, Show) + +instance FromJSON Config where + parseJSON = withObject "Hapistrano configuration" $ \o -> do + configDeployPath <- o .: "deploy_path" + let grabPort m = m .:? "port" .!= 22 + grabShell m = m .:? "shell" .!= Bash + grabSshArgs m = m .:? "ssh_args" .!= [] + host <- o .:? "host" + port <- grabPort o + shell <- grabShell o + sshArgs <- grabSshArgs o + hs <- (o .:? "targets" .!= []) >>= mapM (\m -> + Target + <$> m .: "host" + <*> grabPort m + <*> grabShell m + <*> grabSshArgs m) + let first Target{..} = host + configHosts = nubBy ((==) `on` first) + (maybeToList (Target <$> host <*> pure port <*> pure shell <*> pure sshArgs) ++ hs) + source m = + GitRepository <$> m .: "repo" <*> m .: "revision" + <|> LocalDirectory <$> m .: "local_directory" + configSource <- source o + configRestartCommand <- (o .:? "restart_command") >>= + maybe (return Nothing) (fmap Just . mkCmd) + configBuildScript <- o .:? "build_script" >>= + maybe (return Nothing) (fmap Just . mapM mkCmd) + configCopyFiles <- o .:? "copy_files" .!= [] + configCopyDirs <- o .:? "copy_dirs" .!= [] + configLinkedFiles <- o .:? "linked_files" .!= [] + configLinkedDirs <- o .:? "linked_dirs" .!= [] + configVcAction <- o .:? "vc_action" .!= True + configRunLocally <- o .:? "run_locally" >>= + maybe (return Nothing) (fmap Just . mapM mkCmd) + configTargetSystem <- o .:? "linux" .!= GNULinux + configReleaseFormat <- o .:? "release_format" + configKeepReleases <- o .:? "keep_releases" + return Config {..} + +instance FromJSON CopyThing where + parseJSON = withObject "src and dest of a thing to copy" $ \o -> + CopyThing <$> (o .: "src") <*> (o .: "dest") + +instance FromJSON TargetSystem where + parseJSON = withBool "linux" $ + pure . \case + True -> GNULinux + False -> BSD + +mkCmd :: String -> Parser GenericCommand +mkCmd raw = + case mkGenericCommand raw of + Nothing -> fail "invalid restart command" + Just cmd -> return cmd diff --git a/src/System/Hapistrano/Core.hs b/src/System/Hapistrano/Core.hs --- a/src/System/Hapistrano/Core.hs +++ b/src/System/Hapistrano/Core.hs @@ -9,7 +9,6 @@ -- -- Core Hapistrano functions that provide basis on which all the -- functionality is built. - {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -39,28 +38,30 @@ import qualified System.Process.Typed as SPT -- | Run the 'Hapistrano' monad. The monad hosts 'exec' actions. - -runHapistrano :: MonadIO m - => Maybe SshOptions -- ^ SSH options to use or 'Nothing' if we run locally - -> Shell -- ^ Shell to run commands +runHapistrano :: + MonadIO m + => Maybe SshOptions -- ^ SSH options to use or 'Nothing' if we run locally + -> Shell -- ^ Shell to run commands -> (OutputDest -> String -> IO ()) -- ^ How to print messages - -> Hapistrano a -- ^ The computation to run - -> m (Either Int a) -- ^ Status code in 'Left' on failure, result in + -> Hapistrano a -- ^ The computation to run + -> m (Either Int a) -- ^ Status code in 'Left' on failure, result in -- 'Right' on success -runHapistrano sshOptions shell' printFnc m = liftIO $ do - let config = Config - { configSshOptions = sshOptions - , configShellOptions = shell' - , configPrint = printFnc } - r <- runReaderT (runExceptT m) config - case r of - Left (Failure n msg) -> do - forM_ msg (printFnc StderrDest) - return (Left n) - Right x -> return (Right x) +runHapistrano sshOptions shell' printFnc m = + liftIO $ do + let config = + Config + { configSshOptions = sshOptions + , configShellOptions = shell' + , configPrint = printFnc + } + r <- runReaderT (runExceptT m) config + case r of + Left (Failure n msg) -> do + forM_ msg (printFnc StderrDest) + return (Left n) + Right x -> return (Right x) -- | Fail returning the following status code and message. - failWith :: Int -> Maybe String -> Hapistrano a failWith n msg = throwError (Failure n msg) @@ -71,15 +72,17 @@ -- __NOTE:__ the commands executed with 'exec' will create their own pipe and -- will stream output there and once the command finishes its execution it will -- parse the result. - -exec :: forall a. Command a => a -> Hapistrano (Result a) +exec :: + forall a. Command a + => a + -> Hapistrano (Result a) exec typedCmd = do let cmd = renderCommand typedCmd (prog, args) <- getProgAndArgs cmd - parseResult (Proxy :: Proxy a) <$> exec' cmd (readProcessWithExitCode prog args "") + parseResult (Proxy :: Proxy a) <$> + exec' cmd (readProcessWithExitCode prog args "") -- | Same as 'exec' but it streams to stdout only for _GenericCommand_s - execWithInheritStdout :: Command a => a -> Hapistrano () execWithInheritStdout typedCmd = do let cmd = renderCommand typedCmd @@ -89,27 +92,22 @@ -- | Prepares a process, reads @stdout@ and @stderr@ and returns exit code -- NOTE: @strdout@ and @stderr@ are empty string because we're writing -- the output to the parent. - readProcessWithExitCode' - :: ProcessConfig stdin stdoutIgnored stderrIgnored + readProcessWithExitCode' :: + ProcessConfig stdin stdoutIgnored stderrIgnored -> IO (ExitCode, String, String) readProcessWithExitCode' pc = - SPT.withProcessTerm pc' $ \p -> atomically $ - (,,) <$> SPT.waitExitCodeSTM p - <*> return "" - <*> return "" - where - pc' = SPT.setStdout SPT.inherit - $ SPT.setStderr SPT.inherit pc + SPT.withProcessTerm pc' $ \p -> + atomically $ (,,) <$> SPT.waitExitCodeSTM p <*> return "" <*> return "" + where + pc' = SPT.setStdout SPT.inherit $ SPT.setStderr SPT.inherit pc -- | Get program and args to run a command locally or remotelly. - getProgAndArgs :: String -> Hapistrano (String, [String]) getProgAndArgs cmd = do Config {..} <- ask return $ case configSshOptions of - Nothing -> - (renderShell configShellOptions, ["-c", cmd]) + Nothing -> (renderShell configShellOptions, ["-c", cmd]) Just SshOptions {..} -> ("ssh", sshArgs ++ [sshHost, "-p", show sshPort, cmd]) where @@ -117,29 +115,22 @@ renderShell Zsh = "zsh" renderShell Bash = "bash" --- | Copy a file from local path to target server. -scpFile - :: Path Abs File -- ^ Location of the file to copy - -> Path Abs File -- ^ Where to put the file on target machine +-- | Copy a file from local path to target server. +scpFile :: + Path Abs File -- ^ Location of the file to copy + -> Path Abs File -- ^ Where to put the file on target machine -> Hapistrano () -scpFile src dest = - scp' (fromAbsFile src) (fromAbsFile dest) ["-q"] +scpFile src dest = scp' (fromAbsFile src) (fromAbsFile dest) ["-q"] -- | Copy a local directory recursively to target server. - -scpDir - :: Path Abs Dir -- ^ Location of the directory to copy - -> Path Abs Dir -- ^ Where to put the dir on target machine +scpDir :: + Path Abs Dir -- ^ Location of the directory to copy + -> Path Abs Dir -- ^ Where to put the dir on target machine -> Hapistrano () -scpDir src dest = - scp' (fromAbsDir src) (fromAbsDir dest) ["-qr"] +scpDir src dest = scp' (fromAbsDir src) (fromAbsDir dest) ["-qr"] -scp' - :: FilePath - -> FilePath - -> [String] - -> Hapistrano () +scp' :: FilePath -> FilePath -> [String] -> Hapistrano () scp' src dest extraArgs = do Config {..} <- ask let prog = "scp" @@ -152,21 +143,19 @@ Nothing -> "" Just x -> x ++ ":" args = extraArgs ++ portArg ++ [src, hostPrefix ++ dest] - void (exec' (prog ++ " " ++ unwords args) (readProcessWithExitCode prog args "")) + void + (exec' (prog ++ " " ++ unwords args) (readProcessWithExitCode prog args "")) ---------------------------------------------------------------------------- -- Helpers - -- | A helper for 'exec' and similar functions. - -exec' - :: String -- ^ How to show the command in print-outs +exec' :: + String -- ^ How to show the command in print-outs -> IO (ExitCode, String, String) -- ^ Handler to get (ExitCode, Output, Error) it can change accordingly to @stdout@ and @stderr@ of child process -> Hapistrano String -- ^ Raw stdout output of that program exec' cmd readProcessOutput = do Config {..} <- ask time <- liftIO getZonedTime - let timeStampFormat = "%T, %F (%Z)" printableTime = formatTime defaultTimeLocale timeStampFormat time hostLabel = @@ -178,18 +167,13 @@ cmdInfo = colorizeString Green (cmd ++ "\n") liftIO $ configPrint StdoutDest (hostInfo ++ timestampInfo ++ cmdInfo) (exitCode', stdout', stderr') <- liftIO readProcessOutput - unless (null stdout') . liftIO $ - configPrint StdoutDest stdout' - unless (null stderr') . liftIO $ - configPrint StderrDest stderr' + unless (null stdout') . liftIO $ configPrint StdoutDest stdout' + unless (null stderr') . liftIO $ configPrint StderrDest stderr' case exitCode' of - ExitSuccess -> - return stdout' - ExitFailure n -> - failWith n Nothing + ExitSuccess -> return stdout' + ExitFailure n -> failWith n Nothing -- | Put something “inside” a line, sort-of beautifully. - putLine :: String -> String putLine str = "*** " ++ str ++ padding ++ "\n" where diff --git a/src/System/Hapistrano/Types.hs b/src/System/Hapistrano/Types.hs --- a/src/System/Hapistrano/Types.hs +++ b/src/System/Hapistrano/Types.hs @@ -8,162 +8,185 @@ -- Portability : portable -- -- Type definitions for the Hapistrano tool. - {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} module System.Hapistrano.Types ( Hapistrano - , Failure (..) - , Config (..) - , Task (..) + , Failure(..) + , Config(..) + , Source(..) + , Task(..) , ReleaseFormat(..) - , SshOptions (..) - , OutputDest (..) + , SshOptions(..) + , OutputDest(..) , Release , TargetSystem(..) , Shell(..) + -- * Types helpers , mkRelease , releaseTime , renderRelease , parseRelease , fromMaybeReleaseFormat - , fromMaybeKeepReleases ) -where + , fromMaybeKeepReleases + , toMaybePath + ) where -import Control.Applicative -import Control.Monad.Except -import Control.Monad.Reader -import Data.Aeson -import Data.Maybe -import Data.Time -import Numeric.Natural -import Path +import Control.Applicative +import Control.Monad.Except +import Control.Monad.Reader +import Data.Aeson +import Data.Maybe +import Data.Time +import Numeric.Natural +import Path -- | Hapistrano monad. - type Hapistrano a = ExceptT Failure (ReaderT Config IO) a -- | Failure with status code and a message. - -data Failure = Failure Int (Maybe String) +data Failure = + Failure Int (Maybe String) -- | Hapistrano configuration options. - -data Config = Config - { configSshOptions :: !(Maybe SshOptions) +data Config = + Config + { configSshOptions :: !(Maybe SshOptions) -- ^ 'Nothing' if we are running locally, or SSH options to use. - , configShellOptions :: !Shell + , configShellOptions :: !Shell -- ^ One of the supported 'Shell's - , configPrint :: !(OutputDest -> String -> IO ()) + , configPrint :: !(OutputDest -> String -> IO ()) -- ^ How to print messages - } + } --- | The records describes deployment task. +-- | The source of the repository. It can be from a version control provider +-- like GitHub or a local directory. +data Source + = GitRepository + { gitRepositoryURL :: String + -- ^ The URL of remote Git repository to deploy + , gitRepositoryRevision :: String + -- ^ The SHA1 or branch to release + } + | LocalDirectory + { localDirectoryPath :: Path Abs Dir + -- ^ The local repository to deploy + } + deriving (Eq, Ord, Show) -data Task = Task - { taskDeployPath :: Path Abs Dir +-- | The records describes deployment task. +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 + , taskSource :: Source + -- ^ The 'Source' to deploy + , taskReleaseFormat :: ReleaseFormat -- ^ The 'ReleaseFormat' to use - } deriving (Show, Eq, Ord) + } + deriving (Show, Eq, Ord) -- | Release format mode. - data ReleaseFormat = ReleaseShort -- ^ Standard release path following Capistrano's format - | ReleaseLong -- ^ Long release path including picoseconds + | ReleaseLong -- ^ Long release path including picoseconds deriving (Show, Read, Eq, Ord, Enum, Bounded) instance FromJSON ReleaseFormat where - parseJSON = withText "release format" $ \case + parseJSON = + withText "release format" $ \case "short" -> return ReleaseShort - "long" -> return ReleaseLong - _ -> fail "expected 'short' or 'long'" + "long" -> return ReleaseLong + _ -> fail "expected 'short' or 'long'" -- | Current shells supported. -data Shell = - Bash +data Shell + = Bash | Zsh deriving (Show, Eq, Ord) instance FromJSON Shell where - parseJSON = withText "shell" $ \case + parseJSON = + withText "shell" $ \case "bash" -> return Bash - "zsh" -> return Zsh - _ -> fail "supported shells: 'bash' or 'zsh'" + "zsh" -> return Zsh + _ -> fail "supported shells: 'bash' or 'zsh'" -- | SSH options. - -data SshOptions = SshOptions - { sshHost :: String -- ^ Host to use - , sshPort :: Word -- ^ Port to use - , sshArgs :: [String] -- ^ Arguments for ssh - } deriving (Show, Read, Eq, Ord) +data SshOptions = + SshOptions + { sshHost :: String -- ^ Host to use + , sshPort :: Word -- ^ Port to use + , sshArgs :: [String] -- ^ Arguments for ssh + } + deriving (Show, Read, Eq, Ord) -- | Output destination. - data OutputDest = StdoutDest | StderrDest deriving (Eq, Show, Read, Ord, Bounded, Enum) -- | Release indentifier. - -data Release = Release ReleaseFormat UTCTime +data Release = + Release ReleaseFormat UTCTime deriving (Eq, Show, Ord) -- | Target's system where application will be deployed - data TargetSystem = GNULinux | BSD deriving (Eq, Show, Read, Ord, Bounded, Enum) -- | Create a 'Release' indentifier. - mkRelease :: ReleaseFormat -> UTCTime -> Release mkRelease = Release -- | 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 + fmt = + case rfmt of + ReleaseShort -> releaseFormatShort + ReleaseLong -> releaseFormatLong --- | Parse 'Release' identifier from a 'String'. +---------------------------------------------------------------------------- +-- Types helpers +-- | Parse 'Release' identifier from a 'String'. parseRelease :: String -> Maybe Release -parseRelease s = (Release ReleaseLong <$> p releaseFormatLong s) - <|> (Release ReleaseShort <$> p releaseFormatShort s) +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" --- | Get release format based on the CLI and file configuration values. +releaseFormatLong = "%Y%m%d%H%M%S%q" -fromMaybeReleaseFormat :: Maybe ReleaseFormat -> Maybe ReleaseFormat -> ReleaseFormat -fromMaybeReleaseFormat cliRF configRF = fromMaybe ReleaseShort (cliRF <|> configRF) +-- | Get release format based on the CLI and file configuration values. +fromMaybeReleaseFormat :: + Maybe ReleaseFormat -> Maybe ReleaseFormat -> ReleaseFormat +fromMaybeReleaseFormat cliRF configRF = + fromMaybe ReleaseShort (cliRF <|> configRF) -- | Get keep releases based on the CLI and file configuration values. - fromMaybeKeepReleases :: Maybe Natural -> Maybe Natural -> Natural -fromMaybeKeepReleases cliKR configKR = fromMaybe defaultKeepReleases (cliKR <|> configKR) +fromMaybeKeepReleases cliKR configKR = + fromMaybe defaultKeepReleases (cliKR <|> configKR) defaultKeepReleases :: Natural defaultKeepReleases = 5 + +-- | Get the local path to copy from the 'Source' configuration value. +toMaybePath :: Source -> Maybe (Path Abs Dir) +toMaybePath (LocalDirectory path) = Just path +toMaybePath _ = Nothing