More cleanup

hapistrano.cabal

@@ -3,19 +3,29 @@ version:             0.2.0.0
 synopsis:            A deployment library for Haskell applications
 description:
   .
-  Hapistrano makes it easy to reliably deploy Haskell applications.
+  Hapistrano makes it easy to reliably deploy Haskell applications
+  to a server.
   .
-  Following popular libraries like Ruby's <http://capistranorb.com/ Capistrano>,
-  Hapistrano simply creates a new sandbox, installs dependencies, builds, and
-  then symlinks to the new build directory when installation is done.
+  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.
   .
-  This process makes deploy atomic, without allowing for dependency problems.
 license:             MIT
 license-file:        LICENSE
 author:              Justin Leitgeb
 maintainer:          justin@stackbuilders.com
 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
 

spec/System/HapistranoSpec.hs

@@ -6,6 +6,10 @@ 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)
 
 import qualified System.Hapistrano as Hap
@@ -89,6 +93,12 @@ defaultState tmpDir testRepo =
              , Hap.restartCommand = 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
+
 spec :: Spec
 spec = describe "hapistrano" $ do
   describe "readCurrentLink" $
@@ -99,9 +109,11 @@ spec = describe "hapistrano" $ do
 
         deployAndActivate $ defaultState tmpDir testRepoPath
 
-        ltarget <- Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
+        ltarget <-
+          runReaderT (runEitherT Hap.readCurrentLink) $
+          defaultState tmpDir testRepoPath
 
-        last ltarget /= '\n' `shouldBe` True
+        last (fromRight ltarget) /= '\n' `shouldBe` True
 
   describe "deploying" $ do
     it "a simple deploy" $
@@ -148,10 +160,9 @@ spec = describe "hapistrano" $ do
         let firstRelease = head $ filter (Hap.isReleaseString Long) contents
 
         firstReleaseLinkTarget <-
-          Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
+          runReaderT (runEitherT Hap.readCurrentLink) deployState
 
-        putStrLn $ "the first: " ++ show firstReleaseLinkTarget
-        firstRelease `shouldBe` Hap.pathToRelease firstReleaseLinkTarget
+        firstRelease `shouldBe` Hap.pathToRelease (fromRight firstReleaseLinkTarget)
 
         -- deploy a second version
         deployAndActivate deployState
@@ -164,15 +175,15 @@ spec = describe "hapistrano" $ do
               sort (filter (Hap.isReleaseString Long) conts) !! 1
 
         secondReleaseLinkTarget <-
-          Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
+          runReaderT (runEitherT Hap.readCurrentLink) deployState
 
-        secondRelease `shouldBe` Hap.pathToRelease secondReleaseLinkTarget
+        secondRelease `shouldBe` Hap.pathToRelease (fromRight secondReleaseLinkTarget)
 
         -- roll back, and current symlink should point to first release again
 
         rollback deployState
 
         afterRollbackLinkTarget <-
-          Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
+          runReaderT (runEitherT Hap.readCurrentLink) deployState
 
-        Hap.pathToRelease afterRollbackLinkTarget `shouldBe` firstRelease
+        Hap.pathToRelease (fromRight afterRollbackLinkTarget) `shouldBe` firstRelease

src/System/Hapistrano.hs

@@ -23,6 +23,7 @@ module System.Hapistrano
 
 import Control.Monad.Reader (ReaderT(..), ask)
 
+
 import System.Hapistrano.Types
   (Config(..), FailureResult, Hapistrano, Release, ReleaseFormat(..))
 
@@ -52,12 +53,10 @@ pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
 
 -- | Switches the current symlink to point to the release specified in
 -- the configuration. Maybe used in either deploy or rollback cases.
-activateRelease :: Release -> Hapistrano (Maybe String)
+activateRelease :: Release -> Hapistrano String
 activateRelease rel = removeCurrentSymlink >> symlinkCurrent rel
 
--- | 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.
+-- | 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
@@ -105,14 +104,14 @@ directoryExists hst path = do
 -- | 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 (Maybe String)
+           -> Hapistrano String
 
 runCommand Nothing command = execCommand command
 runCommand (Just server) command =
   execCommand $ unwords ["ssh", server, command]
 
 
