stackbuilders/hapistrano
1
1
Fork 0
mirror of https://github.com/stackbuilders/hapistrano.git synced 2025-01-03 09:41:36 +03:00
Code Issues Projects Releases Wiki Activity

Refactor/rewrite all the code (#52)

Browse Source 
* Refactor/rewrite all the code

The change prepares solid ground for further improvements. This also fixes
at least two bugs:

* Proper support for empty lines and comments in build scripts.

* Previously switching to new releases was not atomic despite messing with
  symlinks. This is because it deleted the current link before creating the
  new one, but it should have created a new link and then use ‘mv’ to
  replace the old one atomically. The code has been changed to work properly
  now.

* Refresh the test suite as well

* Fix the build for older GHCs

* Use subshell for ‘cd’ commands
This commit is contained in:
Mark Karpov 2017-02-06 19:04:00 +04:00 committed by GitHub
parent 7c65c4c2bc
commit 72a1b75e70
13 changed files with 851 additions and 793 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
.travis.yml
View File

@ -4,10 +4,6 @@ sudo: false
matrix:
include:
- env: CABALVER=1.24 GHCVER=7.6.3
addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3], sources: [hvr-ghc]}}
- env: CABALVER=1.24 GHCVER=7.8.4
addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4], sources: [hvr-ghc]}}
- env: CABALVER=1.24 GHCVER=7.10.3
addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3],sources: [hvr-ghc]}}
- env: CABALVER=1.24 GHCVER=8.0.2
@ -28,17 +24,11 @@ install:
- cabal install --only-dependencies --enable-tests
script:
- case "$GHCVER" in
"7.6.3") cabal configure --enable-tests -v2 -f dev ;;
*) cabal configure --enable-tests --enable-coverage -v2 -f dev ;;
esac
- cabal configure --enable-tests --enable-coverage -v2 -f dev
- cabal build
- case "$GHCVER" in
"7.6.3") true ;;
*) cabal test --show-details=always ;;
esac
- cabal test --show-details=always
- cabal sdist
- cabal haddock | grep "100%" | wc -l | grep "2"
- cabal haddock | grep "100%" | wc -l | grep "4"
notifications:
email: false

2
CHANGELOG.md
View File

