{-# LANGUAGE OverloadedStrings #-}

{- | Constructing and running the @cabal test@ invocations that back every
@pbt-cli@ command.

Two details here are load-bearing.

First, custom test options are passed with repeated singular
@--test-option=@ flags, never the plural @--test-options=@. Cabal splits the
plural form on whitespace, so a Tasty pattern containing a space — which is
the common case, since Tasty group names have spaces — would arrive at the
test binary as several mangled arguments. The singular form appends one
argument verbatim.

Second, nothing here goes through a shell. Arguments are handed to the process
as a list, so patterns, redeemer names and paths need no quoting and cannot be
re-interpreted. 'renderCommand' exists only to *show* a copy-pasteable
equivalent for @--dry-run@ and error messages.
-}
module PbtCli.Cabal (
  -- * Invocations
  Invocation (..),
  testInvocation,
  renderCommand,

  -- * Test options
  TestOptions (..),
  noTestOptions,
  testOptionArgs,
  wantsStructuredOutput,

  -- * Running
  runInherit,
  runCapture,
  runStreaming,

  -- * Environment
  findCabal,
  CabalMissing (..),
) where

import Control.Exception (Exception, throwIO)
import Data.ByteString.Char8 qualified as BS8
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Maybe (catMaybes)
import System.Directory (findExecutable)
import System.Exit (ExitCode (..))
import System.IO (BufferMode (LineBuffering), hIsEOF, hSetBuffering)
import System.Process (
  CreateProcess (..),
  StdStream (CreatePipe, Inherit),
  proc,
  waitForProcess,
  withCreateProcess,
 )

-- | A resolved @cabal@ command line, ready to run.
data Invocation = Invocation
  { Invocation -> [Char]
invProgram :: FilePath
  -- ^ absolute path to @cabal@.
  , Invocation -> [[Char]]
invArgs :: [String]
  , Invocation -> Maybe [Char]
invWorkingDir :: Maybe FilePath
  }
  deriving (Invocation -> Invocation -> Bool
(Invocation -> Invocation -> Bool)
-> (Invocation -> Invocation -> Bool) -> Eq Invocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Invocation -> Invocation -> Bool
== :: Invocation -> Invocation -> Bool
$c/= :: Invocation -> Invocation -> Bool
/= :: Invocation -> Invocation -> Bool
Eq, Int -> Invocation -> ShowS
[Invocation] -> ShowS
Invocation -> [Char]
(Int -> Invocation -> ShowS)
-> (Invocation -> [Char])
-> ([Invocation] -> ShowS)
-> Show Invocation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Invocation -> ShowS
showsPrec :: Int -> Invocation -> ShowS
$cshow :: Invocation -> [Char]
show :: Invocation -> [Char]
$cshowList :: [Invocation] -> ShowS
showList :: [Invocation] -> ShowS
Show)

{- | Thrown when @cabal@ is not on @PATH@; @pbt-cli@ is a wrapper, not a build
system, so it cannot do anything useful without it.
-}
newtype CabalMissing = CabalMissing String
  deriving (Int -> CabalMissing -> ShowS
[CabalMissing] -> ShowS
CabalMissing -> [Char]
(Int -> CabalMissing -> ShowS)
-> (CabalMissing -> [Char])
-> ([CabalMissing] -> ShowS)
-> Show CabalMissing
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CabalMissing -> ShowS
showsPrec :: Int -> CabalMissing -> ShowS
$cshow :: CabalMissing -> [Char]
show :: CabalMissing -> [Char]
$cshowList :: [CabalMissing] -> ShowS
showList :: [CabalMissing] -> ShowS
Show)

instance Exception CabalMissing

-- | Locate @cabal@, or fail with an actionable message.
findCabal :: IO FilePath
findCabal :: IO [Char]
findCabal =
  [Char] -> IO (Maybe [Char])
findExecutable [Char]
"cabal" IO (Maybe [Char]) -> (Maybe [Char] -> IO [Char]) -> IO [Char]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just [Char]
p -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
p
    Maybe [Char]
Nothing ->
      CabalMissing -> IO [Char]
forall e a. Exception e => e -> IO a
throwIO (CabalMissing -> IO [Char])
-> ([Char] -> CabalMissing) -> [Char] -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> CabalMissing
CabalMissing ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$
        [Char]
"cabal was not found on PATH. pbt-cli drives `cabal test`, so it needs a "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"cabal installation (or a `nix develop` shell) to do anything beyond "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"`pbt-cli suites`, which is purely static."

-- | The custom test options @pbt-cli@ knows how to forward to a suite.
data TestOptions = TestOptions
  { TestOptions -> Bool
toStreamingJson :: Bool
  -- ^ @--streaming-json@: real-time NDJSON instead of console output.
  , TestOptions -> Bool
toListTestsJson :: Bool
  -- ^ @--list-tests-json@: dump the test tree and exit without running.
  , TestOptions -> Bool
toListThreatModels :: Bool
  -- ^ @--list-threat-models-json@: dump the threat models and exit.
  , TestOptions -> Maybe [Char]
toPattern :: Maybe String
  -- ^ Tasty's @-p@ pattern.
  , TestOptions -> Maybe [Char]
toTestIds :: Maybe String
  -- ^ @--test-id@, comma-separated ids from a previous discovery.
  , TestOptions -> Maybe [Char]
toThreatModelName :: Maybe String
  -- ^ @--threat-model-name@, comma-separated name prefixes.
  , TestOptions -> [[Char]]
toExtra :: [String]
  -- ^ anything else, passed through one argument at a time.
  }
  deriving (TestOptions -> TestOptions -> Bool
(TestOptions -> TestOptions -> Bool)
-> (TestOptions -> TestOptions -> Bool) -> Eq TestOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestOptions -> TestOptions -> Bool
== :: TestOptions -> TestOptions -> Bool
$c/= :: TestOptions -> TestOptions -> Bool
/= :: TestOptions -> TestOptions -> Bool
Eq, Int -> TestOptions -> ShowS
[TestOptions] -> ShowS
TestOptions -> [Char]
(Int -> TestOptions -> ShowS)
-> (TestOptions -> [Char])
-> ([TestOptions] -> ShowS)
-> Show TestOptions
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestOptions -> ShowS
showsPrec :: Int -> TestOptions -> ShowS
$cshow :: TestOptions -> [Char]
show :: TestOptions -> [Char]
$cshowList :: [TestOptions] -> ShowS
showList :: [TestOptions] -> ShowS
Show)

-- | No custom options: run the suite exactly as @cabal test@ would.
noTestOptions :: TestOptions
noTestOptions :: TestOptions
noTestOptions =
  TestOptions
    { toStreamingJson :: Bool
toStreamingJson = Bool
False
    , toListTestsJson :: Bool
toListTestsJson = Bool
False
    , toListThreatModels :: Bool
toListThreatModels = Bool
False
    , toPattern :: Maybe [Char]
toPattern = Maybe [Char]
forall a. Maybe a
Nothing
    , toTestIds :: Maybe [Char]
toTestIds = Maybe [Char]
forall a. Maybe a
Nothing
    , toThreatModelName :: Maybe [Char]
toThreatModelName = Maybe [Char]
forall a. Maybe a
Nothing
    , toExtra :: [[Char]]
toExtra = []
    }

{- | Render test options as @--test-option=@ flags.

Flags that take a value contribute two arguments (@--test-option=-p@ then
@--test-option=\<value\>@) because that is how Tasty's own parser reads them,
and it keeps values with spaces intact.
-}
testOptionArgs :: TestOptions -> [String]
testOptionArgs :: TestOptions -> [[Char]]
testOptionArgs TestOptions
to =
  [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
one [Char]
"--streaming-json" | TestOptions -> Bool
toStreamingJson TestOptions
to]
    , [ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
one [Char]
"--list-tests-json" | TestOptions -> Bool
toListTestsJson TestOptions
to]
    , [ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
one [Char]
"--list-threat-models-json" | TestOptions -> Bool
toListThreatModels TestOptions
to]
    , [Char] -> Maybe [Char] -> [[Char]]
forall {a}. (Semigroup a, IsString a) => a -> Maybe a -> [a]
pair [Char]
"-p" (TestOptions -> Maybe [Char]
toPattern TestOptions
to)
    , [Char] -> Maybe [Char] -> [[Char]]
forall {a}. (Semigroup a, IsString a) => a -> Maybe a -> [a]
pair [Char]
"--test-id" (TestOptions -> Maybe [Char]
toTestIds TestOptions
to)
    , [Char] -> Maybe [Char] -> [[Char]]
forall {a}. (Semigroup a, IsString a) => a -> Maybe a -> [a]
pair [Char]
"--threat-model-name" (TestOptions -> Maybe [Char]
toThreatModelName TestOptions
to)
    , ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
one (TestOptions -> [[Char]]
toExtra TestOptions
to)
    ]
 where
  one :: a -> a
