Refactoring and test additions

hapistrano.cabal

@@ -1,9 +1,15 @@
 name:                hapistrano
 version:             0.1.0.2
 synopsis:            A deployment library for Haskell applications
-description:         Hapistrano makes it easy to reliably deploy Haskell
+description:
-                     applications.
+  .
-
+  Hapistrano makes it easy to reliably deploy Haskell applications.
+  .
+  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.
+  .
+  This process makes deploy atomic, without allowing for dependency problems.
 license:             MIT
 license-file:        LICENSE
 author:              Justin Leitgeb
@@ -22,28 +28,52 @@ executable hap
                        , process
                        , either
                        , transformers
-                       , lens >= 4.1
+                       , mtl
                        , filepath
-                       , either
                        , base-compat
 
   default-language:    Haskell2010
+  ghc-options:         -Wall
 
 library
-  exposed-modules:     Hapistrano
+  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

spec/Spec.hs

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

spec/System/HapistranoSpec.hs

@@ -0,0 +1,141 @@
+module System.HapistranoSpec (spec) where
+
+import Test.Hspec (it, describe, shouldBe, Spec)
+
+import System.IO.Temp (withSystemTempDirectory)
+
+import System.Directory (getDirectoryContents)
+import Control.Monad (void, replicateM_)
+import System.FilePath.Posix (joinPath)
+
+import qualified System.Hapistrano as Hap
+import System.Hapistrano.Types
+import Data.List (sort)
+
+rollback :: HapistranoState -> 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 :: HapistranoState -> 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 :: HapistranoState -> IO ()
+deployAndActivate cfg =
+  Hap.runRC errorHandler successHandler cfg $ do
+    _ <- Hap.pushRelease
+    _ <- Hap.runBuild
+
+    void Hap.activateRelease
+
+  where
+    errorHandler   = Hap.defaultErrorHandler
+    successHandler = Hap.defaultSuccessHandler
+
+defaultState :: FilePath -> HapistranoState
+defaultState tmpDir = Hap.initialState
+               Hap.Config { Hap.deployPath     = tmpDir
+                          , Hap.host           = Nothing
+                          , Hap.repository     =
+                            "https://github.com/stackbuilders/atomic-write.git"
+
+                          , Hap.releaseFormat  = Long
+                          , Hap.revision       = "master"
+                          , Hap.buildScript    = Nothing
+                          , Hap.restartCommand = Nothing
+                          }
+
+spec :: Spec
+spec = describe "hapistrano" $ do
+  describe "readCurrentLink" $
+    it "trims trailing whitespace" $
+      withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
+
+        deployAndActivate (defaultState tmpDir)
+
+        ltarget <- Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
+
+        last ltarget /= '\n' `shouldBe` True
+
+  describe "deploying" $ do
+    it "a simple deploy" $
+      withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
+
+        deployOnly (defaultState tmpDir)
+
+        contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
+        length (filter (Hap.isReleaseString Long) contents) `shouldBe` 1
+
+    it "activates the release" $
+      withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
+
+        deployAndActivate (defaultState tmpDir)
+
+        contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
+        length (filter (Hap.isReleaseString Long) contents) `shouldBe` 1
+
+    it "cleans up old releases" $
+      withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
+
+        replicateM_ 7 $ deployAndActivate (defaultState tmpDir)
+
+        contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
+        length (filter (Hap.isReleaseString Long) contents) `shouldBe` 5
+
+  describe "rollback" $
+    it "rolls back to the previous release" $
+      withSystemTempDirectory "hapistranoDeployTest" $ \tmpDir -> do
+
+        let deployState = defaultState tmpDir
+
+        deployAndActivate deployState
+
+        -- current symlink should point to the last release directory
+        contents <- getDirectoryContents (joinPath [tmpDir, "releases"])
+
+        let firstRelease = head $ filter (Hap.isReleaseString Long) contents
+
+        firstReleaseLinkTarget <-
+          Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
+
+        putStrLn $ "the first: " ++ show firstReleaseLinkTarget
+        firstRelease `shouldBe` Hap.pathToRelease 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 Long) conts) !! 1
+
+        secondReleaseLinkTarget <-
+          Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
+
+        secondRelease `shouldBe` Hap.pathToRelease secondReleaseLinkTarget
+
+        -- roll back, and current symlink should point to first release again
+
+
+        rollback deployState
+
+        afterRollbackLinkTarget <-
+          Hap.readCurrentLink Nothing (Hap.currentPath tmpDir)
+
+        Hap.pathToRelease afterRollbackLinkTarget `shouldBe` firstRelease

