hapistrano 0.1.0.2 → 0.2.0.1

raw patch · 6 files changed

+529/−447 lines, 6 filesdep +base-compatdep +directorydep +hspecdep −lensdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: base-compat, directory, hspec, mtl, temporary

Dependencies removed: lens

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• hapistrano.cabal +55/−12
• spec/Spec.hs +1/−0
• src/Hapistrano.hs +0/−414
• src/Main.hs +23/−21
• src/System/Hapistrano.hs +401/−0
• src/System/Hapistrano/Types.hs +49/−0

@@ -1,46 +1,89 @@ name:                hapistrano-version:             0.1.0.2+version:             0.2.0.1 synopsis:            A deployment library for Haskell applications-description:         Hapistrano makes it easy to reliably deploy Haskell-                     applications.-+description:+  .+  Hapistrano makes it easy to reliably deploy Haskell applications+  to a server.+  .+  Following popular libraries like Ruby's <http://capistranorb.com/+  Capistrano>, Hapistrano does the work of building the application+  with dependencies into a distinct folder, and then atomically moves+  a symlink to the latest complete build.+  .+  This allows for atomic switchovers to new application code after the+  build is complete. Rollback is even simpler, since Hapistrano can+  just point the `current` symlink to the previous release.+  .+  See <https://github.com/stackbuilders/hapistrano the project readme on GitHub>+  for more information.+  . license:             MIT license-file:        LICENSE author:              Justin Leitgeb maintainer:          justin@stackbuilders.com-copyright:           2014 Stack Builders Inc.+copyright:           2015 Stack Builders Inc. category:            System+Homepage:            https://github.com/stackbuilders/hapistrano+Bug-reports:         https://github.com/stackbuilders/hapistrano/issues build-type:          Simple cabal-version:       >=1.10  executable hap   main-is:        Main.hs   hs-source-dirs: src-  build-depends:         base >=4.6 && <4.8+  build-depends:         base >=4.5 && <4.8                        , time                        , old-locale                        , process                        , either                        , transformers-                       , lens >= 4.1+                       , mtl                        , filepath-                       , either+                       , base-compat+   default-language:    Haskell2010+  ghc-options:         -Wall  library-  exposed-modules:     Hapistrano-  build-depends:         base >=4.6 && <4.8+  exposed-modules:     System.Hapistrano+  other-modules:       System.Hapistrano.Types++  build-depends:         base >=4.5 && <4.8                        , time                        , old-locale                        , process                        , either                        , transformers-                       , lens >= 4.1+                       , mtl                        , filepath-                       , either+                       , base-compat    hs-source-dirs:      src   default-language:    Haskell2010+  ghc-options:         -Wall++test-suite hapistrano-test+  type: exitcode-stdio-1.0+  hs-source-dirs: spec, src+  main-is: Spec.hs++  build-depends:       base >=4.5 && <4.8+                       , time+                       , old-locale+                       , process+                       , either+                       , transformers+                       , mtl+                       , filepath+                       , base-compat++                     , hspec+                     , temporary+                     , directory++  default-language:    Haskell2010+  ghc-options:         -Wall  source-repository head   type:     git

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -1,414 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}---- | A module for easily creating reliable deploy processes for Haskell--- applications.-module Hapistrano-       (-         Config(..)-       , initialState-       , runRC--       , activateRelease-       , runBuild-       , defaultSuccessHandler-       , defaultErrorHandler-       , pushRelease-       , restartServerCommand-       , rollback-       ) where--import Control.Lens (makeLenses, use, (^.), (.=))-import Control.Monad (unless)-import System.Exit (ExitCode(..), exitWith)--import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Trans.State (StateT, evalStateT, get)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Either ( EitherT(..)-                                  , left-                                  , right-                                  , runEitherT-                                  , eitherT )-import Data.Char (isNumber)-import Data.List (intercalate, sortBy, sort, isInfixOf)-import Data.Time (getCurrentTime)-import Data.Time.Format (formatTime)-import System.Exit (ExitCode(..))-import System.FilePath.Posix (joinPath, splitPath)-import System.IO (hPutStrLn, stderr)-import System.Locale (defaultTimeLocale)-import System.Process (readProcessWithExitCode)---- | Config stuff that will be replaced by config file reading-data Config = Config { _deployPath :: String-                     , _host       :: String-                     , _repository :: String -- ^ The remote git repo-                     , _revision   :: String -- ^ A SHA1 or branch to release-                     , _buildScript    :: Maybe FilePath-                     , _restartCommand :: Maybe String-                     } deriving (Show)--makeLenses ''Config---data HapistranoState = HapistranoState { _config    :: Config-                                       , _timestamp :: Maybe String-                                       }-makeLenses ''HapistranoState--type Release = String--type RC a = StateT HapistranoState (EitherT (Int, Maybe String) IO) a---- | 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 :: RC (Maybe String)-pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>-              cleanReleases >> cloneToRelease >> setReleaseRevision---- | Switches the current symlink to point to the release specified in--- the configuration. Maybe used in either deploy or rollback cases.-activateRelease :: RC (Maybe String)-activateRelease = removeCurrentSymlink >> symlinkCurrent----- | Returns an initial state for the deploy.-initialState :: Config -> HapistranoState-initialState cfg = HapistranoState { _config    = cfg-                                   , _timestamp = Nothing-                                   }---- | Given a pair of actions, one to perform in case of failure, and--- one to perform in case of success, run an EitherT and get back a--- monadic result.-runRC :: ((Int, Maybe String) -> IO a) -- ^ Error handler-      -> (a -> IO a)                   -- ^ Success handler-      -> HapistranoState               -- ^ Initial state-      -> RC a-      -> IO a-runRC errorHandler successHandler initState remoteCmd =-    eitherT errorHandler-            successHandler-            (evalStateT remoteCmd initState)--defaultErrorHandler :: (Int, Maybe String) -> IO ()-defaultErrorHandler _ =-  hPutStrLn stderr "Deploy failed." >> exitWith (ExitFailure 1)--defaultSuccessHandler :: a -> IO ()-defaultSuccessHandler _ = putStrLn "Deploy completed successfully."----- | Creates necessary directories for the hapistrano project. Should--- only need to run the first time the project is deployed on a given--- system.-setupDirs :: RC (Maybe String)-setupDirs = do-  conf <- use config--  remoteCommand $ intercalate " && "-    [ "mkdir -p " ++ releasesPath conf-    , "mkdir -p " ++ cacheRepoPath conf-    ]--remoteCommand :: String -- ^ The command to run remotely-              -> RC (Maybe String)-remoteCommand command = do-  server <- use $ config . host-  liftIO $ putStrLn $ "Going to execute " ++ command ++ " on host " ++ server-           ++ "."--  (code, stdout, err) <--    liftIO $ readProcessWithExitCode "ssh" (server : words command) ""--  case code of-    ExitSuccess -> do-      liftIO $ putStrLn $ "Command '" ++ command ++-        "' was successful on host '" ++ server ++ "'."--      unless (null stdout) (liftIO $ putStrLn $ "Output:\n" ++ stdout)--      lift $ right $ maybeString stdout--    ExitFailure int -> do-      let maybeError = maybeString err-      liftIO $ printCommandError server command (int, maybeError)-      lift $ left (int, maybeError)---- | Returns a timestamp in the default format for build directories.-currentTimestamp :: IO String-currentTimestamp = do-  curTime <- getCurrentTime-  return $ formatTime defaultTimeLocale "%Y%m%d%H%M%S" curTime--echoMessage :: String -> RC (Maybe String)-echoMessage msg = do-  liftIO $ putStrLn msg-  lift $ right Nothing--printCommandError :: String -> String -> (Int, Maybe String) -> IO ()-printCommandError server cmd (errCode, Nothing) =-  hPutStrLn stderr $ "Command " ++ " '" ++ cmd ++ "' failed on host '" ++-  server ++ "' with error code " ++ show errCode ++ " and no STDERR output."-printCommandError server cmd (errCode, Just errMsg) =-  hPutStrLn stderr $ "Command " ++ " '" ++ cmd ++ "' failed on host '" ++-  server ++ "' with error code " ++ show errCode ++ " and message '" ++-  errMsg ++ "'."--directoryExists :: FilePath -> RC (Maybe String)-directoryExists path =-  remoteCommand $ "ls " ++ path---- | Returns the FilePath pointed to by the current symlink.-readCurrentLink :: RC (Maybe FilePath)-readCurrentLink = do-  conf <- use config-  remoteCommand $ "readlink " ++ currentPath conf---- | Ensure that the initial bare repo exists in the repo directory. Idempotent.-ensureRepositoryPushed :: RC (Maybe String)-ensureRepositoryPushed = do-  conf <- use config-  res <- directoryExists $ cacheRepoPath conf--  case res of-    Nothing -> createCacheRepo-    Just _ -> lift $ right $ Just "Repo already existed"---- | Returns a Just String or Nothing based on whether the input is null or--- has contents.-maybeString :: String -> Maybe String-maybeString possibleString =-  if null possibleString then Nothing else Just possibleString---- | Returns the full path of the folder containing all of the release builds.-releasesPath :: Config -> FilePath-releasesPath conf = joinPath [conf ^. deployPath, "releases"]---- | Figures out the most recent release if possible, and sets the--- StateT monad with the correct timestamp. This function is used--- before rollbacks.-detectPrevious :: [String] -> RC (Maybe String)-detectPrevious rs = do-  let mostRecentRls = biggest rs-  case mostRecentRls of-    Nothing -> lift $ left (1, Just "No previous releases detected!")-    Just rls -> do-      timestamp .= mostRecentRls-      lift $ right $ Just rls---- | Activates the previous detected release.-rollback :: RC (Maybe String)-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.-cloneToRelease :: RC (Maybe String)-cloneToRelease = do-  conf <- use config-  releaseTimestamp <- use timestamp--  rls <- case releaseTimestamp of-           Nothing -> do-             ts <- liftIO currentTimestamp-             timestamp .= Just ts-             return ts--           Just r -> return r--  remoteCommand $ "git clone " ++ cacheRepoPath conf ++ " " ++-    joinPath [ releasesPath conf, rls ]----- | Returns the full path to the git repo used for cache purposes on the--- target host filesystem.-cacheRepoPath :: Config -> FilePath-cacheRepoPath conf = joinPath [conf ^. deployPath, "repo"]---- | Returns the full path to the current symlink.-currentPath :: Config -> FilePath-currentPath conf = joinPath [conf ^. deployPath, "current"]---- | Take the release timestamp from the end of a filepath.-pathToRelease :: FilePath -> Release-pathToRelease = last . splitPath---- | Returns a list of Strings representing the currently deployed releases.-releases :: RC [Release]-releases = do-  conf <- use config-  res  <- remoteCommand $ "find " ++ releasesPath conf ++ " -type d -maxdepth 1"--  case res of-    Nothing -> lift $ right []-    Just s ->-      lift $ right $ filter isReleaseString . map pathToRelease-      $ lines s--previousReleases :: RC [Release]-previousReleases = do-  rls <- releases-  currentRelease <- readCurrentLink--  case currentRelease of-    Nothing -> lift $ left (1, Just "Bad pointer from current link")-    Just c -> do-      let currentRel = (head . lines . pathToRelease) c-      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 :: RC (Maybe String)-cleanReleases = do-  conf <- use config-  allReleases <- releases--  case allReleases of-    [] -> echoMessage "There are no old releases to prune."-    xs -> do-      let deletable = oldReleases conf xs--      remoteCommand $ "rm -rf -- " ++ foldr (\a b -> a ++ " " ++ b) ""-        deletable---- | Returns a Bool indicating if the given String is in the proper release--- format.-isReleaseString :: String -> Bool-isReleaseString s = all isNumber s && length s == 14---- | Creates the git repository that is used on the target host for--- cache purposes.-createCacheRepo :: RC (Maybe String)-createCacheRepo = do-  conf <- use config-  remoteCommand $ "git clone --bare " ++ conf ^. repository ++ " " ++-    cacheRepoPath conf---- | Returns the full path of the symlink pointing to the current--- release.-currentSymlinkPath :: Config -> FilePath-currentSymlinkPath conf = joinPath [conf ^. deployPath, "current"]--currentTempSymlinkPath :: Config -> FilePath-currentTempSymlinkPath conf = joinPath [conf ^. deployPath, "current_tmp"]---- | Removes the current symlink in preparation for a new release being--- activated.-removeCurrentSymlink :: RC (Maybe String)-removeCurrentSymlink = do-  conf <- use config-  remoteCommand $ "rm -rf " ++ currentSymlinkPath conf---- | Determines whether the target host OS is Linux-remoteIsLinux :: RC Bool-remoteIsLinux = do-  st <- get-  res <- remoteCommand "uname"--  case res of-    Just output -> lift $ right $ "Linux" `isInfixOf` output-    _ -> lift $ left (1, Just "Unable to determine remote host type")--restartServerCommand :: RC (Maybe String)-restartServerCommand = do-  conf <- use config-  case conf ^. restartCommand of-    Nothing -> return $ Just "No command given for restart action."-    Just cmd -> remoteCommand cmd--runBuild :: RC (Maybe String)-runBuild = do-  conf <- use config-  case conf ^. buildScript of-    Nothing -> do-      liftIO $ putStrLn "No build script specified, skipping build step."-      return Nothing--    Just scr -> do-      fl <- liftIO $ readFile scr-      let commands = lines fl-      buildRelease commands---- | 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 directory indicated by the release timestamp.-symlinkCurrent :: RC (Maybe String)-symlinkCurrent = do-  conf <- use config-  releaseTimestamp <- use timestamp--  case releaseTimestamp of-    Nothing  -> lift $ left (1, Just "No releases to symlink!")-    Just rls -> do-      isLnx <- remoteIsLinux--      remoteCommand $ "ln -s " ++ releasePath conf rls ++ " " ++-        currentTempSymlinkPath conf ++-        " && " ++ mvCommand isLnx ++ " " ++-        currentTempSymlinkPath conf-        ++ " " ++ currentSymlinkPath conf---- | Updates the git repo used as a cache in the target host filesystem.-updateCacheRepo :: RC (Maybe String)-updateCacheRepo = do-  conf <- use config-  remoteCommand $ 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 :: RC (Maybe String)-setReleaseRevision = do-  conf <- use config-  releaseTimestamp <- use timestamp-  case releaseTimestamp of-    Nothing -> lift $ left (1, Just "No releases to symlink!")-    Just rls ->-      remoteCommand $ intercalate " && "-      [ "cd " ++ releasePath conf rls-      , "git fetch --all"-      , "git reset --hard " ++ conf ^. revision-      ]---- | Returns a command that builds this application. Sets the context--- of the build by switching to the release directory before running--- the script.-buildRelease :: [String] -- ^ Commands to be run. List intercalated-                         -- with "&&" so that failure aborts the-                         -- sequence.-             -> RC (Maybe String)-buildRelease commands = do-  conf <- use config-  releaseTimestamp <- use timestamp-  case releaseTimestamp of-    Nothing -> lift $ left (1, Just "No releases to symlink!")-    Just rls -> do-      let cdCmd = "cd " ++ releasePath conf rls-      remoteCommand $ 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