one a
v = a
"--test-option=" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
v
  pair :: a -> Maybe a -> [a]
pair a
flag = [a] -> (a -> [a]) -> Maybe a -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\a
v -> [a -> a
forall {a}. (Semigroup a, IsString a) => a -> a
one a
flag, a -> a
forall {a}. (Semigroup a, IsString a) => a -> a
one a
v])

{- | Does this invocation need the suite's stdout on our pipe?

True for every mode that parses NDJSON off it. Used to decide whether to
override the project's @test-show-details@.
-}
wantsStructuredOutput :: TestOptions -> Bool
wantsStructuredOutput :: TestOptions -> Bool
wantsStructuredOutput TestOptions
to =
  TestOptions -> Bool
toStreamingJson TestOptions
to Bool -> Bool -> Bool
|| TestOptions -> Bool
toListTestsJson TestOptions
to Bool -> Bool -> Bool
|| TestOptions -> Bool
toListThreatModels TestOptions
to

{- | Build a @cabal test@ invocation.

@targets@ are suite names; passing several is what lets @pbt-cli run@ launch a
whole project's suites in one cabal call. An empty target list means @all@,
cabal's own everything-target.

For the structured modes this forces @--test-show-details=direct@. Cabal's
default streams the suite's stdout through, but a target repository is free to
set @test-show-details: failures@ or @never@ in its @cabal.project@ (or
@cabal.project.local@, or @~\/.cabal\/config@), and then cabal captures that
stdout into a log under @dist-newstyle@ and our pipe receives nothing at all --
so @run --json@ would exit 0 having emitted no events. pbt-cli owns the pipe,
so it owns the setting; a later flag on the command line wins over the project
file, which makes this a safe unconditional override.

@direct@ rather than @streaming@: both forward the suite's stdout, but
@streaming@ adds cabal's own per-test decoration, and the NDJSON modes want the
suite's bytes and nothing else. Plain @run@ is left alone -- it is a
pass-through of cabal's console output, so the project's own preference is the
right one there.
-}
testInvocation
  :: FilePath
  -- ^ @cabal@ executable
  -> FilePath
  -- ^ working directory (the repository root)
  -> Maybe FilePath
  -- ^ @--project-file@, when the suites are not in the default project
  -> [String]
  -- ^ @cabal test@ targets
  -> TestOptions
  -> Invocation
