bisect_tests.hs

#!/usr/bin/env stack
-- stack runghc --resolver lts-7.19 --install-ghc --package turtle -- -Wall

-- install stack with "curl -sSL https://get.haskellstack.org/ | sh"

-- create an AWS image with `env AWS_PROFILE=YOUR_PROFILE packer build -var 'stackage=lts-7.19' -var 'base_ami=ami-aaaaaaaa' bisect_tests.packer.json`

{-# LANGUAGE OverloadedStrings #-}

import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import           Data.List                 (tails)
import           Data.Maybe                (fromMaybe)
import qualified Data.Text                 as T
import           Turtle                    hiding (x)

data TestType = Unit | Integration | Functional deriving (Show, Read)

testTypeName :: TestType -> Text
testTypeName Unit        = "unit:"
testTypeName Integration = "integration:"
testTypeName Functional  = "functional:"

parser :: Parser (TestType, [Text], Text)
parser = (,,) <$> optRead "type" 't' "one of Unit, Integration, Functional"
              <*> (T.words <$> argText "tests_pattern" "list of tests (space separated)")
              <*> argText "failing_test" "test in which the conflict is manifested"

testApp :: TestType -> [Text] -> IO ExitCode
testApp testType tests  = do
    echo $ "testing with: " <> T.unwords tests
    echo ""
    proc "grails" (["test-app", testTypeName testType] ++ tests) mzero

type Runner = [Text] -> IO ExitCode

loop :: Runner -> [Text] -> Text -> IO [Text]
loop runner testList failing = do
    res <- runMaybeT $ loop' runner failing (splitInto 2 testList)
                       `mplus` -- the minimum length might be > 2, and overlapping the half, thus let's also split at 1/3rd
                       loop' runner failing (splitInto 3 testList)
    pure $ fromMaybe testList res

failWith :: a -> ExitCode -> Maybe a
failWith _ ExitSuccess     = Nothing
failWith a (ExitFailure _) = Just a

failWithF :: (Functor f) => a -> f ExitCode -> MaybeT f a
failWithF x y = MaybeT $ failWith x <$> y

loop' :: Runner -> Text -> [[Text]] -> MaybeT IO [Text]
loop' _ _ ([]:_) = mzero
loop' runner failing testChunks = do
    let candidates = map join $ combinations (length testChunks - 1) testChunks
    slice <- msum (map
                    (\candidate -> failWithF candidate (runner $ candidate ++ [failing]))
                    candidates)
    liftIO $ loop runner slice failing

combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [[]]
combinations n xs = [y:ys| y:xs' <- tails xs
                         , ys <- combinations (n - 1) xs']

splitInto :: Int -> [a] -> [[a]]
splitInto chunks xs = reverse $ split (chunks - 1) (length xs `div` chunks) xs

split :: Int -> Int -> [a] -> [[a]]
split 0 _ xs = [xs]
split step chunkSize xs = right : split (step - 1) chunkSize left
    where
        (left, right) = splitAt (chunkSize * step) xs


main :: IO ()
main = do
    (testType, testList, failing) <- options "Test bisector" parser
    let testRunner = testApp testType
    minimized <- loop testRunner testList failing
    echo $ "Minimal test case: " <> T.unwords minimized <> " " <> failing

bisect_tests.packer.json

{
  "variables": {
    "stackage": null,
    "base_ami": null,
    "scripts_dir": "."
  },
  "builders": [{
    "type": "amazon-ebs",
    "region": "eu-west-1",
    "source_ami": "{{user `base_ami`}}",
    "instance_type": "m4.xlarge",
    "vpc_id": "vpc-aaaaaaaa",
    "subnet_id": "subnet-aaaaaaa",
    "ssh_username": "ubuntu",
    "ami_name": "bisect-tests worker {{timestamp}}"
  }],
  "provisioners": [{
      "type": "shell-local",
      "command": "stack ghc --resolver {{user `stackage`}} --install-ghc --package turtle {{user `scripts_dir`}}/bisect_tests.hs"
    }, {
      "type": "file",
      "source": "{{user `scripts_dir`}}/bisect_tests",
      "destination": "/tmp/bisect_tests"
    }, {
    "type": "shell",
    "inline": [
      "sleep 30",
      "sudo mv /tmp/bisect_tests /usr/local/bin/bisect_tests"
    ]}
  ]
}