@@ -1,19 +1,20 @@ module Main where -import qualified Hapistrano as Hap+import qualified System.Hapistrano as Hap import Control.Monad (void)-import System.Environment (getArgs, getEnv, lookupEnv)+import System.Environment (getArgs, getEnv)+import System.Environment.Compat (lookupEnv) import System.IO (hPutStrLn, stderr)-import System.Exit (exitFailure, exitSuccess)-import Control.Applicative ((<$>))-import Control.Monad.IO.Class (MonadIO(liftIO))+import System.Exit (exitFailure) +import System.Hapistrano.Types (ReleaseFormat(..))+ -- | Rolls back to previous release. rollback :: Hap.Config -> IO () rollback cfg =-  Hap.runRC errorHandler successHandler (Hap.initialState cfg) $ do+  Hap.runRC errorHandler successHandler cfg $ do -    Hap.rollback+    _ <- Hap.rollback     void Hap.restartServerCommand    where@@ -23,10 +24,8 @@ -- | Deploys the current release with Config options. deploy :: Hap.Config -> IO () deploy cfg =-  Hap.runRC errorHandler successHandler (Hap.initialState cfg) $ do-    Hap.pushRelease-    Hap.runBuild-    Hap.activateRelease+  Hap.runRC errorHandler successHandler cfg $ do+    _ <- Hap.pushRelease >>= Hap.runBuild >>= Hap.activateRelease      void Hap.restartServerCommand @@ -37,19 +36,22 @@ -- | Retrieves the configuration from environment variables. configFromEnv :: IO Hap.Config configFromEnv = do-  deployPath     <- getEnv "DEPLOY_PATH"-  host           <- getEnv "HOST"-  repository     <- getEnv "REPOSITORY"-  revision       <- getEnv "REVISION"+  deployPath     <- getEnv    "DEPLOY_PATH"+  repository     <- getEnv    "REPOSITORY"+  revision       <- getEnv    "REVISION"++  host           <- lookupEnv "HOST"   buildScript    <- lookupEnv "BUILD_SCRIPT"   restartCommand <- lookupEnv "RESTART_COMMAND" -  return Hap.Config { Hap._deployPath     = deployPath-                    , Hap._host           = host-                    , Hap._repository     = repository-                    , Hap._revision       = revision-                    , Hap._buildScript    = buildScript-                    , Hap._restartCommand = restartCommand++  return Hap.Config { Hap.deployPath     = deployPath+                    , Hap.host           = host+                    , Hap.releaseFormat  = Short+                    , Hap.repository     = repository+                    , Hap.revision       = revision+                    , Hap.buildScript    = buildScript+                    , Hap.restartCommand = restartCommand                     }  main :: IO ()

@@ -0,0 +1,401 @@+{-# LANGUAGE OverloadedStrings #-}++-- | A module for easily creating reliable deploy processes for Haskell+-- applications.+module System.Hapistrano+       ( Config(..)++       , activateRelease+       , currentPath+       , 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)+import Data.List (intercalate, sortBy, isInfixOf)+import Data.Time (getCurrentTime)+import Data.Time.Format (formatTime)+import System.FilePath.Posix (joinPath, splitPath)+import System.IO (hPutStrLn, stderr)+import System.Locale (defaultTimeLocale)+import System.Process (readProcessWithExitCode)++-- | 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++-- | 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++-- | 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++-- | 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)++-- | Default method to run on deploy success.+defaultSuccessHandler :: a -> ReaderT Config IO ()+defaultSuccessHandler _ =+  liftIO $ putStrLn "Deploy completed successfully."+++-- | 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++  mapM_ (runCommand (host conf))+    ["mkdir -p " ++ releasesPath conf, "mkdir -p " ++ cacheRepoPath conf]++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])++  (code, _, _) <- readProcessWithExitCode command args ""++  return $ case code of+    ExitSuccess   -> True+    ExitFailure _ -> False++-- | Runs the given command either locally or on the local machine.+runCommand :: Maybe String -- ^ The host on which to run the command+           -> String -- ^ The command to run, either on the local or remote host+           -> Hapistrano String++runCommand Nothing command = execCommand command+runCommand (Just server) command =+  execCommand $ unwords ["ssh", server, command]+++execCommand :: String -> Hapistrano String+execCommand cmd = do+  let wds         = words cmd+      (cmd', args) = (head wds, tail wds)++  liftIO $ putStrLn $ "Executing: " ++ cmd++  (code, stdout, err) <- liftIO $ readProcessWithExitCode cmd' args ""++  case code of+    ExitSuccess -> do+      unless (null stdout) (liftIO $ putStrLn $ "Output: " ++ stdout)++      right $ trim stdout++    ExitFailure int -> left (int, trim err)++-- | Returns a timestamp in the default format for build directories.+currentTimestamp :: ReleaseFormat -> IO String+currentTimestamp format = do+  curTime <- getCurrentTime+  return $ formatTime defaultTimeLocale fstring curTime++  where fstring = case format of+          Short -> "%Y%m%d%H%M%S"+          Long  -> "%Y%m%d%H%M%S%q"++-- | 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) $ "readlink " ++ currentPath (deployPath conf)++-- ^ Trims any newlines from the given String+trim :: String -- ^ String to have trailing newlines stripped+     -> String -- ^ String with trailing newlines removed+trim = reverse . dropWhile (== '\n') . reverse++-- | 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"]++  if res+    then right "Repo already existed"+    else createCacheRepo++-- | Returns the full path of the folder containing all of the release builds.+releasesPath :: Config -> FilePath+releasesPath conf = joinPath [deployPath conf, "releases"]++-- | 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++-- | 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) $ "git clone " ++ cacheRepoPath conf +++    " " ++ joinPath [ releasesPath conf, rls ]++  return rls+++-- | Returns 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"]++-- | 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++-- | 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) $ "find " ++ releasesPath conf +++          " -type d -maxdepth 1"++  right $+    filter (isReleaseString (releaseFormat conf)) . map pathToRelease $+    lines res++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) $ "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) $ "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) $ "rm -rf " ++ currentSymlinkPath conf++-- | Determines whether the target host OS is Linux+targetIsLinux :: Hapistrano Bool+targetIsLinux = do+  conf <- ask+  res <- runCommand (host 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) cmd++-- | 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 $ 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) tmpLnCmd++  runCommand (host 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) $ 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) $ 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) $ 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

@@ -0,0 +1,49 @@+module System.Hapistrano.Types+       ( Config(..)+       , FailureResult+       , Hapistrano+       , Release+       , ReleaseFormat(..)+       ) where++import Control.Monad.Reader (ReaderT(..))+import Control.Monad.Trans.Either (EitherT(..))++-- | 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++         , repository     :: String -- ^ The remote git repo+         , revision       :: String -- ^ A SHA1 or branch to release++         , 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++         , buildScript    :: Maybe FilePath+           -- ^ The local path to a file that should be executed on the remote+           -- server to build the application.++         , restartCommand :: Maybe String+           -- ^ Optional command to restart the server after a successful deploy++         } deriving (Show)++data ReleaseFormat = Short+                     -- ^ Standard release path following Capistrano's format++                   | Long+                     -- ^ Long release path including picoseconds for testing+                     -- or people seriously into continuous deployment++                   deriving (Show)+++type Release = String++type FailureResult = (Int, String)++type Hapistrano a = EitherT FailureResult (ReaderT Config IO) a