hapistrano 0.3.10.0 → 0.4.0.0

raw patch · 15 files changed

+1060/−829 lines, 15 filesdep ~pathdep ~path-ioPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: path, path-io

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• Dockerfile +5/−6
• README.md +33/−5
• app/Config.hs +0/−132
• app/Main.hs +4/−3
• hapistrano.cabal +14/−9
• spec/System/HapistranoConfigSpec.hs +59/−0
• spec/System/HapistranoPropsSpec.hs +85/−0
• spec/System/HapistranoSpec.hs +245/−235
• src/System/Hapistrano.hs +12/−5
• src/System/Hapistrano/Commands.hs +21/−298
• src/System/Hapistrano/Commands/Internal.hs +294/−0
• src/System/Hapistrano/Config.hs +134/−0
• src/System/Hapistrano/Core.hs +51/−67
• src/System/Hapistrano/Types.hs +92/−69

@@ -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.

@@ -1,23 +1,22 @@ # Build Hapistrano FROM alpine:3.9 as build-env -MAINTAINER Javier Casas <jcasas@stackbuilders.com>+MAINTAINER Nicolas Vivar <nvivar@stackbuilders.com> -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

@@ -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 

@@ -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

@@ -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

@@ -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)

@@ -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+    }

@@ -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 '#'))]

@@ -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

@@ -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.

@@ -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

@@ -0,0 +1,294 @@+-- |+-- Module      :  System.Hapistrano.Commands+-- Copyright   :  © 2015-Present Stack Builders+-- License     :  MIT+--+-- Maintainer  :  Juan Paucar <jpaucar@stackbuilders.com>+-- 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)

@@ -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

@@ -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

@@ -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