{-# LANGUAGE OverloadedStrings #-}

{- | Implementations of the @pbt-cli@ commands.

Every command returns an 'ExitCode' rather than calling @exitWith@ itself, so
the exit-code contract lives in one place and is testable:

* @0@ — success
* @1@ — tests failed, or nothing matched (no suites, empty tree)
* @2@ — usage error: unknown suite, or a suite that cannot do what was asked
* @3@ — discovery failed (the root is not a readable directory)
* @4@ — @cabal@ could not be found or could not be started
* @5@ — some other I\/O failure

@5@ exists so that @1@ keeps meaning what it says. An unrelated I\/O error — a
write failure part-way through @suites --json@, an @EMFILE@ while forking
cabal — must not reach a CI consumer looking like a failing test run.
-}
module PbtCli.Run (
  execute,

  -- * Selection (exposed for testing)
  groupByProject,
  selectSuites,

  -- * Exit codes
  exitOk,
  exitFailed,
  exitUsage,
  exitDiscovery,
  exitCabal,
  exitIoError,
  classifyIoError,
) where

import Control.Exception (IOException, catch)
import Control.Monad (forM_, unless)
import Data.Aeson (Value (..), decodeStrict')
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.IntMap.Strict qualified as IntMap
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as TextIO
import PbtCli.Cabal (
  CabalMissing (..),
  Invocation,
  TestOptions (..),
  findCabal,
  noTestOptions,
  renderCommand,
  runCapture,
  runInherit,
  runStreaming,
  testInvocation,
 )
import PbtCli.Discover (
  Discovery (..),
  SuiteRef (..),
  TestSuite (..),
  compatibleOnly,
  discover,
  entryPointText,
  flattenSuites,
  isCompatible,
 )
import PbtCli.Doctor (doctor)
import PbtCli.Events (Event (..), decodeEvent, eventsFrom, isJsonObjectLine)
import PbtCli.Options (
  Command (..),
  DoctorOpts (..),
  Filters (..),
  RunOpts (..),
  RunOutput (..),
  SuitesFormat (..),
  SuitesOpts (..),
  TestsFormat (..),
  TestsOpts (..),
  ThreatModelsOpts (..),
 )
import PbtCli.Render (
  encodeJsonCompact,
  encodeJsonPretty,
  renderEventWith,
  renderSuiteBanner,
  renderSuiteNames,
  renderSuitesTable,
  renderSuitesTsv,
  renderTestList,
  renderTestTree,
  tagEventWithSuite,
  testNameIndex,
 )
import System.Directory (doesDirectoryExist, makeAbsolute)
import System.Exit (ExitCode (..))
import System.IO (hPutStrLn, stderr)
import System.IO.Error (isDoesNotExistError, isPermissionError, isResourceVanishedError)

exitOk, exitFailed, exitUsage, exitDiscovery, exitCabal, exitIoError :: ExitCode
exitOk :: ExitCode
exitOk = ExitCode
ExitSuccess
exitFailed :: ExitCode
exitFailed = Int -> ExitCode
ExitFailure Int
1
exitUsage :: ExitCode
exitUsage = Int -> ExitCode
ExitFailure Int
2
exitDiscovery :: ExitCode
exitDiscovery = Int -> ExitCode
ExitFailure Int
3
exitCabal :: ExitCode
exitCabal = Int -> ExitCode
ExitFailure Int
4
exitIoError :: ExitCode
exitIoError = Int -> ExitCode
ExitFailure Int
5

{- | Which exit code an 'IOException' deserves.

Shared with @main@, which classifies a failure of its own final
@hFlush stdout@ the same way -- otherwise a write error would be reported with
one code inside 'execute' and another at shutdown.

* A vanished resource means stdout closed under us: the consumer of a pipe
  stopped reading, which is what @pbt-cli suites | head@ does. It got what it
  asked for, so exit quietly.
* A missing or unreadable file is the one class that can mean cabal itself
  could not be started, so it keeps cabal's code.
* Everything else gets its own code. Blaming cabal was actively misleading --
  an encoding error while rendering a table used to be reported as "could not
  run cabal" -- but so is exit 1, which the contract reserves for a failing
  test run.
-}
classifyIoError :: IOException -> ExitCode
classifyIoError :: IOException -> ExitCode
classifyIoError IOException
e
  | IOException -> Bool
isResourceVanishedError IOException
e = ExitCode
exitOk
  | IOException -> Bool
isDoesNotExistError IOException
e Bool -> Bool -> Bool
|| IOException -> Bool
isPermissionError IOException
e = ExitCode
exitCabal
  | Bool
otherwise = ExitCode
exitIoError

{- | Dispatch a parsed command.

A missing @cabal@ is caught here rather than per command: it is the one
failure every non-static command shares, and it deserves the same message and
exit code wherever it surfaces.
-}
execute :: Command -> IO ExitCode
execute :: Command -> IO ExitCode
execute Command
cmd = IO ExitCode
run IO ExitCode -> (CabalMissing -> IO ExitCode) -> IO ExitCode
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` CabalMissing -> IO ExitCode
onCabalMissing IO ExitCode -> (IOException -> IO ExitCode) -> IO ExitCode
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOException -> IO ExitCode
onIOError
 where
  run :: IO ExitCode
run = case Command
cmd of
    Suites SuitesOpts
o -> SuitesOpts -> IO ExitCode
doSuites SuitesOpts
o
    Tests TestsOpts
o -> TestsOpts -> IO ExitCode
doTests TestsOpts
o
    Run RunOpts
o -> RunOpts -> IO ExitCode
doRun RunOpts
o
    ThreatModels ThreatModelsOpts
o -> ThreatModelsOpts -> IO ExitCode
doThreatModels ThreatModelsOpts
o
    Doctor DoctorOpts
o -> String -> IO ExitCode
doctor (DoctorOpts -> String
dcoRoot DoctorOpts
o)

  onCabalMissing :: CabalMissing -> IO ExitCode
onCabalMissing (CabalMissing String
msg) = do
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"pbt-cli: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg)
    ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitCabal

  onIOError :: IOException -> IO ExitCode
onIOError (IOException
e :: IOException) = do
    let code :: ExitCode
code = IOException -> ExitCode
classifyIoError IOException
e
    if ExitCode
code ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
exitOk
      then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      else
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          if ExitCode
code ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
exitCabal
            then String
"pbt-cli: could not run cabal: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IOException -> String
forall a. Show a => a -> String
show IOException
e
            else String
"pbt-cli: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> IOException -> String
forall a. Show a => a -> String
show IOException
e
    ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
code

-- ---------------------------------------------------------------------------
-- suites
-- ---------------------------------------------------------------------------

doSuites :: SuitesOpts -> IO ExitCode
doSuites :: SuitesOpts -> IO ExitCode
doSuites SuitesOpts
o =
  String -> (Discovery -> IO ExitCode) -> IO ExitCode
withDiscovery (SuitesOpts -> String
suoRoot SuitesOpts
o) ((Discovery -> IO ExitCode) -> IO ExitCode)
-> (Discovery -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \Discovery
d0 -> do
    let d :: Discovery
d = if SuitesOpts -> Bool
suoCompatibleOnly SuitesOpts
o then Discovery -> Discovery
compatibleOnly Discovery
d0 else Discovery
d0
    case SuitesOpts -> SuitesFormat
suoFormat SuitesOpts
o of
      SuitesFormat
SuitesList -> Text -> IO ()
TextIO.putStr (Discovery -> Text
renderSuiteNames Discovery
d)
      SuitesFormat
SuitesJson -> ByteString -> IO ()
LBS8.putStr (Discovery -> ByteString
forall a. ToJSON a => a -> ByteString
encodeJsonPretty Discovery
d)
      SuitesFormat
SuitesJsonCompact -> ByteString -> IO ()
LBS8.putStrLn (Discovery -> ByteString
forall a. ToJSON a => a -> ByteString
encodeJsonCompact Discovery
d)
      SuitesFormat
SuitesTable -> Text -> IO ()
TextIO.putStr (Discovery -> Text
renderSuitesTable Discovery
d)
      SuitesFormat
SuitesTsv -> Text -> IO ()
TextIO.putStr (Discovery -> Text
renderSuitesTsv Discovery
d)
    -- Same contract as list-test-suites.sh: a readable root with nothing to
    -- report is exit 1, distinct from a bad root (exit 3).
    ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if [SuiteRef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Discovery -> [SuiteRef]
flattenSuites Discovery
d) then ExitCode
exitFailed else ExitCode
exitOk)

-- ---------------------------------------------------------------------------
-- tests
-- ---------------------------------------------------------------------------

doTests :: TestsOpts -> IO ExitCode
doTests :: TestsOpts -> IO ExitCode
doTests TestsOpts
o =
  String
-> Text -> (String -> SuiteRef -> IO ExitCode) -> IO ExitCode
withStreamingSuite (TestsOpts -> String
tsoRoot TestsOpts
o) (TestsOpts -> Text
tsoSuite TestsOpts
o) ((String -> SuiteRef -> IO ExitCode) -> IO ExitCode)
-> (String -> SuiteRef -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \String
root SuiteRef
sr -> do
    Invocation
inv <-
      String -> SuiteRef -> TestOptions -> IO Invocation
invocationFor
        String
root
        SuiteRef
sr
        (Filters -> TestOptions
filterOptions (TestsOpts -> Filters
tsoFilters TestsOpts
o)){toListTestsJson = True}
    if TestsOpts -> Bool
tsoDryRun TestsOpts
o
      then [Invocation] -> IO ExitCode
dryRun [Invocation
inv]
      else do
        (ExitCode
code, [ByteString]
ls) <- Invocation -> IO (ExitCode, [ByteString])
runCapture Invocation
inv
        case [Event
e | e :: Event
e@EventSuiteStarted{} <- [ByteString] -> [Event]
eventsFrom [ByteString]
ls] of
          (EventSuiteStarted [TestInfo]
tests Value
raw : [Event]
_) -> do
            case TestsOpts -> TestsFormat
tsoFormat TestsOpts
o of
              TestsFormat
TestsList -> Text -> IO ()
TextIO.putStr ([TestInfo] -> Text
renderTestList [TestInfo]
tests)
              TestsFormat
TestsJson -> ByteString -> IO ()
LBS8.putStr (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodeJsonPretty Value
raw)
              TestsFormat
TestsTree -> Text -> IO ()
TextIO.putStr ([TestInfo] -> Text
renderTestTree [TestInfo]
tests)
            ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if [TestInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestInfo]
tests then ExitCode
exitFailed else ExitCode
exitOk)
          [Event]
_ -> do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"pbt-cli: "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (TestSuite -> Text
tsName (SuiteRef -> TestSuite
srSuite SuiteRef
sr))
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" produced no test tree. The suite is marked as streaming-capable, so "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"this usually means it failed to build — cabal's output above says why."
            ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExitCode -> ExitCode -> ExitCode
worstOf ExitCode
code ExitCode
exitFailed)

-- ---------------------------------------------------------------------------
-- run
-- ---------------------------------------------------------------------------

doRun :: RunOpts -> IO ExitCode
doRun :: RunOpts -> IO ExitCode
doRun RunOpts
o =
  String -> (Discovery -> IO ExitCode) -> IO ExitCode
withDiscovery (RunOpts -> String
rnoRoot RunOpts
o) ((Discovery -> IO ExitCode) -> IO ExitCode)
-> (Discovery -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \Discovery
d0 -> do
    let d :: Discovery
d = if RunOpts -> Bool
rnoCompatibleOnly RunOpts
o then Discovery -> Discovery
compatibleOnly Discovery
d0 else Discovery
d0
        available :: [SuiteRef]
available = Discovery -> [SuiteRef]
flattenSuites Discovery
d
    case [SuiteRef] -> [Text] -> Either String [SuiteRef]
selectSuites [SuiteRef]
available (RunOpts -> [Text]
rnoSuites RunOpts
o) of
      Left String
err -> String -> [SuiteRef] -> IO ExitCode
usageError String
err [SuiteRef]
available
      Right [] -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"pbt-cli: no test suites found."
        ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitFailed
      Right [SuiteRef]
selected -> case [SuiteRef] -> [SuiteRef]
incompatible [SuiteRef]
selected of
        -- --stream and --json need the --streaming-json ingredient, which only
        -- convex-tasty-streaming provides. Refusing here beats running an
        -- upstream-tasty suite that would ignore the flag, print its usual
        -- console output and exit 0 -- leaving a consumer waiting for events
        -- that never come.
        (SuiteRef
bad : [SuiteRef]
more)
          | RunOpts -> RunOutput
rnoOutput RunOpts
o RunOutput -> RunOutput -> Bool
forall a. Eq a => a -> a -> Bool
/= RunOutput
RunConsole ->
              [SuiteRef] -> IO ExitCode
forall {t :: * -> *}. Foldable t => t SuiteRef -> IO ExitCode
incompatibleError (SuiteRef
bad SuiteRef -> [SuiteRef] -> [SuiteRef]
forall a. a -> [a] -> [a]
: [SuiteRef]
more)
        [SuiteRef]
_ -> do
          String
root <- String -> IO String
makeAbsolute (RunOpts -> String
rnoRoot RunOpts
o)
          String
cabal <- IO String
findCabal
          case RunOpts -> RunOutput
rnoOutput RunOpts
o of
            RunOutput
RunConsole -> String -> String -> [SuiteRef] -> IO ExitCode
consoleRun String
root String
cabal [SuiteRef]
selected
            RunOutput
RunStream -> String -> String -> [SuiteRef] -> EventMode -> IO ExitCode
eventRun String
root String
cabal [SuiteRef]
selected (Bool -> EventMode
Pretty ([SuiteRef] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SuiteRef]
selected Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1))
            RunOutput
RunJson -> String -> String -> [SuiteRef] -> EventMode -> IO ExitCode
eventRun String
root String
cabal [SuiteRef]
selected EventMode
Ndjson
 where
  incompatible :: [SuiteRef] -> [SuiteRef]
incompatible = (SuiteRef -> Bool) -> [SuiteRef] -> [SuiteRef]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (SuiteRef -> Bool) -> SuiteRef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuite -> Bool
isCompatible (TestSuite -> Bool) -> (SuiteRef -> TestSuite) -> SuiteRef -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuiteRef -> TestSuite
srSuite)

  incompatibleError :: t SuiteRef -> IO ExitCode
incompatibleError t SuiteRef
bad = do
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"pbt-cli: "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if RunOpts -> RunOutput
rnoOutput RunOpts
o RunOutput -> RunOutput -> Bool
forall a. Eq a => a -> a -> Bool
== RunOutput
RunJson then String
"--json" else String
"--stream")
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" needs sc-testing-tools compatible suites, but these are not:"
    t SuiteRef -> (SuiteRef -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t SuiteRef
bad ((SuiteRef -> IO ()) -> IO ()) -> (SuiteRef -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SuiteRef
sr ->
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"  "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (TestSuite -> Text
tsName (SuiteRef -> TestSuite
srSuite SuiteRef
sr))
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (entry point: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (EntryPoint -> Text
entryPointText (TestSuite -> EntryPoint
tsEntryPoint (SuiteRef -> TestSuite
srSuite SuiteRef
sr)))
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
    Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Add --compatible-only to skip them, or drop the output flag."
    ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitUsage

  -- \| Console mode: one @cabal test@ per project file, stdio inherited.
  --
  --  Grouping is what keeps a whole-repository run to a couple of cabal calls.
  --
  consoleRun :: String -> String -> [SuiteRef] -> IO ExitCode
consoleRun String
root String
cabal [SuiteRef]
selected = do
    let opts :: TestOptions
opts = Filters -> TestOptions
filterOptions (RunOpts -> Filters
rnoFilters RunOpts
o)
        invs :: [Invocation]
invs =
          [ String
-> String -> Maybe String -> [String] -> TestOptions -> Invocation
testInvocation String
cabal String
root Maybe String
projectFile ((SuiteRef -> String) -> [SuiteRef] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SuiteRef -> String
suiteName [SuiteRef]
srs) TestOptions
opts
          | (Maybe String
projectFile, [SuiteRef]
srs) <- [SuiteRef] -> [(Maybe String, [SuiteRef])]
groupByProject [SuiteRef]
selected
          ]
    if RunOpts -> Bool
rnoDryRun RunOpts
o
      then [Invocation] -> IO ExitCode
dryRun [Invocation]
invs
      else [ExitCode] -> ExitCode
worst ([ExitCode] -> ExitCode) -> IO [ExitCode] -> IO ExitCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Invocation -> IO ExitCode) -> [Invocation] -> IO [ExitCode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Invocation -> IO ExitCode
runInherit [Invocation]
invs

  -- \| Event modes: one @cabal test@ per suite.
  --
  --  Suites cannot be grouped here. Cabal runs grouped targets sequentially and
  --  the events of each carry no suite identity, so a grouped run would produce
  --  several indistinguishable @suite_started@ blocks. One invocation per suite
  --  costs a little cabal overhead and buys correct attribution.
  --
  eventRun :: String -> String -> [SuiteRef] -> EventMode -> IO ExitCode
eventRun String
root String
cabal [SuiteRef]
selected EventMode
mode = do
    let opts :: TestOptions
opts = (Filters -> TestOptions
filterOptions (RunOpts -> Filters
rnoFilters RunOpts
o)){toStreamingJson = True}
        invs :: [(SuiteRef, Invocation)]
invs = [(SuiteRef
sr, String
-> String -> Maybe String -> [String] -> TestOptions -> Invocation
testInvocation String
cabal String
root (SuiteRef -> Maybe String
srProjectFile SuiteRef
sr) [SuiteRef -> String
suiteName SuiteRef
sr] TestOptions
opts) | SuiteRef
sr <- [SuiteRef]
selected]
    if RunOpts -> Bool
rnoDryRun RunOpts
o
      then [Invocation] -> IO ExitCode
dryRun (((SuiteRef, Invocation) -> Invocation)
-> [(SuiteRef, Invocation)] -> [Invocation]
forall a b. (a -> b) -> [a] -> [b]
map (SuiteRef, Invocation) -> Invocation
forall a b. (a, b) -> b
snd [(SuiteRef, Invocation)]
invs)
      else [ExitCode] -> ExitCode
worst ([ExitCode] -> ExitCode) -> IO [ExitCode] -> IO ExitCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SuiteRef, Invocation) -> IO ExitCode)
-> [(SuiteRef, Invocation)] -> IO [ExitCode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (EventMode -> (SuiteRef, Invocation) -> IO ExitCode
streamOne EventMode
mode) [(SuiteRef, Invocation)]
invs

  streamOne :: EventMode -> (SuiteRef, Invocation) -> IO ExitCode
streamOne EventMode
mode (SuiteRef
sr, Invocation
inv) = do
    let suite :: Text
suite = TestSuite -> Text
tsName (SuiteRef -> TestSuite
srSuite SuiteRef
sr)
    case EventMode
mode of
      Pretty Bool
True -> Text -> IO ()
TextIO.putStrLn (Text -> Text
renderSuiteBanner Text
suite)
      EventMode
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    IORef (IntMap Text)
names <- IntMap Text -> IO (IORef (IntMap Text))
forall a. a -> IO (IORef a)
newIORef IntMap Text
forall a. IntMap a
IntMap.empty
    Invocation -> (ByteString -> IO ()) -> IO ExitCode
runStreaming Invocation
inv (EventMode -> Text -> IORef (IntMap Text) -> ByteString -> IO ()
emit EventMode
mode Text
suite IORef (IntMap Text)
names)

  emit :: EventMode -> Text -> IORef (IntMap Text) -> ByteString -> IO ()
emit EventMode
mode Text
suite IORef (IntMap Text)
names ByteString
line = case EventMode
mode of
    EventMode
Ndjson
      -- Forward the suite's NDJSON, minus cabal's own chatter, with the suite
      -- named on every event so a multi-suite run stays unambiguous.
      | ByteString -> Bool
isJsonObjectLine ByteString
line -> case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict' ByteString
line of
          Just Value
v -> ByteString -> IO ()
LBS8.putStrLn (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodeJsonCompact (Text -> Value -> Value
tagEventWithSuite Text
suite Value
v))
          Maybe Value
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Pretty Bool
_ -> case ByteString -> Either String Event
decodeEvent ByteString
line of
      Right Event
ev -> do
        -- The tree arrives once, in suite_started, and later test_done events
        -- reference it by id; remember it so a test whose provider sets no
        -- description can still be named. See 'testNameIndex'.
        case Event
ev of
          EventSuiteStarted [TestInfo]
tests Value
_ -> IORef (IntMap Text) -> IntMap Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IntMap Text)
names ([TestInfo] -> IntMap Text
testNameIndex [TestInfo]
tests)
          Event
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        IntMap Text
index <- IORef (IntMap Text) -> IO (IntMap Text)
forall a. IORef a -> IO a
readIORef IORef (IntMap Text)
names
        Maybe Text -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((Int -> Maybe Text) -> Event -> Maybe Text
renderEventWith (Int -> IntMap Text -> Maybe Text
forall a. Int -> IntMap a -> Maybe a
`IntMap.lookup` IntMap Text
index) Event
ev) Text -> IO ()
TextIO.putStrLn
      Left String
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  suiteName :: SuiteRef -> String
suiteName = Text -> String
Text.unpack (Text -> String) -> (SuiteRef -> Text) -> SuiteRef -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuite -> Text
tsName (TestSuite -> Text) -> (SuiteRef -> TestSuite) -> SuiteRef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuiteRef -> TestSuite
srSuite

{- | How @run@ should present a suite's streaming events.

The flag on 'Pretty' says whether to print a banner naming each suite, which
is only worth the noise when more than one suite is being run.
-}
data EventMode = Pretty Bool | Ndjson
  deriving (EventMode -> EventMode -> Bool
(EventMode -> EventMode -> Bool)
-> (EventMode -> EventMode -> Bool) -> Eq EventMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EventMode -> EventMode -> Bool
== :: EventMode -> EventMode -> Bool
$c/= :: EventMode -> EventMode -> Bool
/= :: EventMode -> EventMode -> Bool
Eq)

{- | Group suites by the project file that owns them, preserving first-
appearance order.

Grouping is what lets one @cabal test@ call cover a whole project's suites.
Suites are named explicitly rather than using cabal's @all@ target because
@cabal.project.schema-gen@ imports @cabal.project@, so @all@ under a variant
project file would re-run every suite in the repository.
-}
groupByProject :: [SuiteRef] -> [(Maybe FilePath, [SuiteRef])]
groupByProject :: [SuiteRef] -> [(Maybe String, [SuiteRef])]
groupByProject [SuiteRef]
srs =
  [(Maybe String
p, [SuiteRef
sr | SuiteRef
sr <- [SuiteRef]
srs, SuiteRef -> Maybe String
srProjectFile SuiteRef
sr Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
p]) | Maybe String
p <- [Maybe String]
projectsInOrder]
 where
  projectsInOrder :: [Maybe String]
projectsInOrder = [Maybe String] -> [Maybe String]
dedupe ((SuiteRef -> Maybe String) -> [SuiteRef] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map SuiteRef -> Maybe String
srProjectFile [SuiteRef]
srs)
  dedupe :: [Maybe String] -> [Maybe String]
dedupe = (Maybe String -> [Maybe String] -> [Maybe String])
-> [Maybe String] -> [Maybe String] -> [Maybe String]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Maybe String
x [Maybe String]
acc -> Maybe String
x Maybe String -> [Maybe String] -> [Maybe String]
forall a. a -> [a] -> [a]
: (Maybe String -> Bool) -> [Maybe String] -> [Maybe String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe String
x) [Maybe String]
acc) []

{- | Resolve the requested suite names against what was discovered.

An empty request means "everything", which is what makes @pbt-cli run@ with no
arguments the run-all-tests command.
-}
selectSuites :: [SuiteRef] -> [Text] -> Either String [SuiteRef]
selectSuites :: [SuiteRef] -> [Text] -> Either String [SuiteRef]
selectSuites [SuiteRef]
available [] = [SuiteRef] -> Either String [SuiteRef]
forall a b. b -> Either a b
Right [SuiteRef]
available
selectSuites [SuiteRef]
available [Text]
names = (Text -> Either String SuiteRef)
-> [Text] -> Either String [SuiteRef]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Text -> Either String SuiteRef
look [Text]
names
 where
  look :: Text -> Either String SuiteRef
look Text
n = case [SuiteRef
sr | SuiteRef
sr <- [SuiteRef]
available, TestSuite -> Text
tsName (SuiteRef -> TestSuite
srSuite SuiteRef
sr) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
n] of
    (SuiteRef
sr : [SuiteRef]
_) -> SuiteRef -> Either String SuiteRef
forall a b. b -> Either a b
Right SuiteRef
sr
    [] -> String -> Either String SuiteRef
forall a b. a -> Either a b
Left (String
"unknown test suite: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
n)

-- ---------------------------------------------------------------------------
-- threat-models
-- ---------------------------------------------------------------------------

doThreatModels :: ThreatModelsOpts -> IO ExitCode
doThreatModels :: ThreatModelsOpts -> IO ExitCode
doThreatModels ThreatModelsOpts
o =
  String
-> Text -> (String -> SuiteRef -> IO ExitCode) -> IO ExitCode
withStreamingSuite (ThreatModelsOpts -> String
tmoRoot ThreatModelsOpts
o) (ThreatModelsOpts -> Text
tmoSuite ThreatModelsOpts
o) ((String -> SuiteRef -> IO ExitCode) -> IO ExitCode)
-> (String -> SuiteRef -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \String
root SuiteRef
sr -> do
    Invocation
inv <- String -> SuiteRef -> TestOptions -> IO Invocation
invocationFor String
root SuiteRef
sr TestOptions
noTestOptions{toListThreatModels = True}
    if ThreatModelsOpts -> Bool
tmoDryRun ThreatModelsOpts
o
      then [Invocation] -> IO ExitCode
dryRun [Invocation
inv]
      else do
        (ExitCode
code, [ByteString]
ls) <- Invocation -> IO (ExitCode, [ByteString])
runCapture Invocation
inv
        case [ByteString] -> [KeyMap Value]
threatModelPayloads [ByteString]
ls of
          (KeyMap Value
payload : [KeyMap Value]
_) -> do
            if ThreatModelsOpts -> Bool
tmoJson ThreatModelsOpts
o
              then ByteString -> IO ()
LBS8.putStr (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodeJsonPretty (KeyMap Value -> Value
Object KeyMap Value
payload))
              else case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"threatModels" KeyMap Value
payload of
                Just (Array Array
names) -> Array -> (Value -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Array
names Value -> IO ()
printName
                Maybe Value
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitOk
          [] -> do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"pbt-cli: "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (TestSuite -> Text
tsName (SuiteRef -> TestSuite
srSuite SuiteRef
sr))
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" did not report any threat models. Suites get "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"--list-threat-models-json from defaultMainTestingInterface; a suite using "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"plain defaultMainStreaming does not have it."
            ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExitCode -> ExitCode -> ExitCode
worstOf ExitCode
code ExitCode
exitFailed)
 where
  printName :: Value -> IO ()
printName = \case
    String Text
t -> Text -> IO ()
TextIO.putStrLn Text
t
    Value
other -> ByteString -> IO ()
LBS8.putStrLn (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodeJsonCompact Value
other)

-- | The @{"threatModels": [...]}@ objects among a run's stdout lines.
threatModelPayloads :: [BS8.ByteString] -> [KeyMap.KeyMap Value]
threatModelPayloads :: [ByteString] -> [KeyMap Value]
threatModelPayloads [ByteString]
ls =
  [ KeyMap Value
km
  | ByteString
l <- (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter ByteString -> Bool
isJsonObjectLine [ByteString]
ls
  , Just (Object KeyMap Value
km) <- [ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict' ByteString
l]
  , Key -> KeyMap Value -> Bool
forall a. Key -> KeyMap a -> Bool
KeyMap.member Key
"threatModels" KeyMap Value
km
  ]

-- ---------------------------------------------------------------------------
-- Shared plumbing
-- ---------------------------------------------------------------------------

{- | Discover @root@ and hand the result to @k@, or fail with exit code 3.

Discovery is checked up front for every command, including the ones that end
up shelling out to cabal, so a mistyped @--root@ is reported as such instead of
surfacing as a confusing cabal error.
-}
withDiscovery :: FilePath -> (Discovery -> IO ExitCode) -> IO ExitCode
withDiscovery :: String -> (Discovery -> IO ExitCode) -> IO ExitCode
withDiscovery String
root Discovery -> IO ExitCode
k = do
  Bool
ok <- String -> IO Bool
doesDirectoryExist String
root
  if Bool -> Bool
not Bool
ok
    then do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"pbt-cli: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
root String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a directory")
      ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitDiscovery
    else String -> IO Discovery
discover String
root IO Discovery -> (Discovery -> IO ExitCode) -> IO ExitCode
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Discovery -> IO ExitCode
k

{- | Resolve a suite name and require that it is sc-testing-tools compatible.

The three commands that need structured output (@tests@, @stream@,
@threat-models@) all depend on ingredients only @convex-tasty-streaming@
provides, so pointing them at an upstream-tasty suite can only fail. Failing
here, with the suite's actual classification in the message, beats letting
cabal run a suite that will ignore the flag and exit 0.
-}
withStreamingSuite :: FilePath -> Text -> (FilePath -> SuiteRef -> IO ExitCode) -> IO ExitCode
withStreamingSuite :: String
-> Text -> (String -> SuiteRef -> IO ExitCode) -> IO ExitCode
withStreamingSuite String
root Text
name String -> SuiteRef -> IO ExitCode
k =
  String -> (Discovery -> IO ExitCode) -> IO ExitCode
withDiscovery String
root ((Discovery -> IO ExitCode) -> IO ExitCode)
-> (Discovery -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \Discovery
d -> do
    let available :: [SuiteRef]
available = Discovery -> [SuiteRef]
flattenSuites Discovery
d
    case [SuiteRef
sr | SuiteRef
sr <- [SuiteRef]
available, TestSuite -> Text
tsName (SuiteRef -> TestSuite
srSuite SuiteRef
sr) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name] of
      [] -> String -> [SuiteRef] -> IO ExitCode
usageError (String
"unknown test suite: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
name) [SuiteRef]
available
      (SuiteRef
sr : [SuiteRef]
_)
        | Bool -> Bool
not (TestSuite -> Bool
isCompatible (SuiteRef -> TestSuite
srSuite SuiteRef
sr)) -> do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"pbt-cli: "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
name
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not sc-testing-tools compatible (entry point: "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (EntryPoint -> Text
entryPointText (TestSuite -> EntryPoint
tsEntryPoint (SuiteRef -> TestSuite
srSuite SuiteRef
sr)))
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"). Structured discovery and streaming come from "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"convex-tasty-streaming; use 'pbt-cli run "
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
name
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' to run it as a plain tasty suite."
            ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitUsage
        | Bool
otherwise -> do
            String
absRoot <- String -> IO String
makeAbsolute String
root
            String -> SuiteRef -> IO ExitCode
k String
absRoot SuiteRef
sr

invocationFor :: FilePath -> SuiteRef -> TestOptions -> IO Invocation
invocationFor :: String -> SuiteRef -> TestOptions -> IO Invocation
invocationFor String
root SuiteRef
sr TestOptions
opts = do
  String
cabal <- IO String
findCabal
  Invocation -> IO Invocation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
-> String -> Maybe String -> [String] -> TestOptions -> Invocation
testInvocation String
cabal String
root (SuiteRef -> Maybe String
srProjectFile SuiteRef
sr) [Text -> String
Text.unpack (TestSuite -> Text
tsName (SuiteRef -> TestSuite
srSuite SuiteRef
sr))] TestOptions
opts)

filterOptions :: Filters -> TestOptions
filterOptions :: Filters -> TestOptions
filterOptions Filters
f =
  TestOptions
noTestOptions
    { toPattern = fltPattern f
    , toTestIds = fltTestIds f
    , toThreatModelName = fltThreatModelName f
    , toExtra = fltTestOption f
    }

dryRun :: [Invocation] -> IO ExitCode
dryRun :: [Invocation] -> IO ExitCode
dryRun [Invocation]
invs = do
  (Invocation -> IO ()) -> [Invocation] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> (Invocation -> String) -> Invocation -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Invocation -> String
renderCommand) [Invocation]
invs
  ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitOk

usageError :: String -> [SuiteRef] -> IO ExitCode
usageError :: String -> [SuiteRef] -> IO ExitCode
usageError String
msg [SuiteRef]
available = do
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"pbt-cli: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SuiteRef] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SuiteRef]
available) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"known test suites:"
    [SuiteRef] -> (SuiteRef -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SuiteRef]
available ((SuiteRef -> IO ()) -> IO ()) -> (SuiteRef -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SuiteRef
sr ->
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"  "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (TestSuite -> Text
tsName (SuiteRef -> TestSuite
srSuite SuiteRef
sr))
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (if TestSuite -> Bool
isCompatible (SuiteRef -> TestSuite
srSuite SuiteRef
sr) then String
"  (sc-testing-tools compatible)" else String
"")
  ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitUsage

-- | The most severe of a list of exit codes; success only if all succeeded.
worst :: [ExitCode] -> ExitCode
worst :: [ExitCode] -> ExitCode
worst = (ExitCode -> ExitCode -> ExitCode)
-> ExitCode -> [ExitCode] -> ExitCode
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ExitCode -> ExitCode -> ExitCode
worstOf ExitCode
exitOk

worstOf :: ExitCode -> ExitCode -> ExitCode
worstOf :: ExitCode -> ExitCode -> ExitCode
worstOf ExitCode
ExitSuccess ExitCode
b = ExitCode
b
worstOf ExitCode
a ExitCode
_ = ExitCode
a