testInvocation :: [Char]
-> [Char] -> Maybe [Char] -> [[Char]] -> TestOptions -> Invocation
testInvocation [Char]
cabal [Char]
root Maybe [Char]
projectFile [[Char]]
targets TestOptions
to =
  Invocation
    { invProgram :: [Char]
invProgram = [Char]
cabal
    , invArgs :: [[Char]]
invArgs =
        [[Char]
"test"]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> (if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
targets then [[Char]
"all"] else [[Char]]
targets)
          [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes [([Char]
"--project-file=" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> Maybe [Char] -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
projectFile]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"--test-show-details=direct" | TestOptions -> Bool
wantsStructuredOutput TestOptions
to]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> TestOptions -> [[Char]]
testOptionArgs TestOptions
to
    , invWorkingDir :: Maybe [Char]
invWorkingDir = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
root
    }

{- | A copy-pasteable shell rendering of an invocation.

For display only — the real invocation never touches a shell. Arguments are
single-quoted when they contain anything that a shell would treat specially.
-}
renderCommand :: Invocation -> String
renderCommand :: Invocation -> [Char]
renderCommand Invocation
inv = [[Char]] -> [Char]
unwords (ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
shellQuote ([Char]
"cabal" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: Invocation -> [[Char]]
invArgs Invocation
inv))
 where
  shellQuote :: ShowS
shellQuote [Char]
s
    | (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
safe [Char]
s Bool -> Bool -> Bool
&& Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
s) = [Char]
s
    | Bool
otherwise = [Char]
"'" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Char -> [Char]) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
escapeQuote [Char]
s [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"'"

  safe :: Char -> Bool
safe Char
c = Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789./_-=:," :: String)

  escapeQuote :: Char -> [Char]
escapeQuote Char
'\'' = [Char]
"'\\''"
  escapeQuote Char
c = [Char
c]

{- | Run an invocation with the child's stdio connected straight to ours.

Used by @pbt-cli run@ so cabal's build progress and Tasty's console reporter
appear exactly as they would if the user had typed the cabal command.
-}
runInherit :: Invocation -> IO ExitCode
runInherit :: Invocation -> IO ExitCode
runInherit Invocation
inv =
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess (Invocation -> CreateProcess
processFor Invocation
inv) ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
 -> IO ExitCode)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