src/System/Hapistrano.hs

@@ -1,70 +1,55 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
 
 -- | A module for easily creating reliable deploy processes for Haskell
 -- applications.
-module Hapistrano
+module System.Hapistrano
-       (
+       ( Config(..)
-         Config(..)
-       , initialState
-       , runRC
 
        , activateRelease
-       , runBuild
+       , currentPath
        , defaultSuccessHandler
        , defaultErrorHandler
+       , directoryExists
+       , initialState
+       , isReleaseString
+       , pathToRelease
        , pushRelease
+       , readCurrentLink
        , restartServerCommand
        , rollback
+       , runRC
+       , runBuild
+
        ) where
 
-import Control.Lens (makeLenses, use, (^.), (.=))
+import System.Hapistrano.Types (
-import Control.Monad (unless)
+  Config(..), HapistranoState(..), RC, Release, ReleaseFormat(..))
+
+import Control.Monad (unless, void)
 import System.Exit (ExitCode(..), exitWith)
 
+import Control.Monad.State.Lazy (gets, put)
+
 import Control.Monad.IO.Class (MonadIO(liftIO))
-import Control.Monad.Trans.State (StateT, evalStateT, get)
+import Control.Monad.Trans.State (evalStateT, get)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Either ( EitherT(..)
+import Control.Monad.Trans.Either ( left
-                                  , left
                                   , right
-                                  , runEitherT
                                   , eitherT )
+
 import Data.Char (isNumber)
-import Data.List (intercalate, sortBy, sort, isInfixOf)
+import Data.List (intercalate, sortBy, 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 :: RC ()
 pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
               cleanReleases >> cloneToRelease >> setReleaseRevision
 
@@ -73,11 +58,10 @@ pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
 activateRelease :: RC (Maybe String)
 activateRelease = removeCurrentSymlink >> symlinkCurrent
 
-
 -- | Returns an initial state for the deploy.
 initialState :: Config -> HapistranoState
-initialState cfg = HapistranoState { _config    = cfg
+initialState cfg = HapistranoState { config    = cfg
-                                   , _timestamp = Nothing
+                                   , timestamp = Nothing
                                    }
 
 -- | Given a pair of actions, one to perform in case of failure, and
@@ -93,10 +77,13 @@ runRC errorHandler successHandler initState remoteCmd =
             successHandler
             (evalStateT remoteCmd initState)
 
+-- | Default method to run on deploy failure. Emits a failure message
+-- and exits with a status code of 1.
 defaultErrorHandler :: (Int, Maybe String) -> IO ()
 defaultErrorHandler _ =
   hPutStrLn stderr "Deploy failed." >> exitWith (ExitFailure 1)
 
+-- | Default method to run on deploy success.
 defaultSuccessHandler :: a -> IO ()
 defaultSuccessHandler _ = putStrLn "Deploy completed successfully."
 
@@ -104,19 +91,52 @@ 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 :: RC ()
 setupDirs = do
-  conf <- use config
+  conf <- gets config
 
-  remoteCommand $ intercalate " && "
+  mapM_ (runCommand (host conf))
-    [ "mkdir -p " ++ releasesPath conf
+    ["mkdir -p " ++ releasesPath conf, "mkdir -p " ++ cacheRepoPath conf]
-    , "mkdir -p " ++ cacheRepoPath conf
-    ]
 
-remoteCommand :: String -- ^ The command to run remotely
+directoryExists :: Maybe String -> FilePath -> IO Bool
-              -> RC (Maybe String)
+directoryExists hst path = do
-remoteCommand command = do
+  let (command, args) = case hst of
-  server <- use $ config . host
+        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
+           -> RC (Maybe String)
+
+runCommand Nothing command = do
+  liftIO $ putStrLn $ "Going to execute " ++ command ++ " locally."
+
+  let (cmd, args) = (head (words command), tail (words command))
+
+  (code, stdout, err) <- liftIO $ readProcessWithExitCode cmd args ""
+
+  case code of
+    ExitSuccess -> do
+      liftIO $
+        putStrLn $ "Command '" ++ command ++ "' was successful on local host."
+
+      unless (null stdout) (liftIO $ putStrLn $ "Output:\n" ++ stdout)
+
+      lift $ right $ maybeString stdout
+
+    ExitFailure int -> do
+      let maybeError = maybeString err
+      liftIO $ printCommandError "localhost" command (int, maybeError)
+      lift $ left (int, maybeError)
+
+runCommand (Just server) command = do
   liftIO $ putStrLn $ "Going to execute " ++ command ++ " on host " ++ server
            ++ "."
 
@@ -137,11 +157,16 @@ remoteCommand command = do
       liftIO $ printCommandError server command (int, maybeError)
       lift $ left (int, maybeError)
 
+
 -- | Returns a timestamp in the default format for build directories.
-currentTimestamp :: IO String
+currentTimestamp :: ReleaseFormat -> IO String
-currentTimestamp = do
+currentTimestamp format = do
   curTime <- getCurrentTime
-  return $ formatTime defaultTimeLocale "%Y%m%d%H%M%S" curTime
+  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"
 
 echoMessage :: String -> RC (Maybe String)
 echoMessage msg = do
@@ -157,25 +182,30 @@ printCommandError server cmd (errCode, Just errMsg) =
   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 :: Maybe String -> FilePath -> IO FilePath
-readCurrentLink = do
+readCurrentLink hst path = do
-  conf <- use config
+  let (command, args) = case hst of
-  remoteCommand $ "readlink " ++ currentPath conf
+        Just h  -> ("ssh", [h, "readlink", path])
+        Nothing -> ("readlink", [path])
+
+  (code, stdout, _) <- readProcessWithExitCode command args ""
+
+  case (code, stdout) of
+    (ExitSuccess, out) -> return $ trim out
+    (ExitFailure _, _) -> error "Unable to read current symlink"
+
+  where trim = reverse . dropWhile (=='\n') . reverse
 
 -- | Ensure that the initial bare repo exists in the repo directory. Idempotent.
 ensureRepositoryPushed :: RC (Maybe String)
 ensureRepositoryPushed = do
-  conf <- use config
+  conf <- gets config
-  res <- directoryExists $ cacheRepoPath conf
+  res  <- liftIO $ directoryExists (host conf) $ joinPath [cacheRepoPath conf, "refs"]
 
-  case res of
+  if res
-    Nothing -> createCacheRepo
+    then lift $ right $ Just "Repo already existed"
-    Just _ -> lift $ right $ Just "Repo already existed"
+    else createCacheRepo
 
 -- | Returns a Just String or Nothing based on whether the input is null or
 -- has contents.
@@ -185,7 +215,7 @@ maybeString possibleString =
 
 -- | Returns the full path of the folder containing all of the release builds.
 releasesPath :: Config -> FilePath
-releasesPath conf = joinPath [conf ^. deployPath, "releases"]
+releasesPath conf = joinPath [deployPath conf, "releases"]
 
 -- | Figures out the most recent release if possible, and sets the
 -- StateT monad with the correct timestamp. This function is used
@@ -193,10 +223,12 @@ releasesPath conf = joinPath [conf ^. deployPath, "releases"]
 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
+      conf <- get
+      _ <- put $ conf { timestamp = mostRecentRls }
       lift $ right $ Just rls
 
 -- | Activates the previous detected release.
@@ -207,29 +239,29 @@ rollback = previousReleases >>= detectPrevious >> activateRelease
 -- timestamp if one doesn't yet exist in the HapistranoState.
 cloneToRelease :: RC (Maybe String)
 cloneToRelease = do
-  conf <- use config
+  hs <- get
-  releaseTimestamp <- use timestamp
+  conf <- gets config
 
-  rls <- case releaseTimestamp of
+  rls <- case timestamp hs of
            Nothing -> do
-             ts <- liftIO currentTimestamp
+             ts <- liftIO $ currentTimestamp (releaseFormat conf)
-             timestamp .= Just ts
+             _ <- put $ hs { timestamp = Just ts }
              return ts
 
            Just r -> return r
 
-  remoteCommand $ "git clone " ++ cacheRepoPath conf ++ " " ++
+  runCommand (host conf) $ "git clone " ++ cacheRepoPath (config hs) ++
-    joinPath [ releasesPath conf, rls ]
+    " " ++ joinPath [ releasesPath (config hs), 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"]
+cacheRepoPath conf = joinPath [deployPath conf, "repo"]
 
 -- | Returns the full path to the current symlink.
-currentPath :: Config -> FilePath
+currentPath :: FilePath -> FilePath
-currentPath conf = joinPath [conf ^. deployPath, "current"]
+currentPath depPath = joinPath [depPath, "current"]
 
 -- | Take the release timestamp from the end of a filepath.
 pathToRelease :: FilePath -> Release
@@ -238,25 +270,27 @@ pathToRelease = last . splitPath
 -- | Returns a list of Strings representing the currently deployed releases.
 releases :: RC [Release]
 releases = do
-  conf <- use config
+  conf <- gets config
-  res  <- remoteCommand $ "find " ++ releasesPath conf ++ " -type d -maxdepth 1"
+  res  <- runCommand (host conf) $ "find " ++ releasesPath conf ++
+          " -type d -maxdepth 1"
 
   case res of
     Nothing -> lift $ right []
     Just s ->
-      lift $ right $ filter isReleaseString . map pathToRelease
+      lift $ right $
-      $ lines s
+      filter (isReleaseString (releaseFormat conf)) . map pathToRelease $
+      lines s
 
 previousReleases :: RC [Release]
 previousReleases = do
   rls <- releases
-  currentRelease <- readCurrentLink
+  conf <- gets config
 
-  case currentRelease of
+  currentRelease <-
-    Nothing -> lift $ left (1, Just "Bad pointer from current link")
+    liftIO $ readCurrentLink (host conf) (currentPath (deployPath conf))
-    Just c -> do
+
-      let currentRel = (head . lines . pathToRelease) c
+  let currentRel = (head . lines . pathToRelease) currentRelease
-      return $ filter (< currentRel) rls
+  return $ filter (< currentRel) rls
 
 releasePath :: Config -> Release -> FilePath
 releasePath conf rls = joinPath [releasesPath conf, rls]
@@ -274,66 +308,77 @@ oldReleases conf rs = map mergePath toDelete
 -- host filesystem.
 cleanReleases :: RC (Maybe String)
 cleanReleases = do
-  conf <- use config
+  conf        <- gets config
   allReleases <- releases
 
-  case allReleases of
+  let deletable = oldReleases conf allReleases
-    [] -> echoMessage "There are no old releases to prune."
-    xs -> do
-      let deletable = oldReleases conf xs
 
-      remoteCommand $ "rm -rf -- " ++ foldr (\a b -> a ++ " " ++ b) ""
+  if null deletable
-        deletable
+    then
+      echoMessage "There are no old releases to prune."
+
+    else
+      runCommand (host conf) $
+      "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 :: ReleaseFormat -> String -> Bool
-isReleaseString s = all isNumber s && length s == 14
+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 :: RC (Maybe String)
 createCacheRepo = do
-  conf <- use config
+  conf <- gets config
-  remoteCommand $ "git clone --bare " ++ conf ^. repository ++ " " ++
+
+  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 [conf ^. deployPath, "current"]
+currentSymlinkPath conf = joinPath [deployPath conf, "current"]
 
 currentTempSymlinkPath :: Config -> FilePath
-currentTempSymlinkPath conf = joinPath [conf ^. deployPath, "current_tmp"]
+currentTempSymlinkPath conf = joinPath [deployPath conf, "current_tmp"]
 
 -- | Removes the current symlink in preparation for a new release being
 -- activated.
 removeCurrentSymlink :: RC (Maybe String)
 removeCurrentSymlink = do
-  conf <- use config
+  conf <- gets config
-  remoteCommand $ "rm -rf " ++ currentSymlinkPath conf
+
+  runCommand (host conf) $ "rm -rf " ++ currentSymlinkPath conf
 
 -- | Determines whether the target host OS is Linux
-remoteIsLinux :: RC Bool
+targetIsLinux :: RC Bool
-remoteIsLinux = do
+targetIsLinux = do
-  st <- get
+  conf <- gets config
-  res <- remoteCommand "uname"
+  res <- runCommand (host conf) "uname"
 
   case res of
     Just output -> lift $ right $ "Linux" `isInfixOf` output
     _ -> lift $ left (1, Just "Unable to determine remote host type")
 
+-- | Runs a command to restart a server if a command is provided.
 restartServerCommand :: RC (Maybe String)
 restartServerCommand = do
-  conf <- use config
+  conf <- gets config
-  case conf ^. restartCommand of
-    Nothing -> return $ Just "No command given for restart action."
-    Just cmd -> remoteCommand cmd
 
+  case restartCommand conf of
+    Nothing -> return $ Just "No command given for restart action."
+    Just cmd -> runCommand (host conf) cmd
+
+-- | Runs a build script if one is provided.
 runBuild :: RC (Maybe String)
 runBuild = do
-  conf <- use config
+  conf <- gets config
-  case conf ^. buildScript of
+
+  case buildScript conf of
     Nothing -> do
       liftIO $ putStrLn "No build script specified, skipping build step."
       return Nothing
@@ -344,51 +389,65 @@ runBuild = do
       buildRelease commands
 
 -- | Returns the best 'mv' command for a symlink given the target platform.
-mvCommand ::
+mvCommand :: Bool   -- ^ Whether the target host is Linux
-  Bool -- ^ Whether the target host is Linux
+          -> String -- ^ The best mv command for a symlink on the platform
-  -> 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 :: RC (Maybe String)
 symlinkCurrent = do
-  conf <- use config
+  conf             <- gets config
-  releaseTimestamp <- use timestamp
+  releaseTimestamp <- gets timestamp
 
   case releaseTimestamp of
     Nothing  -> lift $ left (1, Just "No releases to symlink!")
     Just rls -> do
-      isLnx <- remoteIsLinux
+      isLnx <- targetIsLinux
+
+      let tmpLnCmd =
+            lnCommand (releasePath conf rls) (currentTempSymlinkPath conf)
+
+      _ <- runCommand (host conf) $ tmpLnCmd
+
+      runCommand (host conf) $ unwords [ mvCommand isLnx
+                                       , currentTempSymlinkPath conf
+                                       , currentSymlinkPath conf ]
 
-      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 :: RC ()
 updateCacheRepo = do
-  conf <- use config
+  conf <- gets config
-  remoteCommand $ intercalate " && "
+
+  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 :: RC (Maybe String)
+setReleaseRevision :: RC ()
 setReleaseRevision = do
-  conf <- use config
+  conf             <- gets config
-  releaseTimestamp <- use timestamp
+  releaseTimestamp <- gets timestamp
+
   case releaseTimestamp of
     Nothing -> lift $ left (1, Just "No releases to symlink!")
-    Just rls ->
+    Just rls -> do
-      remoteCommand $ intercalate " && "
+      void $ runCommand (host conf) $ intercalate " && "
-      [ "cd " ++ releasePath conf rls
+        [ "cd " ++ releasePath conf rls
-      , "git fetch --all"
+        , "git fetch --all"
-      , "git reset --hard " ++ conf ^. revision
+        , "git reset --hard " ++ revision conf
-      ]
+        ]
 
 -- | Returns a command that builds this application. Sets the context
 -- of the build by switching to the release directory before running
@@ -398,13 +457,14 @@ buildRelease :: [String] -- ^ Commands to be run. List intercalated
                          -- sequence.
              -> RC (Maybe String)
 buildRelease commands = do
-  conf <- use config
+  conf             <- gets config
-  releaseTimestamp <- use timestamp
+  releaseTimestamp <- gets 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
+      runCommand (host conf) $ intercalate " && " $ cdCmd : commands
 
 -- | A safe version of the `maximum` function in Data.List.
 biggest :: Ord a => [a] -> Maybe a

src/System/Hapistrano/Types.hs

@@ -0,0 +1,46 @@
+module System.Hapistrano.Types
+       ( Config(..)
+       , HapistranoState(..)
+       , RC
+       , Release
+       , ReleaseFormat(..)
+       ) where
+
+import Control.Monad.Trans.State (StateT)
+
+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
+                   | Long  -- ^ Long release path including picoseconds for testing or people seriously into continuous deployment
+                   deriving (Show)
+
+data HapistranoState = HapistranoState { config    :: Config
+                                       , timestamp :: Maybe String
+                                       } deriving Show
+
+type Release = String
+
+type RC a = StateT HapistranoState (EitherT (Int, Maybe String) IO) a