@ -4,6 +4,8 @@
* Use `optparse-applicative` to parse arguments.
* Add support for comments and empty lines to scripts.
* Parse ssh port from `PORT` environment variable.
* Drop support for GHCs older than 7.10 (because Chris Done's `path` does
not compile with them, see: https://github.com/chrisdone/path/issues/46).
## 0.2.1.2

21
app/Command.hs
View File

@ -1,21 +0,0 @@
module Command where
import Data.Monoid ((<>))
import Options.Applicative
data Command
= Deploy
| Rollback
deriving Show
addCommand :: Command -> String -> String -> Mod CommandFields Command
addCommand command' name description =
command name (info (pure command') (progDesc description))
commands :: Parser Command
commands
= subparser
(
addCommand Deploy "deploy" "Deploys the current release with the configure options"
<> addCommand Rollback "rollback" "Rolls back to the previous release"
)

12
app/Flag.hs
View File

@ -1,12 +0,0 @@
module Flag where
import Data.Monoid ((<>))
import Options.Applicative
data Flag
= Version
deriving Show
flags :: Parser Flag
flags =
flag' Version (long "version" <> short 'v' <> help "Diplay the version of Hapistrano")

175
app/Main.hs
View File

@ -1,96 +1,123 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import qualified System.Hapistrano as Hap
import Control.Monad (void)
import System.Environment.Compat (lookupEnv)
import System.Hapistrano (ReleaseFormat(..))
import System.Exit
import Options
import Paths_hapistrano (version)
import Control.Monad
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Version (showVersion)
import qualified Text.Read as Read
import Numeric.Natural
import Options.Applicative
import Path
import Path.IO
import Paths_hapistrano (version)
import System.Environment.Compat (lookupEnv, getEnv)
import System.Exit
import System.Hapistrano.Types
import Text.Read (readMaybe)
import qualified System.Hapistrano as Hap
import qualified System.Hapistrano.Commands as Hap
import qualified System.Hapistrano.Core as Hap
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import System.IO
die :: String -> IO a
die err = hPutStrLn stderr err >> exitFailure
#endif
-- | Rolls back to previous release.
rollback :: Hap.Config -> IO ()
rollback cfg =
Hap.runRC errorHandler successHandler cfg $ do
----------------------------------------------------------------------------
-- Command line options
_ <- Hap.rollback
void Hap.restartServerCommand
-- | Command line options.
where
errorHandler = Hap.defaultErrorHandler
successHandler = Hap.defaultSuccessHandler
data Opts = Opts
{ optsCommand :: Command
, optsVersion :: Bool
}
-- | Deploys the current release with Config options.
deploy :: Hap.Config -> IO ()
deploy cfg =
Hap.runRC errorHandler successHandler cfg $ do
_ <- Hap.pushRelease >>= Hap.runBuild >>= Hap.activateRelease
-- | Command to execute and command-specific options.
void Hap.restartServerCommand
data Command
= Deploy ReleaseFormat Natural -- ^ Deploy a new release (with timestamp
-- format and how many releases to keep)
| Rollback Natural -- ^ Rollback to Nth previous release
where
errorHandler = Hap.defaultErrorHandler
successHandler = Hap.defaultSuccessHandler
parserInfo :: ParserInfo Opts
parserInfo = info (helper <*> optionParser)
( fullDesc <>
progDesc "Deploy tool for Haskell applications" <>
header "Hapistrano - A deployment library for Haskell applications" )
-- | Retrieves the configuration from environment variables.
configFromEnv :: IO Hap.Config
configFromEnv = do
maybeDeployPath <- lookupEnv "DEPLOY_PATH"
maybeRepository <- lookupEnv "REPOSITORY"
maybeRevision <- lookupEnv "REVISION"
optionParser :: Parser Opts
optionParser = Opts
<$> subparser
( command "deploy"
(info deployParser (progDesc "Deploy a new release")) <>
command "rollback"
(info rollbackParser (progDesc "Roll back to Nth previous release")) )
<*> switch
( long "version"
<> short 'v'
<> help "Show version of the program" )
deployPath <- maybe (die (noEnv "DEPLOY_PATH")) return maybeDeployPath
repository <- maybe (die (noEnv "REPOSITORY")) return maybeRepository
revision <- maybe (die (noEnv "REVISION")) return maybeRevision
deployParser :: Parser Command
deployParser = Deploy
<$> option pReleaseFormat
( long "release-format"
<> short 'r'
<> value ReleaseShort
<> help "Which format release timestamp format to use: ‘long’ or ‘short’, default is ‘short’." )
<*> option auto
( long "keep-releases"
<> short 'k'
<> value 5
<> help "How many releases to keep. Default is 5." )
port <- lookupEnv "PORT"
host <- lookupEnv "HOST"
buildScript <- lookupEnv "BUILD_SCRIPT"
restartCommand <- lookupEnv "RESTART_COMMAND"
rollbackParser :: Parser Command
rollbackParser = Rollback
<$> option auto
( long "use-nth"
<> short 'n'
<> value 1
<> help "How many deployments back to go? Default is 1." )
return Hap.Config { Hap.deployPath = deployPath
, Hap.host = host
, Hap.releaseFormat = Short
, Hap.repository = repository
, Hap.revision = revision
, Hap.buildScript = buildScript
, Hap.restartCommand = restartCommand
, Hap.port = parsePort port
}
where
noEnv env = env ++ " environment variable does not exist"
parsePort maybePort = maybePort >>= Read.readMaybe
pReleaseFormat :: ReadM ReleaseFormat
pReleaseFormat = eitherReader $ \s ->
case s of
"long" -> Right ReleaseLong
"short" -> Right ReleaseShort
_ -> Left ("Unknown format: " ++ s ++ ", try ‘long’ or ‘short’.")
----------------------------------------------------------------------------
-- Main
main :: IO ()
main = execParser (info (helper <*> opts) hapistranoDesc) >>= runOption
main = do
Opts {..} <- execParser parserInfo
when optsVersion $ do
putStrLn $ "Hapistrano " ++ showVersion version
exitSuccess
runOption :: Option -> IO ()
runOption (Command command) = runCommand command
runOption (Flag flag) = runFlag flag
deployPath <- getEnv "DEPLOY_PATH" >>= parseAbsDir
repository <- getEnv "REPOSITORY"
revision <- getEnv "REVISION"
port <- fromMaybe 22 . (>>= readMaybe) <$> lookupEnv "PORT"
mhost <- lookupEnv "HOST"
buildScript <- lookupEnv "BUILD_SCRIPT"
mrestartCmd <- (>>= Hap.mkGenericCommand) <$> lookupEnv "RESTART_COMMAND"
runCommand :: Command -> IO ()
runCommand Deploy = configFromEnv >>= deploy
runCommand Rollback = configFromEnv >>= rollback
runFlag :: Flag -> IO ()
runFlag Version = printVersion
printVersion :: IO ()
printVersion = putStrLn $ "Hapistrano " ++ showVersion version
Hap.runHapistrano (SshOptions <$> mhost <*> pure port) $ case optsCommand of
Deploy releaseFormat n -> do
release <- Hap.pushRelease Task
{ taskDeployPath = deployPath
, taskRepository = repository
, taskRevision = revision
, taskReleaseFormat = releaseFormat }
forM_ buildScript $ \spath' -> do
spath <- resolveFile' spath'
script <- Hap.readScript spath
Hap.playScript script deployPath release
Hap.activateRelease deployPath release
Hap.dropOldReleases deployPath n
Rollback n -> do
Hap.rollback deployPath n
forM_ mrestartCmd Hap.exec

37
app/Options.hs
View File

@ -1,37 +0,0 @@
module Options (
Option(..)
, opts
, hapistranoDesc
-- | Imports from Options.Applicative
, execParser
, info
, helper
-- | Imports from other internal modules
, module Command
, module Flag
)
where
import Command
import Flag
import Data.Monoid ((<>))
import Options.Applicative
-- | Flags and commands
opts :: Parser Option
opts
= fmap Flag flags
<|> fmap Command commands
data Option
= Command Command.Command
| Flag Flag.Flag
deriving Show
hapistranoDesc :: InfoMod a
hapistranoDesc =
fullDesc
<> header "Hapistrano - A deployment library for Haskell applications"
<> progDesc "Deploy tool for Haskell applications"
<> footer "Run 'hap -h' for available commands"

19
hapistrano.cabal
View File

@ -30,6 +30,7 @@ build-type: Simple
cabal-version: >=1.10
extra-source-files: CHANGELOG.md
, README.md
data-files: script/clean-build.sh
flag dev
description: Turn on development settings.
@ -39,11 +40,13 @@ flag dev
library
hs-source-dirs: src
exposed-modules: System.Hapistrano
other-modules: System.Hapistrano.Types
, System.Hapistrano.Commands
, System.Hapistrano.Core
, System.Hapistrano.Types
build-depends: base >= 4.6 && < 5.0
, either >= 4.0 && < 4.6
, filepath >= 1.2 && < 1.5
, mtl >= 2.0 && < 3.0
, path >= 0.5 && < 6.0
, process >= 1.4 && < 1.5
, time >= 1.5 && < 1.8
, transformers >= 0.4 && < 0.6
@ -56,31 +59,31 @@ library
executable hap
hs-source-dirs: app
main-is: Main.hs
other-modules: Options
, Command
, Flag
build-depends: base >= 4.6 && < 5.0
, base-compat >= 0.6 && < 1.0
, hapistrano
, optparse-applicative >= 0.11 && < 0.14
, path >= 0.5 && < 6.0
, path-io >= 1.2 && < 1.3
if flag(dev)
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror
else
ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall
default-language: Haskell2010
test-suite hapistrano-test
test-suite test
type: exitcode-stdio-1.0
hs-source-dirs: spec
main-is: Spec.hs
other-modules: System.HapistranoSpec
build-depends: base >= 4.5 && < 5.0
, directory >= 1.2.2 && < 1.4
, either >= 4.0 && < 4.6
, filepath >= 1.2 && < 1.5
, hapistrano
, hspec >= 2.0 && < 3.0
, mtl >= 2.0 && < 3.0
, path >= 0.5 && < 6.0
, path-io >= 1.2 && < 1.3
, process >= 1.4 && < 1.5
, temporary >= 1.1 && < 1.3
if flag(dev)
@ -91,4 +94,4 @@ test-suite hapistrano-test
source-repository head
type: git
location: https://github.com/stackbuilders/hapistrano
location: https://github.com/stackbuilders/hapistrano.git

2
script/clean-build.sh
View File

@ -1,7 +1,7 @@
# This is a comment
export PATH=~/.cabal/bin:/usr/local/bin:$PATH
cabal sandbox delete
cabal sandbox delete # kill it with fire!
cabal sandbox init
cabal clean
cabal update

308
spec/System/HapistranoSpec.hs
View File

@ -1,219 +1,139 @@
module System.HapistranoSpec (spec) where
{-# LANGUAGE TemplateHaskell #-}
import Test.Hspec (it, describe, shouldBe, Spec)
import System.IO.Temp (withSystemTempDirectory)
import System.Directory (getDirectoryContents)
import Control.Monad (void, replicateM_)
import Control.Monad.Trans.Either (runEitherT)
import Control.Monad.Reader (ReaderT(..))
import System.FilePath.Posix (joinPath)
module System.HapistranoSpec
( spec )
where
import Control.Monad
import Control.Monad.Reader
import Path
import Path.IO
import System.Hapistrano.Types
import Test.Hspec hiding (shouldBe, shouldReturn)
import qualified System.Hapistrano as Hap
import Data.List (intercalate, sort)
import qualified System.IO as IO
import qualified System.Process as Process
runCommand :: String -> IO ()
runCommand command = do
putStrLn ("GIT running: " ++ command)
let process = Process.shell command
(_, Just outHandle, Just errHandle, processHandle) <-
Process.createProcess process { Process.std_err = Process.CreatePipe
, Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
}
exitCode <- fmap show (Process.waitForProcess processHandle)
out <- IO.hGetContents outHandle
err <- IO.hGetContents errHandle
putStrLn ("GIT res: " ++ show (exitCode, out, err))
-- | Generate a source git repo as test fixture. Push an initial commit
-- to the bare repo by making a clone and committing a trivial change and
-- pushing to the bare repo.
genSourceRepo :: FilePath -> IO FilePath
genSourceRepo path = do
let fullRepoPath = joinPath [path, "testRepo"]
clonePath = joinPath [path, "testRepoClone"]
gitConfigReplace =
intercalate
" && "
[ "git config --local --replace-all push.default simple"
, "git config --local --replace-all user.email hap@hap"
, "git config --local --replace-all user.name Hap"
]
gitConfigUnset =
intercalate
" && "
[ "git config --local --unset push.default"
, "git config --local --unset user.email"
, "git config --local --unset user.name"
]
commands =
[ "mkdir -p " ++ fullRepoPath
, "git init --bare " ++ fullRepoPath
, "git clone " ++ fullRepoPath ++ " " ++ clonePath
, "echo testing > " ++ joinPath [clonePath, "README"]
, "cd " ++ clonePath ++ " && " ++ gitConfigReplace
, "cd " ++ clonePath ++ " && git add -A"
, "cd " ++ clonePath ++ " && git commit -m\"First commit\""
, "cd " ++ clonePath ++ " && git push"
, "cd " ++ clonePath ++ " && " ++ gitConfigUnset
]
mapM_ runCommand commands
return fullRepoPath
rollback :: Hap.Config -> IO ()
rollback cfg =
Hap.runRC errorHandler successHandler cfg $ do
_ <- Hap.rollback
void Hap.restartServerCommand
where
errorHandler = Hap.defaultErrorHandler
successHandler = Hap.defaultSuccessHandler
-- | Deploys the current release with Config options.
deployOnly :: Hap.Config -> IO ()
deployOnly cfg =
Hap.runRC errorHandler successHandler cfg $ void Hap.pushRelease
where
errorHandler = Hap.defaultErrorHandler
successHandler = Hap.defaultSuccessHandler
-- | Deploys the current release with Config options.
deployAndActivate :: Hap.Config -> IO ()
deployAndActivate cfg =
Hap.runRC errorHandler successHandler cfg $ do
rel <- Hap.pushRelease
_ <- Hap.runBuild rel
void $ Hap.activateRelease rel
where
errorHandler = Hap.defaultErrorHandler
successHandler = Hap.defaultSuccessHandler
defaultState :: FilePath -> FilePath -> Hap.Config
defaultState tmpDir testRepo =
Hap.Config { Hap.deployPath = tmpDir
, Hap.host = Nothing
, Hap.repository = testRepo
, Hap.releaseFormat = Hap.Long
, Hap.revision = "master"
, Hap.buildScript = Nothing
, Hap.restartCommand = Nothing
, Hap.port = Nothing
}
-- | The 'fromRight' function extracts the element out of a 'Right' and
-- throws an error if its argument take the form @Left _@.
fromRight :: Either a b -> b
fromRight (Left _) = error "fromRight: Argument takes form 'Left _'" -- yuck
fromRight (Right x) = x
import qualified System.Hapistrano.Commands as Hap
import qualified System.Hapistrano.Core as Hap
import qualified Test.Hspec as Hspec
spec :: Spec
spec = describe "hapistrano" $ do
describe "readCurrentLink" $
it "trims trailing whitespace" $
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
spec = do
describe "readScript" $
it "preforms all the necessary normalizations correctly" $ do
spath <- makeAbsolute $(mkRelFile "script/clean-build.sh")
(fmap Hap.unGenericCommand <$> Hap.readScript spath)
`Hspec.shouldReturn`
[ "export PATH=~/.cabal/bin:/usr/local/bin:$PATH"
, "cabal sandbox delete"
, "cabal sandbox init"
, "cabal clean"
, "cabal update"
, "cabal install --only-dependencies -j"
, "cabal build -j" ]
testRepoPath <- genSourceRepo tmpDir
around withSandbox $ do
describe "pushRelease" $
it "sets up repo all right" $ \(deployPath, repoPath) -> runHap $ do
let task = mkTask deployPath repoPath
release <- Hap.pushRelease task
rpath <- Hap.releasePath deployPath release
-- let's check that the dir exists and contains the right files
(liftIO . readFile . fromAbsFile) (rpath </> $(mkRelFile "foo.txt"))
`shouldReturn` "Foo!\n"
deployAndActivate $ defaultState tmpDir testRepoPath
describe "activateRelease" $
it "creates the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> runHap $ do
let task = mkTask deployPath repoPath
release <- Hap.pushRelease task
Hap.activateRelease deployPath release
rpath <- Hap.releasePath deployPath release
let rc :: Hap.Readlink Dir
rc = Hap.Readlink (Hap.currentSymlinkPath deployPath)
Hap.exec rc `shouldReturn` rpath
doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False
ltarget <-
runReaderT (runEitherT Hap.readCurrentLink) $
defaultState tmpDir testRepoPath
describe "rollback" $
it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> runHap $ do
let task = mkTask deployPath repoPath
rs <- replicateM 5 (Hap.pushRelease task)
Hap.rollback deployPath 2
rpath <- Hap.releasePath deployPath (rs !! 2)
let rc :: Hap.Readlink Dir
rc = Hap.Readlink (Hap.currentSymlinkPath deployPath)
Hap.exec rc `shouldReturn` rpath
doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False
last (fromRight ltarget) /= '\n' `shouldBe` True
describe "dropOldReleases" $
it "works" $ \(deployPath, repoPath) -> runHap $ do
let task = mkTask deployPath repoPath
rs <- replicateM 7 (Hap.pushRelease task)
Hap.dropOldReleases deployPath 5
-- two oldest releases should not survive:
forM_ (take 2 rs) $ \r ->
(Hap.releasePath deployPath r >>= doesDirExist)
`shouldReturn` False
-- 5 most recent releases should stay alive:
forM_ (drop 2 rs) $ \r ->
(Hap.releasePath deployPath r >>= doesDirExist)
`shouldReturn` True
describe "deploying" $ do
it "reads a common build script with comments and new lines" $ do
scriptLines <- lines `fmap` IO.readFile "./script/clean-build.sh"
let validBBuildScriptLines = Hap.cleanBuildScript scriptLines
length validBBuildScriptLines `shouldBe` 7
----------------------------------------------------------------------------
-- Helpers
it "a simple deploy" $
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
infix 1 `shouldBe`, `shouldReturn`
testRepoPath <- genSourceRepo tmpDir
-- | Lifted 'Hspec.shouldBe'.
deployOnly $ defaultState tmpDir testRepoPath
shouldBe :: (MonadIO m, Show a, Eq a) => a -> a -> m ()
shouldBe x y = liftIO (x `Hspec.shouldBe` y)
contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
length (filter (Hap.isReleaseString Hap.Long) contents) `shouldBe` 1
-- | Lifted 'Hspec.shouldReturn'.
it "activates the release" $
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
shouldReturn :: (MonadIO m, Show a, Eq a) => m a -> a -> m ()
shouldReturn m y = m >>= (`shouldBe` y)
testRepoPath <- genSourceRepo tmpDir
-- | The sandbox prepares the environment for an independent round of
-- testing. It provides two paths: deploy path and path where git repo is
-- located.
deployAndActivate $ defaultState tmpDir testRepoPath
withSandbox :: ActionWith (Path Abs Dir, Path Abs Dir) -> IO ()
withSandbox action = withSystemTempDir "hap-test" $ \dir -> do
let dpath = dir </> $(mkRelDir "deploy")
rpath = dir </> $(mkRelDir "repo")
ensureDir dpath
ensureDir rpath
populateTestRepo rpath
action (dpath, rpath)
contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
length (filter (Hap.isReleaseString Hap.Long) contents) `shouldBe` 1
-- | Given path where to put the repo, generate it for testing.
it "cleans up old releases" $
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
testRepoPath <- genSourceRepo tmpDir
populateTestRepo :: Path Abs Dir -> IO ()
populateTestRepo path = runHap $ do
justExec path "git init"
justExec path "git config --local --replace-all push.default simple"
justExec path "git config --local --replace-all user.email hap@hap"
justExec path "git config --local --replace-all user.name Hap"
justExec path "echo 'Foo!' > foo.txt"
justExec path "git add -A"
justExec path "git commit -m 'Initial commit'"
replicateM_ 7 $ deployAndActivate $ defaultState tmpDir testRepoPath
-- | Execute arbitrary commands in the specified directory.
contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
length (filter (Hap.isReleaseString Hap.Long) contents) `shouldBe` 5
justExec :: Path Abs Dir -> String -> Hapistrano ()
justExec path cmd' =
case Hap.mkGenericCommand cmd' of
Nothing -> Hap.failWith 1 (Just $ "Failed to parse the command: " ++ cmd')
Just cmd -> Hap.exec (Hap.Cd path cmd)
describe "rollback" $
it "rolls back to the previous release" $
withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
-- | Run 'Hapistrano' monad locally.
testRepoPath <- genSourceRepo tmpDir
let deployState = defaultState tmpDir testRepoPath
runHap :: Hapistrano a -> IO a
runHap = Hap.runHapistrano Nothing
deployAndActivate deployState
-- | Make a 'Task' given deploy path and path to the repo.
-- current symlink should point to the last release directory
contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
let firstRelease = head $ filter (Hap.isReleaseString Hap.Long) contents
firstReleaseLinkTarget <-
runReaderT (runEitherT Hap.readCurrentLink) deployState
firstRelease `shouldBe` Hap.pathToRelease (fromRight firstReleaseLinkTarget)
-- deploy a second version
deployAndActivate deployState
-- current symlink should point to second release
conts <- getDirectoryContents (joinPath [tmpDir, "releases"])
let secondRelease =
sort (filter (Hap.isReleaseString Hap.Long) conts) !! 1
secondReleaseLinkTarget <-
runReaderT (runEitherT Hap.readCurrentLink) deployState
secondRelease `shouldBe` Hap.pathToRelease (fromRight secondReleaseLinkTarget)
-- roll back, and current symlink should point to first release again
rollback deployState
afterRollbackLinkTarget <-
runReaderT (runEitherT Hap.readCurrentLink) deployState
Hap.pathToRelease (fromRight afterRollbackLinkTarget) `shouldBe` firstRelease
mkTask :: Path Abs Dir -> Path Abs Dir -> Task
mkTask deployPath repoPath = Task
{ taskDeployPath = deployPath
, taskRepository = fromAbsDir repoPath
, taskRevision = "master"
, taskReleaseFormat = ReleaseLong }

559
src/System/Hapistrano.hs
View File

@ -1,6 +1,6 @@
-- |
-- Module : System.Hapistrano
-- Copyright : © 2017 Stack Builders
-- Copyright : © 2015-2017 Stack Builders
-- License : MIT
--
-- Maintainer : Justin Leitgeb <justin@stackbuilders.com>
@ -9,433 +9,210 @@
--
-- A module for creating reliable deploy processes for Haskell applications.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module System.Hapistrano
( Config(..)
, ReleaseFormat(..)
( pushRelease
, activateRelease
, rollback
, dropOldReleases
, playScript
-- * Path helpers
, releasePath
, currentSymlinkPath
, tempSymlinkPath )
where
, activateRelease
, currentPath
, cleanBuildScript
, defaultSuccessHandler
, defaultErrorHandler
, directoryExists
, isReleaseString
, pathToRelease
, pushRelease
, readCurrentLink
, restartServerCommand
, rollback
, runRC
, runBuild
) where
import Control.Monad.Reader (ReaderT(..), ask)
import System.Hapistrano.Types
(Config(..), FailureResult, Hapistrano, Release, ReleaseFormat(..))
import Control.Monad (unless, void)
import System.Exit (ExitCode(..), exitWith)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Either ( left
, right
, eitherT )
import Data.Char (isNumber, isSpace)
import Data.List (intercalate, sortBy, isInfixOf, dropWhileEnd)
import Control.Monad
import Control.Monad.Except
import Data.List (genericDrop, dropWhileEnd, sortBy)
import Data.Maybe (mapMaybe)
import Data.Ord (comparing, Down (..))
import Data.Time
import System.FilePath (joinPath, splitPath)
import System.IO (hPutStrLn, stderr)
import System.Process (readProcessWithExitCode)
import Numeric.Natural
import Path
import System.Hapistrano.Commands
import System.Hapistrano.Core
import System.Hapistrano.Types
import qualified System.IO as IO
import qualified System.Process as Process
----------------------------------------------------------------------------
-- High-level functionality
-- | Does basic project setup for a project, including making sure
-- some directories exist, and pushing a new release directory with the
-- SHA1 or branch specified in the configuration.
pushRelease :: Hapistrano Release
pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
cleanReleases >> cloneToRelease >>= setReleaseRevision
-- | Perform basic setup for a project, making sure necessary directories
-- exist and pushing a new release directory with the SHA1 or branch
-- specified in the configuration. Return identifier of the pushed release.
-- | Switches the current symlink to point to the release specified in
-- the configuration. Maybe used in either deploy or rollback cases.
activateRelease :: Release -> Hapistrano String
activateRelease rel = removeCurrentSymlink >> symlinkCurrent rel
pushRelease :: Task -> Hapistrano Release
pushRelease Task {..} = do
setupDirs taskDeployPath
ensureCacheInPlace taskRepository taskDeployPath
release <- newRelease taskReleaseFormat
cloneToRelease taskDeployPath release
setReleaseRevision taskDeployPath release taskRevision
return release
-- | Runs the deploy, along with an optional success or failure function.
runRC :: ((Int, String) -> ReaderT Config IO a) -- ^ Error handler
-> (a -> ReaderT Config IO a) -- ^ Success handler
-> Config -- ^ Hapistrano deployment configuration
-> Hapistrano a -- ^ The remote command to run
-> IO a
runRC errorHandler successHandler config command =
runReaderT (eitherT errorHandler successHandler command) config
-- | Switch the current symlink to point to the specified release. May be
-- used in deploy or rollback cases.
-- | Default method to run on deploy failure. Emits a failure message
-- and exits with a status code of 1.
defaultErrorHandler :: FailureResult -> ReaderT Config IO ()
defaultErrorHandler res =
liftIO $ hPutStrLn stderr
("Deploy failed with (status, message): " ++ show res)
>> exitWith (ExitFailure 1)
activateRelease
:: Path Abs Dir -- ^ Deploy path
-> Release -- ^ Release identifier to activate
-> Hapistrano ()
activateRelease deployPath release = do
rpath <- releasePath deployPath release
let tpath = tempSymlinkPath deployPath
cpath = currentSymlinkPath deployPath
exec (Ln rpath tpath) -- create a symlink for the new candidate
exec (Mv tpath cpath) -- atomically replace the symlink
-- | Default method to run on deploy success.
defaultSuccessHandler :: a -> ReaderT Config IO ()
defaultSuccessHandler _ =
liftIO $ putStrLn "Deploy completed successfully."
-- | Activates one of already deployed releases.
-- | Creates necessary directories for the hapistrano project. Should
-- only need to run the first time the project is deployed on a given
-- system.
setupDirs :: Hapistrano ()
setupDirs = do
conf <- ask
rollback
:: Path Abs Dir -- ^ Deploy path
-> Natural -- ^ How many releases back to go, 0 re-activates current
-> Hapistrano ()
rollback deployPath n = do
xs <- genericDrop n <$> deployedReleases deployPath
case xs of
[] -> failWith 1 (Just "Could not find the requested release to rollback to.")
(x:_) -> activateRelease deployPath x
mapM_ (runCommand (host conf) (port conf))
["mkdir -p " ++ releasesPath conf, "mkdir -p " ++ cacheRepoPath conf]
-- | Remove older releases to avoid filling up the target host filesystem.
-- | TODO
dropOldReleases
:: Path Abs Dir -- ^ Deploy path
-> Natural -- ^ How many releases to keep
-> Hapistrano () -- ^ Deleted Releases
dropOldReleases deployPath n = do
releases <- deployedReleases deployPath
forM_ (genericDrop n releases) $ \release -> do
rpath <- releasePath deployPath release
exec (Rm rpath)
directoryExists :: Maybe String -> FilePath -> IO Bool
directoryExists hst path = do
let (command, args) = case hst of
Just h -> ("ssh", [h, "ls", path])
Nothing -> ("ls", [path])
-- | Play the given script switching to diroctory of given release.
(code, _, _) <- readProcessWithExitCode command args ""
playScript
:: [GenericCommand] -- ^ Commands to execute
-> Path Abs Dir -- ^ Deploy path
-> Release -- ^ Release identifier
-> Hapistrano ()
playScript cmds deployDir release = do
rpath <- releasePath deployDir release
forM_ cmds (exec . Cd rpath)
return $ case code of
ExitSuccess -> True
ExitFailure _ -> False
----------------------------------------------------------------------------
-- Helpers
-- | Runs the given command either locally or on the local machine.
runCommand :: Maybe String -- ^ The host on which to run the command
-> Maybe Integer -- ^ The port on which to run the command
-> String -- ^ The command to run, either on the local or remote host
-> Hapistrano String
-- | Ensure that necessary directories exist. Idempotent.
runCommand Nothing _ command = execShellCommand command
runCommand (Just server) Nothing command =
execCommand $ unwords ["ssh", server, command]
runCommand (Just server) (Just port') command =
execCommand $ unwords ["ssh", server, "-p", show port', command]
setupDirs
:: Path Abs Dir -- ^ Deploy path
-> Hapistrano ()
setupDirs deployPath = do
(exec . MkDir . releasesPath) deployPath
(exec . MkDir . cacheRepoPath) deployPath
execShellCommand :: String -> Hapistrano String
execShellCommand command = do
liftIO $ putStrLn ("Executing: " ++ command)
let process = Process.shell command
(_, Just outHandle, Just errHandle, processHandle) <-
liftIO $
Process.createProcess process { Process.std_err = Process.CreatePipe
, Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
}
exitCode <- liftIO $ Process.waitForProcess processHandle
case exitCode of
ExitFailure code -> do
err <- liftIO $ IO.hGetContents errHandle
left (code, trim err)
ExitSuccess -> do
out <- liftIO $ IO.hGetContents outHandle
unless (null out) (liftIO $ putStrLn ("Output: " ++ out))
right (trim out)
-- | Ensure that the specified repo is cloned and checked out on the given
-- revision. Idempotent.
execCommand :: String -> Hapistrano String
execCommand cmd = do
let wds = words cmd
(cmd', args) = (head wds, tail wds)
ensureCacheInPlace
:: String -- ^ Repo URL
-> Path Abs Dir -- ^ Deploy path
-> Hapistrano ()
ensureCacheInPlace repo deployPath = do
let cpath = cacheRepoPath deployPath
refs = cpath </> $(mkRelDir "refs")
exists <- (exec (Ls refs) >> return True)
`catchError` const (return False)
unless exists $
exec (GitClone True (Left repo) cpath)
exec (Cd cpath (GitFetch "origin")) -- TODO store this in task description?
liftIO $ putStrLn $ "Executing: " ++ cmd
-- | Create a new realese identifier based on current timestamp.
(code, stdout, err) <- liftIO $ readProcessWithExitCode cmd' args ""
newRelease :: ReleaseFormat -> Hapistrano Release
newRelease releaseFormat =
mkRelease releaseFormat <$> liftIO getCurrentTime
case code of
ExitSuccess -> do
unless (null stdout) (liftIO $ putStrLn $ "Output: " ++ stdout)
-- | Clone the repository to create the specified 'Release'.
right $ trim stdout
cloneToRelease
:: Path Abs Dir -- ^ Deploy path
-> Release -- ^ 'Release' to create
-> Hapistrano ()
cloneToRelease deployPath release = do
rpath <- releasePath deployPath release
let cpath = cacheRepoPath deployPath
exec (GitClone False (Right cpath) rpath)
ExitFailure int -> left (int, trim err)
-- | Set the release to the correct revision by resetting the head of the
-- git repo.
-- | Returns a timestamp in the default format for build directories.
currentTimestamp :: ReleaseFormat -> IO String
currentTimestamp format = do
curTime <- getCurrentTime
return $ formatTime defaultTimeLocale fstring curTime
setReleaseRevision
:: Path Abs Dir -- ^ Deploy path
-> Release -- ^ 'Release' to reset
-> String -- ^ Revision to reset to
-> Hapistrano ()
setReleaseRevision deployPath release revision = do
rpath <- releasePath deployPath release
exec (Cd rpath (GitReset revision))
where fstring = case format of
Short -> "%Y%m%d%H%M%S"
Long -> "%Y%m%d%H%M%S%q"
-- | Return a list of all currently deployed releases sorted newest first.
-- | Returns the FilePath pointed to by the current symlink.
readCurrentLink :: Hapistrano FilePath -- ^ The target of the symlink in the Hapistrano monad
readCurrentLink = do
conf <- ask
runCommand (host conf) (port conf) $ "readlink " ++ currentPath (deployPath conf)
deployedReleases
:: Path Abs Dir -- ^ Deploy path
-> Hapistrano [Release]
deployedReleases deployPath = do
let rpath = releasesPath deployPath
xs <- exec (FindDir 1 rpath)
ps <- mapM (stripDir rpath) (filter (/= rpath) xs)
(return . sortBy (comparing Down) . mapMaybe parseRelease)
(dropWhileEnd (== '/') . fromRelDir <$> ps)
-- ^ Trims any newlines from the given String
trim :: String -- ^ String to have trailing newlines stripped
-> String -- ^ String with trailing newlines removed
trim = dropWhileEnd isSpace . dropWhile isSpace
----------------------------------------------------------------------------
-- Path helpers
-- | Ensure that the initial bare repo exists in the repo directory. Idempotent.
ensureRepositoryPushed :: Hapistrano String
ensureRepositoryPushed = do
conf <- ask
res <-
liftIO $ directoryExists (host conf) $ joinPath [cacheRepoPath conf, "refs"]
-- | Return the full path to the directory containing all of the release
-- builds.
if res
then right "Repo already existed"
else createCacheRepo
releasesPath
:: Path Abs Dir -- ^ Deploy path
-> Path Abs Dir
releasesPath deployPath = deployPath </> $(mkRelDir "releases")
-- | Returns the full path of the folder containing all of the release builds.
releasesPath :: Config -> FilePath
releasesPath conf = joinPath [deployPath conf, "releases"]
-- | Construct path to a particular 'Release'.
-- | Figures out the most recent release if possible.
detectPrevious :: [String] -- ^ The releases in `releases` path
-> Hapistrano String -- ^ The previous release in the Hapistrano monad
detectPrevious rs =
case biggest rs of
Nothing -> left (1, "No previous releases detected!")
Just rls -> right rls
releasePath
:: Path Abs Dir -- ^ Deploy path
-> Release -- ^ 'Release' identifier
-> Hapistrano (Path Abs Dir)
releasePath deployPath release = do
let rendered = renderRelease release
case parseRelDir rendered of
Nothing -> failWith 1 (Just $ "Could not append path: " ++ rendered)
Just rpath -> return (releasesPath deployPath </> rpath)
-- | Activates the previous detected release.
rollback :: Hapistrano String -- ^ The current Release in the Hapistrano monad
rollback = previousReleases >>= detectPrevious >>= activateRelease
-- | Clones the repository to the next releasePath timestamp. Makes a new
-- timestamp if one doesn't yet exist in the HapistranoState. Returns the
-- timestamp of the release that we cloned to.
cloneToRelease :: Hapistrano Release -- ^ The newly-cloned Release, in the Hapistrano monad
cloneToRelease = do
conf <- ask
rls <- liftIO $ currentTimestamp (releaseFormat conf)
void $ runCommand (host conf) (port conf) $ "git clone " ++ cacheRepoPath conf ++
" " ++ joinPath [ releasesPath conf, rls ]
return rls
-- | Returns the full path to the git repo used for cache purposes on the
-- | Return the full path to the git repo used for cache purposes on the
-- target host filesystem.
cacheRepoPath :: Config -- ^ The Hapistrano configuration
-> FilePath -- ^ The full path to the git cache repo used for speeding up deploys
cacheRepoPath conf = joinPath [deployPath conf, "repo"]
-- | Returns the full path to the current symlink.
currentPath :: FilePath -- ^ The full path of the deploy folder root
-> FilePath -- ^ The full path to the `current` symlink
currentPath depPath = joinPath [depPath, "current"]
cacheRepoPath
:: Path Abs Dir -- ^ Deploy path
-> Path Abs Dir
cacheRepoPath deployPath = deployPath </> $(mkRelDir "repo")
-- | Take the release timestamp from the end of a filepath.
pathToRelease :: FilePath -- ^ The entire FilePath to a Release directory
-> Release -- ^ The Release number.
pathToRelease = last . splitPath
-- | Get full path to current symlink.
-- | Returns a list of Strings representing the currently deployed releases.
releases :: Hapistrano [Release] -- ^ A list of all found Releases on the target host
releases = do
conf <- ask
res <- runCommand (host conf) (port conf) $ "find " ++ releasesPath conf ++
" -type d -maxdepth 1"
currentSymlinkPath
:: Path Abs Dir -- ^ Deploy path
-> Path Abs File
currentSymlinkPath deployPath = deployPath </> $(mkRelFile "current")
right $
filter (isReleaseString (releaseFormat conf)) . map pathToRelease $
lines res
-- | Get full path to temp symlink.
previousReleases :: Hapistrano [Release] -- ^ All non-current releases on the target host
previousReleases = do
rls <- releases
currentRelease <- readCurrentLink
let currentRel = (head . lines . pathToRelease) currentRelease
return $ filter (< currentRel) rls
releasePath :: Config -> Release -> FilePath
releasePath conf rls = joinPath [releasesPath conf, rls]
-- | Given a list of release strings, takes the last four in the sequence.
-- Assumes a list of folders that has been determined to be a proper release
-- path.
oldReleases :: Config -> [Release] -> [FilePath]
oldReleases conf rs = map mergePath toDelete
where sorted = sortBy (flip compare) rs
toDelete = drop 4 sorted
mergePath = releasePath conf
-- | Removes releases older than the last five to avoid filling up the target
-- host filesystem.
cleanReleases :: Hapistrano [String] -- ^ Deleted Release directories
cleanReleases = do
conf <- ask
allReleases <- releases
let deletable = oldReleases conf allReleases
if null deletable
then do
liftIO $ putStrLn "There are no old releases to prune."
return []
else do
_ <- runCommand (host conf) (port conf) $ "rm -rf -- " ++ unwords deletable
return deletable
-- | Returns a Bool indicating if the given String is in the proper release
-- format.
isReleaseString :: ReleaseFormat -- ^ Format of Release directories
-> String -- ^ String to check against Release format
-> Bool -- ^ Whether the given String adheres to the specified Release format
isReleaseString format s = all isNumber s && length s == releaseLength
where releaseLength = case format of
Short -> 14
Long -> 26
-- | Creates the git repository that is used on the target host for
-- cache purposes.
createCacheRepo :: Hapistrano String -- ^ Output of the git command used to create the bare cache repo
createCacheRepo = do
conf <- ask
runCommand (host conf) (port conf) $ "git clone --bare " ++ repository conf ++ " " ++
cacheRepoPath conf
-- | Returns the full path of the symlink pointing to the current
-- release.
currentSymlinkPath :: Config -> FilePath
currentSymlinkPath conf = joinPath [deployPath conf, "current"]
currentTempSymlinkPath :: Config -> FilePath
currentTempSymlinkPath conf = joinPath [deployPath conf, "current_tmp"]
-- | Removes the current symlink in preparation for a new release being
-- activated.
removeCurrentSymlink :: Hapistrano ()
removeCurrentSymlink = do
conf <- ask
void $ runCommand (host conf) (port conf) $ "rm -rf " ++ currentSymlinkPath conf
-- | Determines whether the target host OS is Linux
targetIsLinux :: Hapistrano Bool
targetIsLinux = do
conf <- ask
res <- runCommand (host conf) (port conf) "uname"
right $ "Linux" `isInfixOf` res
-- | Runs a command to restart a server if a command is provided.
restartServerCommand :: Hapistrano String
restartServerCommand = do
conf <- ask
case restartCommand conf of
Nothing -> return "No command given for restart action."
Just cmd -> runCommand (host conf) (port conf) cmd
-- | TODO
cleanBuildScript :: [String] -> [String]
cleanBuildScript allScriptLines = filter (not . isCommentOrEmpty) allScriptLines
where
isCommentOrEmpty line = isEmpty line || isComment line
isComment line = (head $ trim line) == '#'
isEmpty line = (trim line) == ""
-- | Runs a build script if one is provided.
runBuild :: Release -> Hapistrano Release
runBuild rel = do
conf <- ask
case buildScript conf of
Nothing ->
liftIO $ putStrLn "No build script specified, skipping build step."
Just scr -> do
fl <- liftIO $ readFile scr
buildRelease rel $ cleanBuildScript $ lines fl
right rel
-- | Returns the best 'mv' command for a symlink given the target platform.
mvCommand :: Bool -- ^ Whether the target host is Linux
-> String -- ^ The best mv command for a symlink on the platform
mvCommand True = "mv -Tf"
mvCommand False = "mv -f"
-- | Creates a symlink to the current release.
lnCommand ::
String -- ^ The path of the new release
-> String -- ^ The temporary symlink target for the release
-> String -- ^ A command to create the temporary symlink
lnCommand rlsPath symlinkPath = unwords ["ln -s", rlsPath, symlinkPath]
-- | Creates a symlink to the directory indicated by the release timestamp.
-- hapistrano does this by creating a temporary symlink and doing an atomic
-- mv (1) operation to activate the new release.
symlinkCurrent :: Release -> Hapistrano String
symlinkCurrent rel = do
conf <- ask
isLnx <- targetIsLinux
let tmpLnCmd =
lnCommand (releasePath conf rel) (currentTempSymlinkPath conf)
_ <- runCommand (host conf) (port conf) tmpLnCmd
runCommand (host conf) (port conf) $ unwords [ mvCommand isLnx
, currentTempSymlinkPath conf
, currentSymlinkPath conf ]
-- | Updates the git repo used as a cache in the target host filesystem.
updateCacheRepo :: Hapistrano ()
updateCacheRepo = do
conf <- ask
void $ runCommand (host conf) (port conf) $ intercalate " && "
[ "cd " ++ cacheRepoPath conf
, "git fetch origin +refs/heads/*:refs/heads/*" ]
-- | Sets the release to the correct revision by resetting the
-- head of the git repo.
setReleaseRevision :: Release -> Hapistrano Release
setReleaseRevision rel = do
conf <- ask
liftIO $ putStrLn "Setting revision in release path."
void $ runCommand (host conf) (port conf) $ intercalate " && "
[ "cd " ++ releasePath conf rel
, "git fetch --all"
, "git reset --hard " ++ revision conf
]
return rel
-- | Returns a command that builds this application. Sets the context
-- of the build by switching to the release directory before running
-- the script.
buildRelease :: Release -- ^ The Release to build
-> [String] -- ^ Commands to be run. List intercalated
-- with "&&" so that failure aborts the
-- sequence.
-> Hapistrano ()
buildRelease rel commands = do
conf <- ask
let cdCmd = "cd " ++ releasePath conf rel
void $ runCommand (host conf) (port conf) $ intercalate " && " $ cdCmd : commands
-- | A safe version of the `maximum` function in Data.List.
biggest :: Ord a => [a] -> Maybe a
biggest rls =
case sortBy (flip compare) rls of
[] -> Nothing
r:_ -> Just r
tempSymlinkPath
:: Path Abs Dir -- ^ Deploy path
-> Path Abs File
tempSymlinkPath deployPath = deployPath </> $(mkRelFile "current_tmp")

273
src/System/Hapistrano/Commands.hs Normal file
View File

@ -0,0 +1,273 @@
-- |
-- Module : System.Hapistrano.Commands
-- Copyright : © 2015-2017 Stack Builders
-- License : MIT
--
-- Maintainer : Justin Leitgeb <justin@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
( Command (..)
, Whoami (..)
, Cd (..)
, MkDir (..)
, Rm (..)
, Mv (..)
, Ln (..)
, Ls (..)
, Readlink (..)
, FindDir (..)
, GitClone (..)
, GitFetch (..)
, GitReset (..)
, GenericCommand
, mkGenericCommand
, unGenericCommand
, readScript )
where
import Control.Monad.IO.Class
import Data.Char (isSpace)
import Data.List (dropWhileEnd)
import Data.Maybe (catMaybes, mapMaybe, fromJust)
import Data.Proxy
import Numeric.Natural
import Path
----------------------------------------------------------------------------
-- Commands
-- | Class for data types that represent shell commands in typed way.
class Command a where
-- | Type of result.
type Result a :: *
-- | How to render the command before feeding it into shell (possibly via
-- SSH).
renderCommand :: a -> String
-- | How to parse the result from stdout.
parseResult :: Proxy a -> String -> Result a
-- | Unix @whoami@.
data Whoami = Whoami
deriving (Show, Eq, Ord)
instance Command Whoami where
type Result Whoami = String
renderCommand Whoami = "whoami"
parseResult Proxy = trim
-- | Specify directory in which to perform another command.
data Cd cmd = Cd (Path Abs Dir) cmd
instance Command cmd => Command (Cd cmd) where
type Result (Cd cmd) = Result cmd
renderCommand (Cd path cmd) = "(cd " ++ quote (fromAbsDir path) ++
" && " ++ renderCommand cmd ++ ")"
parseResult Proxy = parseResult (Proxy :: Proxy cmd)
-- | Create a directory. Does not fail if the directory already exists.
data MkDir = MkDir (Path Abs Dir)
instance Command MkDir where
type Result MkDir = ()
renderCommand (MkDir path) = formatCmd "mkdir"
[ Just "-pv"
, Just (fromAbsDir path) ]
parseResult Proxy _ = ()
-- | Delete file or directory.
data Rm where
Rm :: Path Abs t -> Rm
instance Command Rm where
type Result Rm = ()
renderCommand (Rm path) = formatCmd "rm"
[ Just "-rfv"
, Just (toFilePath path) ]
parseResult Proxy _ = ()
-- | Move or rename files or directories.
data Mv t = Mv (Path Abs t) (Path Abs t)
instance Command (Mv File) where
type Result (Mv File) = ()
renderCommand (Mv old new) = formatCmd "mv"
[ Just "-fvT"
, Just (fromAbsFile old)
, Just (fromAbsFile new) ]
parseResult Proxy _ = ()
instance Command (Mv Dir) where
type Result (Mv Dir) = ()
renderCommand (Mv old new) = formatCmd "mv"
[ Just "-fv"
, Just (fromAbsDir old)
, Just (fromAbsDir new) ]
parseResult Proxy _ = ()
-- | Create symlinks.
data Ln where
Ln :: Path Abs t -> Path Abs File -> Ln
instance Command Ln where
type Result Ln = ()
renderCommand (Ln target linkName) = formatCmd "ln"
[ Just "-svT"
, Just (toFilePath target)
, Just (fromAbsFile linkName) ]
parseResult Proxy _ = ()
-- | Read link.
data Readlink t = Readlink (Path Abs File)
instance Command (Readlink File) where
type Result (Readlink File) = Path Abs File
renderCommand (Readlink path) = formatCmd "readlink"
[ Just "-f"
, Just (toFilePath path) ]
parseResult Proxy = fromJust . parseAbsFile . trim
instance Command (Readlink Dir) where
type Result (Readlink Dir) = Path Abs Dir
renderCommand (Readlink path) = formatCmd "readlink"
[ Just "-f"
, Just (toFilePath path) ]
parseResult Proxy = fromJust . parseAbsDir . trim
-- | @ls@, so far used only to check existence of directories, so it's not
-- very functional right now.
data Ls = Ls (Path Abs Dir)
instance Command Ls where
type Result Ls = ()
renderCommand (Ls path) = formatCmd "ls"
[ Just (fromAbsDir path) ]
parseResult Proxy _ = ()
-- | Find (a very limited version, only finds directories).
data FindDir = FindDir Natural (Path Abs Dir)
instance Command FindDir where
type Result FindDir = [Path Abs Dir]
renderCommand (FindDir maxDepth dir) = formatCmd "find"
[ Just (fromAbsDir dir)
, Just "-maxdepth"
, Just (show maxDepth)
, Just "-type"
, Just "d" ]
parseResult Proxy = mapMaybe parseAbsDir . fmap trim . lines
-- | Git clone.
data GitClone = GitClone Bool (Either String (Path Abs Dir)) (Path Abs Dir)
instance Command GitClone where
type Result GitClone = ()
renderCommand (GitClone bare src dest) = formatCmd "git"
[ Just "clone"
, if bare then Just "--bare" else Nothing
, Just (case src of
Left repoUrl -> repoUrl
Right srcPath -> fromAbsDir srcPath)
, Just (fromAbsDir dest) ]
parseResult Proxy _ = ()
-- | Git fetch (simplified).
data GitFetch = GitFetch String
instance Command GitFetch where
type Result GitFetch = ()
renderCommand (GitFetch remote) = formatCmd "git"
[ Just "fetch"
, Just remote ]
parseResult Proxy _ = ()
-- | Git reset.
data GitReset = GitReset String
instance Command GitReset where
type Result GitReset = ()
renderCommand (GitReset revision) = formatCmd "git"
[ Just "reset"
, Just revision ]
parseResult Proxy _ = ()
-- | Weakly-typed generic command, avoid using it directly.
data GenericCommand = GenericCommand String
deriving (Show, Eq, Ord)
instance Command GenericCommand where
type Result GenericCommand = ()
renderCommand (GenericCommand cmd) = cmd
parseResult Proxy _ = ()
-- | Smart constructor that allows to create 'GenericCommand's. Just a
-- little bit more safety.
mkGenericCommand :: String -> Maybe GenericCommand
mkGenericCommand str =
if '\n' `elem` str' || null str'
then Nothing
else Just (GenericCommand str')
where
str' = trim (takeWhile (/= '#') str)
-- | Get the raw command back from 'GenericCommand'.
unGenericCommand :: GenericCommand -> String
unGenericCommand (GenericCommand x) = x
-- | Read commands from a file.
readScript :: MonadIO m => Path Abs File -> m [GenericCommand]
readScript path = liftIO $ catMaybes . fmap mkGenericCommand . lines
<$> readFile (fromAbsFile path)
----------------------------------------------------------------------------
-- Helpers
-- | Format a command.
formatCmd :: String -> [Maybe String] -> String
formatCmd cmd args = unwords (quote <$> (cmd : catMaybes args))
-- | Simple-minded quoter.
quote :: String -> String
quote str =
if any isSpace str
then "\"" ++ str ++ "\""
else str
-- | Trim whitespace from beginning and end.
trim :: String -> String
trim = dropWhileEnd isSpace . dropWhile isSpace

98
src/System/Hapistrano/Core.hs Normal file
View File

@ -0,0 +1,98 @@
-- |
-- Module : System.Hapistrano.Core
-- Copyright : © 2015-2017 Stack Builders
-- License : MIT
--
-- Maintainer : Justin Leitgeb <justin@stackbuilders.com>
-- Stability : experimental
-- Portability : portable
--
-- Core Hapistrano functions that provide basis on which all the
-- functionality is built.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.Hapistrano.Core
( runHapistrano
, failWith
, exec )
where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.Proxy
import System.Exit
import System.Hapistrano.Commands
import System.Hapistrano.Types
import System.IO
import System.Process
-- | Run the 'Hapistrano' monad. The monad hosts 'exec' actions.
runHapistrano :: MonadIO m
=> Maybe SshOptions -- ^ SSH options to use or 'Nothing' if we run locally
-> Hapistrano a -- ^ The computation to run
-> m a -- ^ IO-enabled monad that hosts the computation
runHapistrano sshOptions m = liftIO $ do
let config = Config
{ configSshOptions = sshOptions }
r <- runReaderT (runExceptT m) config
case r of
Left (Failure n msg) -> do
forM_ msg (hPutStrLn stderr)
exitWith (ExitFailure n)
Right x ->
x <$ putStrLn "Success."
-- | Fail returning the following status code and printing given message to
-- 'stderr'.
failWith :: Int -> Maybe String -> Hapistrano a
failWith n msg = throwError (Failure n msg)
-- | Run the given sequence of command. Whether to use SSH or not is
-- determined from settings contained in the 'Hapistrano' monad
-- configuration. Commands that return non-zero exit codes will result in
-- short-cutting of execution.
exec :: forall a. Command a => a -> Hapistrano (Result a)
exec typedCmd = do
Config {..} <- ask
let (prog, args) =
case configSshOptions of
Nothing ->
("bash", ["-c", cmd])
Just SshOptions {..} ->
("ssh", [sshHost, "-p", show sshPort, cmd])
cmd = renderCommand typedCmd
hostLabel =
case configSshOptions of
Nothing -> "localhost"
Just SshOptions {..} -> sshHost ++ ":" ++ show sshPort
liftIO $ do
printLine hostLabel
putStrLn ("$ " ++ cmd)
(exitCode, stdout', stderr') <- liftIO
(readProcessWithExitCode prog args "")
unless (null stdout') . liftIO $
putStrLn stdout'
unless (null stderr') . liftIO $
hPutStrLn stderr stderr'
case exitCode of
ExitSuccess ->
return (parseResult (Proxy :: Proxy a) stdout')
ExitFailure n ->
failWith n Nothing
----------------------------------------------------------------------------
-- Helpers
-- | Print something “inside” a line, sort-of beautifully.
printLine :: String -> IO ()
printLine str = putStrLn ("*** " ++ str ++ padding)
where
padding = ' ' : replicate (75 - length str) '*'

122
src/System/Hapistrano/Types.hs
View File

@ -1,70 +1,108 @@
-- |
-- Module : System.Hapistrano.Types
-- Copyright : © 2017 Stack Builders
-- Copyright : © 2015-2017 Stack Builders
-- License : MIT
--
-- Maintainer : Justin Leitgeb <justin@stackbuilders.com>
-- Stability : experimental
-- Portability : portable
--
-- TODO
-- Type definitions for the Hapistrano tool.
module System.Hapistrano.Types
( Config(..)
, FailureResult
, Hapistrano
, Release
, ReleaseFormat(..)
) where
( Hapistrano
, Failure (..)
, Config (..)
, Task (..)
, ReleaseFormat(..)
, SshOptions (..)
, Release
, mkRelease
, releaseTime
, renderRelease
, parseRelease )
where
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.Trans.Either (EitherT(..))
import Control.Applicative
import Control.Monad.Except
import Control.Monad.Reader
import Data.Time
import Path
-- | Config stuff that will be replaced by config file reading
data Config =
Config { deployPath :: String
-- ^ The root of the deploy target on the remote host
-- | Hapistrano monad.
, repository :: String -- ^ The remote git repo
, revision :: String -- ^ A SHA1 or branch to release
type Hapistrano a = ExceptT Failure (ReaderT Config IO) a
, releaseFormat :: ReleaseFormat
, host :: Maybe String
-- ^ The target host for the deploy, or Nothing to indicate that
-- operations should be done directly in the local deployPath without
-- going over SSH
-- | Failure with status code and a message.
, buildScript :: Maybe FilePath
-- ^ The local path to a file that should be executed on the remote
-- server to build the application.
data Failure = Failure Int (Maybe String)
, restartCommand :: Maybe String
-- ^ Optional command to restart the server after a successful deploy
-- | Hapistrano configuration options.
, port :: Maybe Integer
-- ^ Optional port to deploy to a different ssh port
data Config = Config
{ configSshOptions :: Maybe SshOptions
-- ^ 'Nothing' if we are running locally, or SSH options to use.
}
} deriving (Show)
-- | The records describes deployment task.
-- | TODO
data Task = Task
{ taskDeployPath :: Path Abs Dir
-- ^ The root of the deploy target on the remote host
, taskRepository :: String
-- ^ The URL of remote Git repo to deploy
, taskRevision :: String
-- ^ A SHA1 or branch to release
, taskReleaseFormat :: ReleaseFormat
-- ^ The 'ReleaseFormat' to use
} deriving (Show, Eq)
data ReleaseFormat = Short
-- ^ Standard release path following Capistrano's format
-- | Release format mode.
| Long
-- ^ Long release path including picoseconds for testing
-- or people seriously into continuous deployment
data ReleaseFormat
= ReleaseShort -- ^ Standard release path following Capistrano's format
| ReleaseLong -- ^ Long release path including picoseconds
deriving (Show, Read, Eq, Ord, Enum, Bounded)
deriving (Show)
-- | SSH options.
-- | TODO
data SshOptions = SshOptions
{ sshHost :: String -- ^ Host to use
, sshPort :: Word -- ^ Port to use
} deriving (Show, Eq, Ord)
type Release = String
-- | Release indentifier.
-- | TODO
data Release = Release ReleaseFormat UTCTime
deriving (Eq, Show, Ord)
type FailureResult = (Int, String)
-- | Create a 'Release' indentifier.
-- | TODO
mkRelease :: ReleaseFormat -> UTCTime -> Release
mkRelease = Release
type Hapistrano a = EitherT FailureResult (ReaderT Config IO) a
-- | Extract deployment time from 'Release'.
releaseTime :: Release -> UTCTime
releaseTime (Release _ time) = time
-- | Render 'Release' indentifier as a 'String'.
renderRelease :: Release -> String
renderRelease (Release rfmt time) = formatTime defaultTimeLocale fmt time
where
fmt = case rfmt of
ReleaseShort -> releaseFormatShort
ReleaseLong -> releaseFormatLong
-- | Parse 'Release' identifier from a 'String'.
parseRelease :: String -> Maybe Release
parseRelease s = (Release ReleaseLong <$> p releaseFormatLong s)
<|> (Release ReleaseShort <$> p releaseFormatShort s)
where
p = parseTimeM False defaultTimeLocale
releaseFormatShort, releaseFormatLong :: String
releaseFormatShort = "%Y%m%d%H%M%S"
releaseFormatLong = "%Y%m%d%H%M%S%q"