mirror of
https://github.com/stackbuilders/hapistrano.git
synced 2024-11-27 02:24:43 +03:00
Quickcheck property tests (#128)
* Add property check quote command * Add property test trim function * Fix biased test cases for trim function * Stack lock * Separated property tests from other tests * Fixes on imports * PR quickcheck * Remove wrong comment * Add property test for generic and ungeneric command * Refactoring isCmdString function * Fix conflicts * Add quickchek part 1
This commit is contained in:
William R. Arellano
Juan Paucar
parent
9a7fa97794
commit
f8a869ce3d
@ -40,7 +40,7 @@ script:
|
||||
- cabal build --enable-tests
|
||||
- cabal test --enable-tests
|
||||
- cabal sdist
|
||||
- cabal haddock | grep "100%" | wc -l | grep "4"
|
||||
- cabal haddock | grep "100%" | wc -l | grep -G "[45]" # Fixes issue with different haddock coverage with different ghc versions https://github.com/haskell/haddock/issues/123
|
||||
# There is a single Docker image, there are no variants for different versions of GHC
|
||||
- if [[ "$GHCVER" == "8.0.2" ]]; then docker build . -t hapistrano; docker run --rm hapistrano --version; fi
|
||||
|
||||
|
||||
@ -50,6 +50,7 @@ library
|
||||
, System.Hapistrano.Commands
|
||||
, 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
|
||||
@ -99,6 +100,7 @@ test-suite test
|
||||
hs-source-dirs: spec
|
||||
main-is: Spec.hs
|
||||
other-modules: System.HapistranoSpec
|
||||
, System.HapistranoPropsSpec
|
||||
build-depends: base >= 4.8 && < 5.0
|
||||
, directory >= 1.2.5 && < 1.4
|
||||
, filepath >= 1.2 && < 1.5
|
||||
|
||||
85
spec/System/HapistranoPropsSpec.hs
Normal file
85
spec/System/HapistranoPropsSpec.hs
Normal file
@ -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,29 @@
|
||||
{-# 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 +32,296 @@ spec :: Spec
|
||||
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
|
||||
spath <- makeAbsolute $(mkRelFile "script/clean-build.sh")
|
||||
(fmap Hap.unGenericCommand <$> Hap.readScript spath)
|
||||
`Hspec.shouldReturn`
|
||||
(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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
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` ()
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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 +329,10 @@ justExec path cmd' =
|
||||
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 +348,27 @@ runHapWithShell shell m = do
|
||||
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
|
||||
, taskRepository = fromAbsDir repoPath
|
||||
, taskRevision = 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
|
||||
|
||||
@ -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
|
||||
, 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
|
||||
|
||||
isLinux :: TargetSystem -> Bool
|
||||
isLinux = (== GNULinux)
|
||||
import System.Hapistrano.Commands.Internal
|
||||
|
||||
294
src/System/Hapistrano/Commands/Internal.hs
Normal file
294
src/System/Hapistrano/Commands/Internal.hs
Normal file
@ -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)
|
||||
@ -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 System.Process.Typed (ProcessConfig)
|
||||
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 @@ failWith n msg = throwError (Failure n msg)
|
||||
-- __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 @@ execWithInheritStdout typedCmd = do
|
||||
-- | 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 @@ getProgAndArgs cmd = do
|
||||
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 @@ scp' src dest extraArgs = do
|
||||
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 @@ exec' cmd readProcessOutput = do
|
||||
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,18 +8,17 @@
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Type definitions for the Hapistrano tool.
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module System.Hapistrano.Types
|
||||
( Hapistrano
|
||||
, Failure (..)
|
||||
, Config (..)
|
||||
, Task (..)
|
||||
, Failure(..)
|
||||
, Config(..)
|
||||
, Task(..)
|
||||
, ReleaseFormat(..)
|
||||
, SshOptions (..)
|
||||
, OutputDest (..)
|
||||
, SshOptions(..)
|
||||
, OutputDest(..)
|
||||
, Release
|
||||
, TargetSystem(..)
|
||||
, Shell(..)
|
||||
@ -28,142 +27,142 @@ module System.Hapistrano.Types
|
||||
, renderRelease
|
||||
, parseRelease
|
||||
, fromMaybeReleaseFormat
|
||||
, fromMaybeKeepReleases )
|
||||
where
|
||||
, fromMaybeKeepReleases
|
||||
) 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.
|
||||
|
||||
data Task = Task
|
||||
{ taskDeployPath :: Path Abs Dir
|
||||
data Task =
|
||||
Task
|
||||
{ taskDeployPath :: Path Abs Dir
|
||||
-- ^ The root of the deploy target on the remote host
|
||||
, taskRepository :: String
|
||||
, taskRepository :: String
|
||||
-- ^ The URL of remote Git repo to deploy
|
||||
, taskRevision :: String
|
||||
, taskRevision :: String
|
||||
-- ^ A SHA1 or branch to release
|
||||
, taskReleaseFormat :: ReleaseFormat
|
||||
, 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'.
|
||||
|
||||
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"
|
||||
|
||||
releaseFormatLong = "%Y%m%d%H%M%S%q"
|
||||
|
||||
-- | Get release format based on the CLI and file configuration values.
|
||||
|
||||
fromMaybeReleaseFormat :: Maybe ReleaseFormat -> Maybe ReleaseFormat -> ReleaseFormat
|
||||
fromMaybeReleaseFormat cliRF configRF = fromMaybe ReleaseShort (cliRF <|> configRF)
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user