Merge pull request #10 from stackbuilders/rollback

Implement rollback function

BuildTest.hs

@@ -10,15 +10,19 @@ testConfig = Hap.Config { Hap._deployPath = "/tmp/project"
                         , Hap._revision    = "origin/transformer-refactor"
                         }
 
-main :: IO ()
+rollback :: IO ()
-main = do
+rollback = do
-  initState <- Hap.initialState testConfig
+  Hap.runRC errorHandler successHandler (Hap.initialState testConfig) $
-
+    void Hap.rollback
-  Hap.runRC errorHandler successHandler initState $
+
-    do
+  where
-      Hap.pushRelease
+    errorHandler   = Hap.defaultErrorHandler
-      Hap.defaultBuildRelease
+    successHandler = Hap.defaultSuccessHandler
-      void Hap.activateRelease
+
+main :: IO ()
+main = do
+  Hap.runRC errorHandler successHandler (Hap.initialState testConfig) $
+    void (Hap.pushRelease >> Hap.defaultBuildRelease >> Hap.activateRelease)
 
   where
     errorHandler   = Hap.defaultErrorHandler

src/Hapistrano.hs

@@ -8,18 +8,19 @@ module Hapistrano
          Config(..)
        , initialState
        , runRC
-       , pushRelease
+
        , activateRelease
        , defaultBuildRelease
        , defaultSuccessHandler
        , defaultErrorHandler
-       , currentTimestamp
+       , pushRelease
+       , rollback
        ) where
 
-import Control.Lens (makeLenses, use, (^.))
+import Control.Lens (makeLenses, use, (^.), (.=))
 import Control.Monad (unless)
 import Control.Monad.IO.Class (MonadIO(liftIO))
-import Control.Monad.Trans.State (StateT, evalStateT, runStateT, get)
+import Control.Monad.Trans.State (StateT, evalStateT, get)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Either ( EitherT(..)
                                   , left
@@ -27,11 +28,11 @@ import Control.Monad.Trans.Either ( EitherT(..)
                                   , runEitherT
                                   , eitherT )
 import Data.Char (isNumber)
-import Data.List (intercalate, sortBy)
+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)
+import System.FilePath.Posix (joinPath, splitPath)
 import System.IO (hPutStrLn, stderr)
 import System.Locale (defaultTimeLocale)
 import System.Process (readProcessWithExitCode)
@@ -47,19 +48,20 @@ makeLenses ''Config
 
 
 data HapistranoState = HapistranoState { _config    :: Config
-                                       , _timestamp :: String
+                                       , _timestamp :: Maybe String
                                        }
 makeLenses ''HapistranoState
 
+type Release = String
 
 type RC a = StateT HapistranoState (EitherT (Int, Maybe String) IO) a
 
-initialState :: Config -> IO HapistranoState
+-- | Returns an initial state for the deploy.
-initialState cfg = do
+initialState :: Config -> HapistranoState
-  ts <- currentTimestamp
+initialState cfg = HapistranoState { _config    = cfg
-  return HapistranoState { _config    = cfg
+                                   , _timestamp = Nothing
-                         , _timestamp = ts
+                                   }
-                         }
+
 -- | 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.
@@ -68,10 +70,10 @@ runRC :: ((Int, Maybe String) -> IO a) -- ^ Error handler
       -> HapistranoState               -- ^ Initial state
       -> RC a
       -> IO a
-runRC errorHandler successHandler initState remoteCommand  =
+runRC errorHandler successHandler initState remoteCmd =
     eitherT errorHandler
             successHandler
-            (evalStateT remoteCommand initState)
+            (evalStateT remoteCmd initState)
 
 defaultErrorHandler :: (Int, Maybe String) -> IO ()
 defaultErrorHandler _ = putStrLn "Deploy failed."
@@ -88,7 +90,7 @@ setupDirs = do
   remoteCommand $ "mkdir -p " ++ joinPath [pathName, "releases"]
 
 remoteCommand :: String -- ^ The command to run remotely
-        -> RC (Maybe String)
+              -> RC (Maybe String)
 remoteCommand command = do
   server <- use $ config . host
   liftIO $ putStrLn $ "Going to execute " ++ command ++ " on host " ++ server
@@ -135,17 +137,21 @@ 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
-  st <- get
   conf <- use config
-  let e = runStateT (directoryExists (cacheRepoPath conf)) st
+  res <- directoryExists $ cacheRepoPath conf
-  res <- liftIO $ runEitherT e
 
   case res of
-    Left _ -> createCacheRepo
+    Nothing -> createCacheRepo
-    Right _ -> lift $ right $ Just "Repo already existed"
+    Just _ -> lift $ right $ Just "Repo already existed"
 
 -- | Returns a Just String or Nothing based on whether the input is null or
 -- has contents.
@@ -157,42 +163,84 @@ maybeString possibleString =
 releasesPath :: Config -> FilePath
 releasesPath conf = joinPath [(conf ^. deployPath), "releases"]
 
