First

LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2014 Justin Leitgeb
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

hapistrano.cabal

@@ -0,0 +1,26 @@
+name:                hapistrano
+version:             0.1.0.0
+-- synopsis:
+-- description:
+license:             MIT
+license-file:        LICENSE
+author:              Justin Leitgeb
+maintainer:          justin@stackbuilders.com
+-- copyright:
+category:            System
+build-type:          Simple
+-- extra-source-files:
+cabal-version:       >=1.10
+
+executable hap
+  main-is:             Main.hs
+  -- other-modules:
+  -- other-extensions:
+  build-depends:         base >=4.6 && <4.7
+                       , time
+                       , old-locale
+                       , process
+                       , either
+                       , transformers
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/Main.hs

@@ -0,0 +1,175 @@
+module Main where
+
+import System.Locale (defaultTimeLocale)
+import Data.Time (getCurrentTime)
+import Data.Time.Format (formatTime)
+import System.Process
+import System.Exit (ExitCode(..))
+import Control.Monad.Trans.Either (EitherT(..), left, right, runEitherT)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+
+import Data.List
+
+import Data.Char (isNumber)
+
+currentTimestamp :: IO String
+currentTimestamp = do
+  curTime <- getCurrentTime
+  return $ formatTime defaultTimeLocale "%Y%m%d%H%M%S" curTime
+
+type RemoteCommand = EitherT (Int, Maybe String) IO (Maybe String)
+
+-- ^ Used to compose a "command" that is really just output in the chain.
+echoMessage :: String -> RemoteCommand
+echoMessage msg = do
+  liftIO $ putStrLn msg
+  right Nothing
+
+remoteT ::  -- ^ The host to run commands on
+            String
+
+            -- ^ The command to run remotely
+            -> String
+
+            -- ^ Left (non-zero code, Maybe STDERR) or Right (Maybe STDOUT)
+            -> RemoteCommand
+
+remoteT server command = do
+  liftIO $ putStrLn $ "Going to execute " ++ command ++ " on host " ++ server ++
+    "."
+
+  (code, stdout, stderr) <-
+    liftIO $ readProcessWithExitCode "ssh" (server : words command) ""
+  case code of
+    ExitSuccess -> do
+      liftIO $ putStrLn $ "Command '" ++ command ++
+        "' was successful on host '" ++ server ++ "'."
+
+      right $ maybeString stdout
+    ExitFailure int -> do
+      liftIO $
+        putStrLn $ "Command '" ++ command ++ "' failed " ++ "on host '" ++
+                   server ++ "'."
+
+      left $ (int, maybeString stderr)
+
+
+-- ^ Check for existence of bare repo - does not verify contents.
+doesBareRepoExist :: Config -> RemoteCommand
+doesBareRepoExist config = do
+  remoteT (host config) $ "ls " ++ repoPath config
+
+
+-- ^ Ensure that the initial bare repo exists in the repo directory. Idempotent.
+ensureRepositoryPushed :: Config -> RemoteCommand
+ensureRepositoryPushed config = do
+  res <- liftIO $ runEitherT $ doesBareRepoExist config
+
+  case res of
+    Left _ -> createCacheRepo config
+    Right _ -> right $ Just "Repo already existed"
+
+
+-- ^ Config stuff that will be replaced by config file reading
+data Config = Config { deployPath :: String
+                     , deploySha1 :: String
+                     , host       :: String
+                     , repository :: String -- ^ The remote git repo
+                     } deriving (Show)
+
+
+-- ^ 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
+
+releasesPath :: Config -> String
+releasesPath config = deployPath config ++ "/releases"
+
+-- ^ The path indicating the current release folder.
+releasePath :: Config -> IO String
+releasePath config = do
+  ts <- currentTimestamp
+  return $ releasesPath config ++ "/" ++ ts
+
+-- ^ Clones the repository to the next releasePath timestamp.
+cloneToNewRelease :: Config -> RemoteCommand
+cloneToNewRelease config = do
+  nextReleasePath <- liftIO $ releasePath config
+  remoteT (host config) $
+    "git clone " ++ repoPath config ++ " " ++ nextReleasePath
+
+repoPath :: Config -> String
+repoPath config = deployPath config ++ "/repo"
+
+releases :: Config -> EitherT (Int, Maybe String) IO [String]
+releases config = do
+  res <- liftIO $ runEitherT $ remoteT (host config) cmd
+  case res of
+    Left r -> left r
+    Right rs ->
+      case rs of
+        Nothing -> right []
+        Just s  ->
+          right $ filter isReleaseString . map (reverse . take 14 . reverse) $
+          lines s
+
+  where cmd = "find " ++ releasesPath config ++ " -type d -maxdepth 1"
+
+-- Given a list of release strings, takes the last five in the sequence.
+-- Assumes a list of folders that has been determined to be a proper release
+-- path.
+oldReleases :: Config -> [String] -> [String]
+oldReleases config rs =
+  withDir
+  where sorted = (reverse . sort) rs
+        toDelete = drop 5 sorted
+        withDir = map (\fileName -> (releasesPath config) ++ "/" ++ fileName)
+                  toDelete
+
+cleanReleases :: Config -> RemoteCommand
+cleanReleases config = do
+  allReleases <- liftIO $ runEitherT $ releases config
+
+  case allReleases of
+    Left err -> left err
+    Right xs -> do
+      let deletable = oldReleases config xs
+
+      if null deletable then
+        echoMessage "There are no old releases to prune."
+       else
+        remoteT (host config) $ "rm -rf " ++ foldr (\a b -> a ++ " " ++ b) ""
+          deletable
+
+isReleaseString :: String -> Bool
+isReleaseString s = all isNumber s && (length s) == 14
+
+createCacheRepo :: Config -> RemoteCommand
+createCacheRepo config =
+  remoteT (host config) cmd
+  where cmd = "git clone --bare " ++ (repository config) ++ " " ++
+              repoPath config
+
+setupDirs :: Config -> RemoteCommand
+setupDirs config =
+  remoteT (host config) $ "mkdir -p " ++ (deployPath config) ++ "/releases"
+
+testConfig :: Config
+testConfig = Config { deployPath = "/tmp/project"
+                    , deploySha1 = "master"
+                    , host       = "localhost"
+                    , repository = "/tmp/testrepo"
+                    }
+
+
+main :: IO ()
+main = do
+  runEitherT $
+    setupDirs testConfig >>
+    ensureRepositoryPushed testConfig >>
+    cleanReleases testConfig >>
+    cloneToNewRelease testConfig
+
+  return ()