Haskell is a better Python. Continuously run arg, snapping working dir (minus .git) on failures. Optionally upload failures to S3.

run-zing.zsh

PATH=/usr/local/bin:$PATH

[[ -z $1 ]] && echo run-zing NUM && exit 99
run_number=$1

if [[ $(facter os.name) == 'CentOS' ]]; then
  ZING_HOME=/opt/zing/zing-jdk1.8.0-16.01.9.0-1-x86_64
else
  ZING_HOME=/opt/zing/zing-jdk1.8.0-16.01.9.0-1
fi

ulimit -c unlimited
ulimit -l 1000000
ulimit -n 1000000
chpst -u drewr -U drewr \
  env \
   HOME=/home/drewr \
   PATH=../gradle-2.13/bin:$PATH \
   JAVA_HOME=$ZING_HOME \
   ../runsnap 'git clean -fd >OUT-git-clean.log 2>&1 && \
     ( git checkout -f 770abd7af8c23773b0a1d5d4153298e69d0151d5 && git log -1 ) >OUT-git-checkout.log 2>&1 && \
     gradle --stacktrace clean >OUT-clean.log 2>&1 && \
     gradle --info check >OUT-check.log 2>&1' $run_number

runsnap.hs

#!/usr/bin/env stack
{- stack --resolver lts-6.13 --install-ghc runghc
     --package text
-}

-- Continuously run arg (using System.Process.callCommand), snapping
-- working directory on failure.  The snap uses rsync to create a
-- sibling directory with timestamp and git sha.  The .git directory
-- is not copied.
--
-- If arg hangs, runsnap's child PID can accept a SIGUSR1 (10) which
-- will terminate the iteration, snap the working dir, and start the
-- next one.
--
-- Try it!
--
--     runsnap "sleep 2; echo run a thing; exit 0"
--     runsnap "sleep 2; echo run a thing; exit 99"
--
-- Really wrote it for running test suites in an ad hoc infinite loop:
--
--     % cd elasticsearch
--     % env \
--     PATH=../gradle-2.13/bin:$PATH \
--     JAVA_HOME=/opt/zing/zing-jdk1.8.0-16.01.7.0-6 \
--     ../runsnap 'git clean -fd >OUT-git-clean.log 2>&1 && \
--       git fetch >OUT-git-fetch.log 2>&1 && \
--       git checkout -f origin/master >OUT-git-checkout.log 2>&1 && \
--       gradle --stacktrace clean >OUT-clean.log 2>&1 && \
--       gradle --info check >OUT-check.log 2>&1'
--