--- | Clones the repository to the next releasePath timestamp.
+-- | 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
-  remoteCommand $
+
-    "git clone " ++ cacheRepoPath conf ++ " " ++ joinPath [releasesPath conf, releaseTimestamp]
+  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 [String]
+releases :: RC [Release]
 releases = do
-  st  <- get
   conf <- use config
-  res    <- liftIO $ runEitherT
+  res  <- remoteCommand $ "find " ++ releasesPath conf ++ " -type d -maxdepth 1"
-            (evalStateT (remoteCommand ("find " ++ releasesPath conf ++
-                                  " -type d -maxdepth 1")) st)
 
   case res of
-    Left r -> lift $ left r
+    Nothing -> lift $ right []
-    Right Nothing -> lift $ right []
+    Just s ->
-    Right (Just s) ->
+      lift $ right $ filter isReleaseString . map pathToRelease
-      lift $ right $ filter isReleaseString . map (reverse . take 14 . reverse)
       $ lines s
 
--- | Given a list of release strings, takes the last five in the sequence.
+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
+
+-- | 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 -> [String] -> [FilePath]
+oldReleases :: Config -> [Release] -> [FilePath]
 oldReleases conf rs = map mergePath toDelete
   where sorted             = sortBy (flip compare) rs
-        toDelete           = drop 5 sorted
+        toDelete           = drop 4 sorted
         mergePath fileName = joinPath [releasesPath conf, fileName]
 
 -- | Removes releases older than the last five to avoid filling up the target
@@ -209,7 +257,7 @@ cleanReleases = do
     Right xs -> do
       let deletable = oldReleases conf xs
 
-      remoteCommand $ "rm -rf --" ++ foldr (\a b -> a ++ " " ++ b) ""
+      remoteCommand $ "rm -rf -- " ++ foldr (\a b -> a ++ " " ++ b) ""
         deletable
 
 -- | Returns a Bool indicating if the given String is in the proper release
@@ -230,6 +278,9 @@ createCacheRepo = do
 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)
@@ -237,19 +288,39 @@ 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 <- liftIO $ runEitherT $ evalStateT (remoteCommand "uname") st
+
+  case res of
+    Right (Just output) -> lift $ right $ "Linux" `isInfixOf` output
+    _ -> lift $ left (1, Just "Unable to determine remote host type")
+
+-- | 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
-  st <- get
   conf <- use config
-  allReleases <- liftIO . runEitherT $ evalStateT releases st
+  releaseTimestamp <- use timestamp
 
-  case allReleases of
+  case releaseTimestamp of
-    Left err -> lift $ left err
+    Nothing  -> lift $ left (1, Just "No releases to symlink!")
-    Right [] -> lift $ left (1, Just "No releases to symlink!")
+    Just rls -> do
-    Right rls -> do
+      isLnx <- remoteIsLinux
-      let latest = joinPath [releasesPath conf, maximum rls]
+
-      remoteCommand $ "ln -s " ++  latest ++ " " ++ currentSymlinkPath conf
+      remoteCommand $ "ln -s " ++ 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)
@@ -268,30 +339,37 @@ defaultBuildRelease :: RC (Maybe String)
 defaultBuildRelease  = do
   conf <- use config
   releaseTimestamp <- use timestamp
-  remoteCommand $ intercalate " && "
+  case releaseTimestamp of
-              [ "cd " ++ joinPath [releasesPath conf, releaseTimestamp]
+    Nothing -> lift $ left (1, Just "No releases to symlink!")
-              , "export PATH=~/.cabal/bin:/usr/local/bin:$PATH"
+    Just rls ->
-              , "git fetch --all"
+      remoteCommand $ intercalate " && "
-              , "git reset --hard " ++ conf ^. revision
+      [ "cd " ++ joinPath [releasesPath conf, rls]
-              , "rm -rf .cabal-sandbox"
+      , "export PATH=~/.cabal/bin:/usr/local/bin:$PATH"
-              , "cabal sandbox init"
+      , "git fetch --all"
-              , "cabal clean"
+      , "git reset --hard " ++ conf ^. revision
-              , "cabal update"
+      , "rm -rf .cabal-sandbox"
-              , "cabal install --only-dependencies -j"
+      , "cabal sandbox init"
-              , "cabal build -j" ]
+      , "cabal clean"
+      , "cabal update"
+      , "cabal install --only-dependencies -j"
+      , "cabal build -j"
+      ]
+
+-- | A safe version of the `maximum` function in Data.List.
+biggest :: Ord a => [a] -> Maybe a
+biggest rls =
+  case (reverse . sort) rls of
+    []  -> Nothing
+    r:_ -> Just r
 
 -- | 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 = do
+pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
-  setupDirs
+              cleanReleases >> cloneToRelease
-  ensureRepositoryPushed
-  updateCacheRepo
-  cleanReleases
-  cloneToRelease
 
 -- | Switches the current symlink to point to the release specified in
--- the configuration.
+-- the configuration. Maybe used in either deploy or rollback cases.
 activateRelease :: RC (Maybe String)
 activateRelease = removeCurrentSymlink >> symlinkCurrent