ph -> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph

{- | Run an invocation, collecting its stdout lines and letting stderr through.

stderr stays connected to ours on purpose: cabal reports build failures there,
and swallowing them would turn a compile error into a mystifying "no events"
result.
-}
runCapture :: Invocation -> IO (ExitCode, [BS8.ByteString])
runCapture :: Invocation -> IO (ExitCode, [ByteString])
runCapture Invocation
inv = do
  Collector
ref <- IO Collector
newCollector
  ExitCode
code <- Invocation -> (ByteString -> IO ()) -> IO ExitCode
runStreaming Invocation
inv (Collector -> ByteString -> IO ()
collect Collector
ref)
  [ByteString]
ls <- Collector -> IO [ByteString]
takeCollected Collector
ref
  (ExitCode, [ByteString]) -> IO (ExitCode, [ByteString])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExitCode
code, [ByteString]
ls)

{- | Run an invocation, handing each stdout line to a callback as it arrives.

The child's stdout is line-buffered and consumed incrementally, which is what
makes @pbt-cli stream@ actually live rather than a delayed dump at exit.
-}
runStreaming :: Invocation -> (BS8.ByteString -> IO ()) -> IO ExitCode
runStreaming :: Invocation -> (ByteString -> IO ()) -> IO ExitCode
runStreaming Invocation
inv ByteString -> IO ()
onLine =
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess (Invocation -> CreateProcess
processFor Invocation
inv){std_out = CreatePipe} ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
 -> IO ExitCode)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
mout Maybe Handle
_ ProcessHandle
ph ->
    case Maybe Handle
mout of
      Maybe Handle
Nothing -> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
      Just Handle
h -> do
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
        Handle -> IO ()
pump Handle
h
        ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
 where
  pump :: Handle -> IO ()
pump Handle
h = do
    Bool
eof <- Handle -> IO Bool
hIsEOF Handle
h
    if Bool
eof
      then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      else do
        ByteString
l <- Handle -> IO ByteString
BS8.hGetLine Handle
h
        ByteString -> IO ()
onLine ByteString
l
        Handle -> IO ()
pump Handle
h

processFor :: Invocation -> CreateProcess
processFor :: Invocation -> CreateProcess
processFor Invocation
inv =
  ([Char] -> [[Char]] -> CreateProcess
proc (Invocation -> [Char]
invProgram Invocation
inv) (Invocation -> [[Char]]
invArgs Invocation
inv))
    { cwd = invWorkingDir inv
    , std_in = Inherit
    , std_err = Inherit
    }

-- A tiny append-only line collector, so runCapture can build its result
-- without leaning on lazy IO.
newtype Collector = Collector (IORef [BS8.ByteString])

newCollector :: IO Collector
newCollector :: IO Collector
newCollector = IORef [ByteString] -> Collector
Collector (IORef [ByteString] -> Collector)
-> IO (IORef [ByteString]) -> IO Collector
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef []

collect :: Collector -> BS8.ByteString -> IO ()
collect :: Collector -> ByteString -> IO ()
collect (Collector IORef [ByteString]
r) ByteString
l = IORef [ByteString] -> ([ByteString] -> [ByteString]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [ByteString]
r (ByteString
l ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)

takeCollected :: Collector -> IO [BS8.ByteString]
takeCollected :: Collector -> IO [ByteString]
takeCollected (Collector IORef [ByteString]
r) = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [ByteString] -> IO [ByteString]
forall a. IORef a -> IO a
readIORef IORef [ByteString]
r