-execCommand :: String -> Hapistrano (Maybe String)
+execCommand :: String -> Hapistrano String
 execCommand cmd = do
   let wds         = words cmd
       (cmd', args) = (head wds, tail wds)
@@ -125,7 +124,7 @@ execCommand cmd = do
     ExitSuccess -> do
       unless (null stdout) (liftIO $ putStrLn $ "Output: " ++ stdout)
 
-      right $ maybeString stdout
+      right $ trim stdout
 
     ExitFailure int -> left (int, trim err)
 
@@ -139,65 +138,48 @@ currentTimestamp format = do
           Short -> "%Y%m%d%H%M%S"
           Long  -> "%Y%m%d%H%M%S%q"
 
-echoMessage :: String -> Hapistrano (Maybe String)
-echoMessage msg = do
-  liftIO $ putStrLn msg
-  right Nothing
-
 -- | Returns the FilePath pointed to by the current symlink.
-readCurrentLink :: Maybe String -> FilePath -> IO FilePath
-readCurrentLink hst path = do
-  let (command, args) = case hst of
-        Just h  -> ("ssh", [h, "readlink", path])
-        Nothing -> ("readlink", [path])
+readCurrentLink :: Hapistrano FilePath -- ^ The target of the symlink in the Hapistrano monad
+readCurrentLink = do
+  conf <- ask
+  runCommand (host conf) $ "readlink " ++ currentPath (deployPath conf)
 
-  (code, stdout, _) <- readProcessWithExitCode command args ""
-
-  case (code, stdout) of
-    (ExitSuccess, out) -> return $ trim out
-    (ExitFailure _, _) -> error "Unable to read current symlink"
-
-
-trim :: String -> String
-trim = reverse . dropWhile (=='\n') . reverse
+-- ^ 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 (Maybe String)
+ensureRepositoryPushed :: Hapistrano String
 ensureRepositoryPushed = do
   conf <- ask
   res  <-
     liftIO $ directoryExists (host conf) $ joinPath [cacheRepoPath conf, "refs"]
 
   if res
-    then right $ Just "Repo already existed"
+    then right "Repo already existed"
     else createCacheRepo
 
--- | 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 [deployPath conf, "releases"]
 
 -- | Figures out the most recent release if possible.
 detectPrevious :: [String] -- ^ The releases in `releases` path
-               -> Hapistrano String
+               -> 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 (Maybe String)
+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
+cloneToRelease :: Hapistrano Release -- ^ The newly-cloned Release, in the Hapistrano monad
 cloneToRelease = do
   conf <- ask
   rls  <- liftIO $ currentTimestamp (releaseFormat conf)
@@ -210,38 +192,35 @@ cloneToRelease = do
 
 -- | Returns the full path to the git repo used for cache purposes on the
 -- target host filesystem.
-cacheRepoPath :: Config -> FilePath
+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 -> FilePath
+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 -> Release
+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]
+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"
 
-  case res of
-    Nothing -> right []
-    Just s ->
-      right $
-      filter (isReleaseString (releaseFormat conf)) . map pathToRelease $
-      lines s
+  right $
+    filter (isReleaseString (releaseFormat conf)) . map pathToRelease $
+    lines res
 
-previousReleases :: Hapistrano [Release]
+previousReleases :: Hapistrano [Release] -- ^ All non-current releases on the target host
 previousReleases = do
-  rls <- releases
-  conf <- ask
-
-  currentRelease <-
-    liftIO $ readCurrentLink (host conf) (currentPath (deployPath conf))
+  rls            <- releases
+  currentRelease <- readCurrentLink
 
   let currentRel = (head . lines . pathToRelease) currentRelease
   return $ filter (< currentRel) rls
@@ -260,7 +239,7 @@ oldReleases conf rs = map mergePath toDelete
 
 -- | Removes releases older than the last five to avoid filling up the target
 -- host filesystem.
-cleanReleases :: Hapistrano (Maybe String)
+cleanReleases :: Hapistrano [String]
 cleanReleases = do
   conf        <- ask
   allReleases <- releases
@@ -268,12 +247,13 @@ cleanReleases = do
   let deletable = oldReleases conf allReleases
 
   if null deletable
-    then
-      echoMessage "There are no old releases to prune."
+    then do
+      liftIO $ putStrLn "There are no old releases to prune."
+      return []
 
-    else
-      runCommand (host conf) $
-      "rm -rf -- " ++ unwords deletable
+    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.
@@ -285,7 +265,7 @@ isReleaseString format s = all isNumber s && length s == releaseLength
 
 -- | Creates the git repository that is used on the target host for
 -- cache purposes.
-createCacheRepo :: Hapistrano (Maybe String)
+createCacheRepo :: Hapistrano String
 createCacheRepo = do
   conf <- ask
 
@@ -314,17 +294,15 @@ targetIsLinux = do
   conf <- ask
   res <- runCommand (host conf) "uname"
 
-  case res of
-    Just output -> right $ "Linux" `isInfixOf` output
-    _ -> left (1, "Unable to determine remote host type")
+  right $ "Linux" `isInfixOf` res
 
 -- | Runs a command to restart a server if a command is provided.
-restartServerCommand :: Hapistrano (Maybe String)
+restartServerCommand :: Hapistrano String
 restartServerCommand = do
   conf <- ask
 
   case restartCommand conf of
-    Nothing -> return $ Just "No command given for restart action."
+    Nothing -> return "No command given for restart action."
     Just cmd -> runCommand (host conf) cmd
 
 -- | Runs a build script if one is provided.
@@ -358,7 +336,7 @@ 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 (Maybe String)
+symlinkCurrent :: Release -> Hapistrano String
 symlinkCurrent rel = do
   conf <- ask