{-# LANGUAGE OverloadedStrings #-}

import Control.Exception (finally)
import Control.Monad (liftM)
import Data.Time.Clock as T
import Data.Time.Format as TF
import Data.Text (pack, unpack, strip)
import System.Directory (canonicalizePath, getCurrentDirectory, setCurrentDirectory)
import System.Environment (getArgs)
import System.Exit
import System.FilePath.Posix (takeFileName, (</>))
import System.Posix.Signals (installHandler, sigUSR1, Handler(..))
import System.Process
       (spawnCommand, waitForProcess, callCommand, readProcessWithExitCode,
        terminateProcess)

import Text.Printf (printf)

type ShellCommand = String

main :: IO ()
main = do
  args <- getArgs
  case args of
    ["setup"] -> putStrLn "setup complete"
    [cmd] -> runAndCount cmd 1
    [cmd,offset] -> runAndCount cmd (read offset :: Int)
    [] -> do
      snapped <- snapCurrDir ""
      putStrLn $ "snapped to " ++ snapped
    _ -> error $ "unknown: \"" ++ show args ++ "\""

stripStr :: String -> String
stripStr = unpack . strip . pack

gitHead :: FilePath -> IO (Maybe String)
gitHead dir = do
  withCurrentDirectory dir $ do
    (c, out, _) <- readProcessWithExitCode "git" ["rev-parse", "HEAD"] ""
    pure $ case c of
      ExitSuccess -> Just (stripStr out)
      _ -> Nothing

nowString :: IO String
nowString = do
  t <- T.getCurrentTime
  pure $ TF.formatTime TF.defaultTimeLocale "%Y%m%d%H%M%S" t

resolveDirName :: FilePath -> IO FilePath
resolveDirName dir = liftM takeFileName (canonicalizePath dir)

snapCurrDir :: String -> IO String
snapCurrDir i = snapDir i "."

snapDir :: String -> String -> IO String
snapDir iterStr dir = do
  now <- nowString
  gitRev <- gitHead dir
  baseName <- resolveDirName dir
  destParent <- canonicalizePath (dir </> "..")
  let gitRev' = case gitRev of
              (Just rev) -> rev
              Nothing -> ""
      dest = destParent </> baseName ++ "-" ++ now ++ "-" ++
             gitRev' ++ (if (null iterStr) then "" else ("-" ++ iterStr))
      cmd = "rsync -a --exclude .git " ++ dir ++ " " ++ dest
  callCommand cmd
  pure dest

runAndCount :: ShellCommand -> Int -> IO ()
runAndCount cmd n = do
  tStart <- T.getCurrentTime
  proc <- spawnCommand cmd
  installHandler sigUSR1 (CatchOnce $ terminateProcess proc) Nothing
  res <- waitForProcess proc
  tEnd <- T.getCurrentTime
  let dur = show $ T.diffUTCTime tEnd tStart
  case res of
    ExitSuccess -> logMe "success" dur >> putStrLn ""
    (ExitFailure code) -> do
      logMe "fail" dur
      putStr $ " (" ++ (show code) ++ "): "
      dest <- snapCurrDir iterStr
      putStrLn dest
  runAndCount cmd (n + 1)
  where logMe status dur = putStr $ "== runsnap ==> " ++ (show n) ++ " " ++ status ++ " " ++ dur
        iterStr = printf "%06i" n :: String

withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory path f = do
    cur <- getCurrentDirectory
    setCurrentDirectory path
    finally f (setCurrentDirectory cur)

savesnap.hs

#!/usr/bin/env stack
{- stack --resolver lts-6.13 --install-ghc
     runghc
     --package amazonka
     --package amazonka-s3
     --package cond
     --package filepath
     --package network
     --package text
-}

-- Save a directory as .tar.xz and .zip, then upload those to S3 at
-- BUCKET/PREFIX/FILENAME.
--
-- Example:
--
--    savesnap mybucket.example.com $(date -u +%s) somedir/
--

{-# LANGUAGE OverloadedStrings #-}

import Prelude hiding (unwords, takeWhile)
import Control.Exception
import Control.Lens (set, view, (<&>), (.~))
import Control.Monad
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.AWS
import Data.Monoid
import Data.Text (Text, pack, unpack, strip, dropAround, unwords, takeWhile)
import Data.Text.IO as T
import Network.AWS.Data (toText, fromText)
import Network.AWS.S3
       (BucketName(..), ObjectKey(..), putObject, poACL,
        ObjectCannedACL(OPublicRead))
import Network.BSD (getHostName)
import System.Directory
import System.Environment (getArgs)
import System.FilePath.Posix as Path hiding ((</>))
import System.IO (stdout)
import System.Process (callCommand)

data DirToSave = DirToSave
  { _path :: Text
  , _parent :: Text
  , _basename :: Text
  , _xzFile :: Text  -- xz file path
  , _zipFile :: Text  -- zip file path
  , _xzName :: Text  -- xz file without dir
  , _zipName :: Text  -- zip file without dir
  }

chunksize = 16384

main = do
  args <- getArgs
  host <- getHostName
  let shortHost = takeWhile (\c -> not (c == '.')) . pack $ host
  case args of
    [bucket, prefix, dirToSync] ->
      saveToS3 (pack bucket) (pack prefix) (mkDirToSave (pack dirToSync) shortHost)
    _ -> error $ "unknown: \"" ++ show args ++ "\""

mkDirToSave :: Text -> Text -> DirToSave
mkDirToSave path suffix = DirToSave
  { _path = path
  , _parent = pack . Path.takeDirectory . unpack $ path
  , _basename = baseName

  , _xzFile = path <> xzExt
  , _xzName = baseName <> xzExt

  , _zipFile = path <> zipExt
  , _zipName = baseName <> zipExt
  }
  where
    xzExt = "." <> suffix <> ".tar.xz"
    zipExt = "." <> suffix <> ".zip"
    baseName = pack . Path.takeFileName . unpack $ path

mkArchive :: DirToSave -> (DirToSave -> Text) -> Text -> IO ()
mkArchive dir accessor archiveCmd = do
  fileExists <- doesFileExist (unpack . accessor $ dir)
  when (not fileExists) $ do
    withCurrentDirectory (unpack . _parent $ dir) $ do
      callCommand . unpack $ cmd
    say $ "create " <> (accessor dir)
  where cmd = unwords [archiveCmd, (accessor dir), (_basename dir)]

(</>) :: Text -> Text -> Text
(</>) x y = (dropAround (== '/') x) <> "/" <> (dropAround (== '/') y)

saveToS3 :: Text -> Text -> DirToSave -> IO ()
saveToS3 b pre dir = do
  mkArchive dir _zipFile "zip -qr9"
  mkArchive dir _xzFile "tar cfJ"
  putChunkedFile
     NorthVirginia (BucketName b)
     (ObjectKey (pre </> _xzName dir)) chunksize (unpack . _xzFile $ dir)
  putChunkedFile
     NorthVirginia (BucketName b)
     (ObjectKey (pre </> _zipName dir)) chunksize (unpack . _zipFile $ dir)

putChunkedFile :: Region
               -> BucketName
               -> ObjectKey
               -> ChunkSize
               -> FilePath
               -> IO ()
putChunkedFile r b k c f = do
    lgr <- newLogger Debug stdout
    env <- newEnv r Discover <&> envLogger .~ lgr
    runResourceT . runAWST env $
        do bdy <- chunkedFile c f
           let po = set poACL (Just OPublicRead) $ putObject b k bdy
           void . send $ po
           say $
               "Successfully Uploaded: " <> toText f <> " to " <> toText b <>
               " - " <>
               toText k
           
say :: MonadIO m => Text -> m ()
say = liftIO . T.putStrLn

withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory path f = do
    cur <- getCurrentDirectory
    setCurrentDirectory path
    finally f (setCurrentDirectory cur)