module System.Process.Quick.CallSpec.Verify where

import Control.Monad.Writer.Strict hiding (lift)
import Data.Conduit ( runConduitRes, (.|) )
import Data.Conduit.Find as F
import Data.Conduit.List qualified as DCL
import Debug.TraceEmbrace
import Language.Haskell.TH.Syntax
import System.Directory
import System.Exit hiding (exitFailure)
import System.FilePath (getSearchPath, takeDirectory, takeExtension)
import System.IO.Temp (withSystemTempDirectory)
import System.Process (readProcessWithExitCode)
import System.Process.Quick.CallEffect
import System.Process.Quick.CallSpec
import System.Process.Quick.Predicate
import System.Process.Quick.Predicate.InFile ()
import System.Process.Quick.Predicate.InDir ()
import System.Process.Quick.Prelude hiding (Type, lift)


type FailureReport = Doc

data CallSpecViolation
  = HelpKeyIgnored
  | HelpKeyNotSupported FailureReport
  | ProgramNotFound FailureReport [FilePath]
  | HelpKeyExitNonZero FailureReport
  | SandboxLaunchFailed FailureReport
  | UnexpectedCallEffect [CallEffect]
  deriving (Int -> CallSpecViolation -> ShowS
[CallSpecViolation] -> ShowS
CallSpecViolation -> String
(Int -> CallSpecViolation -> ShowS)
-> (CallSpecViolation -> String)
-> ([CallSpecViolation] -> ShowS)
-> Show CallSpecViolation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CallSpecViolation -> ShowS
showsPrec :: Int -> CallSpecViolation -> ShowS
$cshow :: CallSpecViolation -> String
show :: CallSpecViolation -> String
$cshowList :: [CallSpecViolation] -> ShowS
showList :: [CallSpecViolation] -> ShowS
Show, CallSpecViolation -> CallSpecViolation -> Bool
(CallSpecViolation -> CallSpecViolation -> Bool)
-> (CallSpecViolation -> CallSpecViolation -> Bool)
-> Eq CallSpecViolation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CallSpecViolation -> CallSpecViolation -> Bool
== :: CallSpecViolation -> CallSpecViolation -> Bool
$c/= :: CallSpecViolation -> CallSpecViolation -> Bool
/= :: CallSpecViolation -> CallSpecViolation -> Bool
Eq)

data CsViolationWithCtx
  = forall cs. CallSpec cs
  => CsViolationWithCtx
     { ()
csContext :: cs
     , CsViolationWithCtx -> CallSpecViolation
csViolation :: CallSpecViolation
     }

type M m = (MonadMask m, MonadCatch m, MonadIO m)


callProcessSilently :: M m => FilePath -> [String] -> m (Maybe Doc)
callProcessSilently :: forall (m :: * -> *).
M m =>
String -> [String] -> m (Maybe FailureReport)
callProcessSilently String
p [String]
args =
  m (ExitCode, String, String)
-> m (Either IOException (ExitCode, String, String))
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either IOException a)
tryIO (IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
p [String]
args String
"")) m (Either IOException (ExitCode, String, String))
-> (Either IOException (ExitCode, String, String)
    -> m (Maybe FailureReport))
-> m (Maybe FailureReport)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left IOException
e ->
      Maybe FailureReport -> m (Maybe FailureReport)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FailureReport -> m (Maybe FailureReport))
-> (FailureReport -> Maybe FailureReport)
-> FailureReport
-> m (Maybe FailureReport)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureReport -> Maybe FailureReport
forall a. a -> Maybe a
Just (FailureReport -> m (Maybe FailureReport))
-> FailureReport -> m (Maybe FailureReport)
forall a b. (a -> b) -> a -> b
$ FailureReport
"Command: [" FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> String -> FailureReport
forall a. Pretty a => a -> FailureReport
doc String
p FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
" " FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> [String] -> FailureReport
forall a. Pretty a => [a] -> FailureReport
hsep (ShowS
escArg ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
args) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
"]" FailureReport -> FailureReport -> FailureReport
$$
      FailureReport
"Failed due:" FailureReport -> FailureReport -> FailureReport
$$ IOException -> FailureReport
forall a. Pretty a => a -> FailureReport
tab IOException
e

    Right (ExitCode
ExitSuccess, String
_, String
_) -> Maybe FailureReport -> m (Maybe FailureReport)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FailureReport
forall a. Maybe a
Nothing
    Right (ExitFailure Int
ec, String
out, String
err) ->
      Maybe FailureReport -> m (Maybe FailureReport)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FailureReport -> m (Maybe FailureReport))
-> (FailureReport -> Maybe FailureReport)
-> FailureReport
-> m (Maybe FailureReport)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureReport -> Maybe FailureReport
forall a. a -> Maybe a
Just (FailureReport -> m (Maybe FailureReport))
-> FailureReport -> m (Maybe FailureReport)
forall a b. (a -> b) -> a -> b
$ FailureReport
"Command: [" FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> String -> FailureReport
forall a. Pretty a => a -> FailureReport
doc String
p FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
" " FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> [String] -> FailureReport
forall a. Pretty a => [a] -> FailureReport
hsep (ShowS
escArg ShowS -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
args) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
"]" FailureReport -> FailureReport -> FailureReport
$$
      (if Int
ec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then FailureReport
"Exited with: " FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> Int -> FailureReport
forall b a. (Show a, IsString b) => a -> b
show Int
ec FailureReport -> FailureReport -> FailureReport
$$ FailureReport
"" else FailureReport
"")
      FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> String
out String -> (FailureReport -> FailureReport) -> FailureReport
forall a.
(IsEmpty a, Pretty a) =>
a -> (FailureReport -> FailureReport) -> FailureReport
&! ((FailureReport
"Output: " FailureReport -> FailureReport -> FailureReport
<+>) (FailureReport -> FailureReport)
-> (FailureReport -> FailureReport)
-> FailureReport
-> FailureReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureReport -> FailureReport
forall a. Pretty a => a -> FailureReport
tab) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> String
err String -> (FailureReport -> FailureReport) -> FailureReport
forall a.
(IsEmpty a, Pretty a) =>
a -> (FailureReport -> FailureReport) -> FailureReport
&! ((FailureReport
"StdErr: " FailureReport -> FailureReport -> FailureReport
<+>) (FailureReport -> FailureReport)
-> (FailureReport -> FailureReport)
-> FailureReport
-> FailureReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureReport -> FailureReport
forall a. Pretty a => a -> FailureReport
tab)

verifyWithActiveMethods ::
  forall w m cs. (M m, CallSpec cs, WriterT [FilePath] m ~ w) =>
  ArgCollector w ->
  ArgCollector w ->
  Set VerificationMethod ->
  Proxy cs ->
  Int ->
  m [CsViolationWithCtx]
verifyWithActiveMethods :: forall (w :: * -> *) (m :: * -> *) cs.
(M m, CallSpec cs, WriterT [String] m ~ w) =>
ArgCollector w
-> ArgCollector w
-> Set VerificationMethod
-> Proxy cs
-> Int
-> m [CsViolationWithCtx]
verifyWithActiveMethods ArgCollector w
inArgLocators ArgCollector w
outArgLocators Set VerificationMethod
activeVerMethods Proxy cs
pcs Int
iterations =
  [Maybe CsViolationWithCtx] -> [CsViolationWithCtx]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CsViolationWithCtx] -> [CsViolationWithCtx])
-> m [Maybe CsViolationWithCtx] -> m [CsViolationWithCtx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VerificationMethod -> m (Maybe CsViolationWithCtx))
-> [VerificationMethod] -> m [Maybe CsViolationWithCtx]
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 VerificationMethod -> m (Maybe CsViolationWithCtx)
go  ((VerificationMethod -> Bool)
-> [VerificationMethod] -> [VerificationMethod]
forall a. (a -> Bool) -> [a] -> [a]
filter (VerificationMethod -> Set VerificationMethod -> Bool
forall a. Ord a => a -> Set a -> Bool
`member` Set VerificationMethod
activeVerMethods) (Proxy cs -> [VerificationMethod]
forall cs. CallSpec cs => Proxy cs -> [VerificationMethod]
verificationMethods Proxy cs
pcs))
  where
    go :: VerificationMethod -> m (Maybe CsViolationWithCtx)
go = \case
      VerificationMethod
TrailingHelpValidate -> Proxy cs -> Int -> m (Maybe CsViolationWithCtx)
forall (m :: * -> *) cs.
(M m, CallSpec cs) =>
Proxy cs -> Int -> m (Maybe CsViolationWithCtx)
verifyTrailingHelp Proxy cs
pcs Int
iterations
      VerificationMethod
SandboxValidate -> ArgCollector (WriterT [String] m)
-> ArgCollector (WriterT [String] m)
-> Proxy cs
-> Int
-> m (Maybe CsViolationWithCtx)
forall (w :: * -> *) (m :: * -> *) cs.
(M m, CallSpec cs, WriterT [String] m ~ w) =>
ArgCollector w
-> ArgCollector w
-> Proxy cs
-> Int
-> m (Maybe CsViolationWithCtx)
validateInSandbox v -> w v
v -> WriterT [String] m v
ArgCollector w
ArgCollector (WriterT [String] m)
forall v. Data v => v -> w v
inArgLocators v -> w v
v -> WriterT [String] m v
ArgCollector w
ArgCollector (WriterT [String] m)
forall v. Data v => v -> w v
outArgLocators Proxy cs
pcs Int
iterations

-- |Compose a list of monadic actions into one action.  Composes using
-- ('>=>') - that is, the output of each action is fed to the input of
-- the one after it in the list.
concatM :: (Monad m) => [a -> m a] -> (a -> m a)
concatM :: forall (m :: * -> *) a. Monad m => [a -> m a] -> a -> m a
concatM [a -> m a]
fs = ((a -> m a) -> (a -> m a) -> a -> m a)
-> (a -> m a) -> [a -> m a] -> a -> m a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> m a) -> (a -> m a) -> a -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
(>=>) a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a -> m a]
fs

validateInSandbox ::
  forall w m cs. (M m, CallSpec cs, WriterT [FilePath] m ~ w) =>
  ArgCollector w ->
  ArgCollector w ->
  Proxy cs ->
  Int ->
  m (Maybe CsViolationWithCtx)
validateInSandbox :: forall (w :: * -> *) (m :: * -> *) cs.
(M m, CallSpec cs, WriterT [String] m ~ w) =>
ArgCollector w
-> ArgCollector w
-> Proxy cs
-> Int
-> m (Maybe CsViolationWithCtx)
validateInSandbox ArgCollector w
inArgLocators ArgCollector w
outArgLocators Proxy cs
pcs !Int
iterations
  | Int
iterations Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CsViolationWithCtx
forall a. Maybe a
Nothing
  | Bool
otherwise =
    String
-> (String -> m (Maybe CsViolationWithCtx))
-> m (Maybe CsViolationWithCtx)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"quick-process" String -> m (Maybe CsViolationWithCtx)
go m (Maybe CsViolationWithCtx)
-> (Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx))
-> m (Maybe CsViolationWithCtx)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe CsViolationWithCtx
Nothing -> ArgCollector (WriterT [String] m)
-> ArgCollector (WriterT [String] m)
-> Proxy cs
-> Int
-> m (Maybe CsViolationWithCtx)
forall (w :: * -> *) (m :: * -> *) cs.
(M m, CallSpec cs, WriterT [String] m ~ w) =>
ArgCollector w
-> ArgCollector w
-> Proxy cs
-> Int
-> m (Maybe CsViolationWithCtx)
validateInSandbox v -> w v
v -> WriterT [String] m v
ArgCollector w
ArgCollector (WriterT [String] m)
forall v. Data v => v -> w v
inArgLocators v -> w v
v -> WriterT [String] m v
ArgCollector w
ArgCollector (WriterT [String] m)
forall v. Data v => v -> w v
outArgLocators Proxy cs
pcs (Int -> m (Maybe CsViolationWithCtx))
-> Int -> m (Maybe CsViolationWithCtx)
forall a b. (a -> b) -> a -> b
$ Int
iterations Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      Just CsViolationWithCtx
e -> Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx))
-> Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx)
forall a b. (a -> b) -> a -> b
$ CsViolationWithCtx -> Maybe CsViolationWithCtx
forall a. a -> Maybe a
Just CsViolationWithCtx
e
  where
    checkFilesExist :: cs -> [String] -> IO (Maybe CsViolationWithCtx)
checkFilesExist cs
cs [String]
outFiles = do
      (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> (Bool -> Bool) -> Bool -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> IO Bool) -> (String -> IO Bool) -> String -> IO Bool
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> IO Bool
doesFileExist) [String]
outFiles IO [String]
-> ([String] -> IO (Maybe CsViolationWithCtx))
-> IO (Maybe CsViolationWithCtx)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> Maybe CsViolationWithCtx -> IO (Maybe CsViolationWithCtx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CsViolationWithCtx
forall a. Maybe a
Nothing
        [String]
ne -> Maybe CsViolationWithCtx -> IO (Maybe CsViolationWithCtx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CsViolationWithCtx -> IO (Maybe CsViolationWithCtx))
-> (CallSpecViolation -> Maybe CsViolationWithCtx)
-> CallSpecViolation
-> IO (Maybe CsViolationWithCtx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CsViolationWithCtx -> Maybe CsViolationWithCtx
forall a. a -> Maybe a
Just (CsViolationWithCtx -> Maybe CsViolationWithCtx)
-> (CallSpecViolation -> CsViolationWithCtx)
-> CallSpecViolation
-> Maybe CsViolationWithCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. cs -> CallSpecViolation -> CsViolationWithCtx
forall cs.
CallSpec cs =>
cs -> CallSpecViolation -> CsViolationWithCtx
CsViolationWithCtx cs
cs (CallSpecViolation -> IO (Maybe CsViolationWithCtx))
-> CallSpecViolation -> IO (Maybe CsViolationWithCtx)
forall a b. (a -> b) -> a -> b
$
          [CallEffect] -> CallSpecViolation
UnexpectedCallEffect
          [ FsEffect -> CallEffect
FsEffect (FsEffect -> CallEffect)
-> ([FsEffect] -> FsEffect) -> [FsEffect] -> CallEffect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FsEffect] -> FsEffect
FsAnd ([FsEffect] -> CallEffect) -> [FsEffect] -> CallEffect
forall a b. (a -> b) -> a -> b
$ (String -> FsEffect) -> [String] -> [FsEffect]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FsEffect -> FsEffect
FsNot (FsEffect -> FsEffect)
-> (String -> FsEffect) -> String -> FsEffect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [FsPredicate] -> FsEffect)
-> [FsPredicate] -> String -> FsEffect
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [FsPredicate] -> FsEffect
FsPathPredicate [FsPredicate
FsExists]) [String]
ne
          ]

    findOriginFor :: String -> String -> IO (Maybe String)
findOriginFor String
projectDir String
inFile = do
      xs :: [FilePath] <- ConduitT () Void (ResourceT IO) [String] -> IO [String]
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (ConduitT () Void (ResourceT IO) [String] -> IO [String])
-> ConduitT () Void (ResourceT IO) [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$
        String
-> CondT FileEntry (ResourceT IO) ()
-> ConduitT () String (ResourceT IO) ()
forall (m :: * -> *) a i.
MonadResource m =>
String -> CondT FileEntry m a -> ConduitT i String m ()
F.find String
projectDir (do CondT FileEntry (ResourceT IO) ()
forall (m :: * -> *). Monad m => CondT FileEntry m ()
ignoreVcs
                              String -> CondT FileEntry (ResourceT IO) ()
forall (m :: * -> *). Monad m => String -> CondT FileEntry m ()
glob (String -> CondT FileEntry (ResourceT IO) ())
-> String -> CondT FileEntry (ResourceT IO) ()
forall a b. (a -> b) -> a -> b
$ String
"*" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
takeExtension String
inFile
                              CondT FileEntry (ResourceT IO) ()
forall (m :: * -> *). MonadIO m => CondT FileEntry m ()
regular
                              CondT FileEntry (ResourceT IO) ()
-> CondT FileEntry (ResourceT IO) ()
forall (m :: * -> *) a b. Monad m => CondT a m b -> CondT a m ()
not_ CondT FileEntry (ResourceT IO) ()
forall (m :: * -> *). MonadIO m => CondT FileEntry m ()
F.executable) ConduitT () String (ResourceT IO) ()
-> ConduitT String Void (ResourceT IO) [String]
-> ConduitT () Void (ResourceT IO) [String]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT String Void (ResourceT IO) [String]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
DCL.consume
      case xs of
        [] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
        [String]
neXs -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String -> IO String
forall a. Gen a -> IO a
generate ([String] -> Gen String
forall a. [a] -> Gen a
elements [String]
neXs)

    genInputFile :: String -> String -> IO ()
genInputFile String
projectDir String
inFile = (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"/etc/hosts" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO (Maybe String)
findOriginFor String
projectDir String
inFile) IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      \String
origin -> Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
inFile) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                 String -> String -> IO ()
copyFile String
origin String
inFile
                 -- putStrLn ("File "  <> show origin <> " => " <> show inFile)

    doIn :: String -> () -> m (Maybe CsViolationWithCtx)
doIn String
projectDir () = do
      cs <- IO cs -> m cs
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Gen cs -> IO cs
forall a. Gen a -> IO a
generate (forall a. Arbitrary a => Gen a
arbitrary @cs))
      inFiles <- execWriterT (gmapM inArgLocators cs)
      -- absolute path is an issue for generator
      -- though process in docker is run under root - high chance to pass ;)
      -- quick hack is to use  odd size in Gen to avoid absolute path it Sandbox mode
      mapM_ (liftIO1 (genInputFile projectDir)) inFiles
      callProcessSilently (programName (pure cs)) (programArgs cs) >>= \case
        Maybe FailureReport
Nothing -> do
          outFiles <- WriterT [String] m cs -> m [String]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT ((forall d. Data d => d -> WriterT [String] m d)
-> cs -> WriterT [String] m cs
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> cs -> m cs
gmapM d -> w d
d -> WriterT [String] m d
ArgCollector w
forall v. Data v => v -> w v
forall d. Data d => d -> WriterT [String] m d
outArgLocators cs
cs)
          liftIO (checkFilesExist cs outFiles)
        Just FailureReport
e -> Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx))
-> (CallSpecViolation -> Maybe CsViolationWithCtx)
-> CallSpecViolation
-> m (Maybe CsViolationWithCtx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CsViolationWithCtx -> Maybe CsViolationWithCtx
forall a. a -> Maybe a
Just (CsViolationWithCtx -> Maybe CsViolationWithCtx)
-> (CallSpecViolation -> CsViolationWithCtx)
-> CallSpecViolation
-> Maybe CsViolationWithCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. cs -> CallSpecViolation -> CsViolationWithCtx
forall cs.
CallSpec cs =>
cs -> CallSpecViolation -> CsViolationWithCtx
CsViolationWithCtx cs
cs (CallSpecViolation -> m (Maybe CsViolationWithCtx))
-> CallSpecViolation -> m (Maybe CsViolationWithCtx)
forall a b. (a -> b) -> a -> b
$ FailureReport -> CallSpecViolation
SandboxLaunchFailed FailureReport
e
    go :: String -> m (Maybe CsViolationWithCtx)
go String
tdp = do
      projectDir <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory
      bracket
        (liftIO $ setCurrentDirectory tdp)
        (\() -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
projectDir)
        (doIn projectDir)

verifyTrailingHelp ::
  forall m cs. (M m, CallSpec cs) =>
  Proxy cs ->
  Int ->
  m (Maybe CsViolationWithCtx)
verifyTrailingHelp :: forall (m :: * -> *) cs.
(M m, CallSpec cs) =>
Proxy cs -> Int -> m (Maybe CsViolationWithCtx)
verifyTrailingHelp Proxy cs
pcs Int
iterations =
  IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
findExecutable String
progName) m (Maybe String)
-> (Maybe String -> m (Maybe CsViolationWithCtx))
-> m (Maybe CsViolationWithCtx)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> do
      cs <- m cs
genCs
      Just . CsViolationWithCtx cs . ProgramNotFound (text progName) <$> liftIO getSearchPath
    Just String
_ -> do
      String
-> [String]
-> m (Maybe CsViolationWithCtx)
-> (FailureReport -> m (Maybe CsViolationWithCtx))
-> m (Maybe CsViolationWithCtx)
forall {m :: * -> *} {b}.
(MonadIO m, MonadMask m) =>
String -> [String] -> m b -> (FailureReport -> m b) -> m b
spCmd String
progName [String]
helpKey
        (String
-> [String]
-> m (Maybe CsViolationWithCtx)
-> (FailureReport -> m (Maybe CsViolationWithCtx))
-> m (Maybe CsViolationWithCtx)
forall {m :: * -> *} {b}.
(MonadIO m, MonadMask m) =>
String -> [String] -> m b -> (FailureReport -> m b) -> m b
spCmd String
progName (String
"--hheellppaoesnthqkxsth" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
helpKey)
           (do cs <- m cs
genCs
               pure . Just $ CsViolationWithCtx cs HelpKeyIgnored)
           (\FailureReport
_ -> Int -> m (Maybe CsViolationWithCtx)
go Int
iterations))
        (\FailureReport
rep -> do
            cs <- m cs
genCs
            pure . Just . CsViolationWithCtx cs $ HelpKeyNotSupported rep)
  where
    progName :: String
progName = Proxy cs -> String
forall cs. CallSpec cs => Proxy cs -> String
programName Proxy cs
pcs
    genCs :: m cs
genCs = IO cs -> m cs
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Gen cs -> IO cs
forall a. Gen a -> IO a
generate (forall a. Arbitrary a => Gen a
arbitrary @cs))
    helpKey :: [String]
helpKey = [String
"--help"]
    spCmd :: String -> [String] -> m b -> (FailureReport -> m b) -> m b
spCmd String
pn [String]
args m b
onSuccess FailureReport -> m b
onFailure = do
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO $(trIo "spawn process/pn args")
      String -> [String] -> m (Maybe FailureReport)
forall (m :: * -> *).
M m =>
String -> [String] -> m (Maybe FailureReport)
callProcessSilently String
pn [String]
args m (Maybe FailureReport) -> (Maybe FailureReport -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe FailureReport
Nothing -> m b
onSuccess
        Just FailureReport
rep -> FailureReport -> m b
onFailure FailureReport
rep
    go :: Int -> m (Maybe CsViolationWithCtx)
go Int
n
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CsViolationWithCtx
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          cs <- IO cs -> m cs
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Gen cs -> IO cs
forall a. Gen a -> IO a
generate (forall a. Arbitrary a => Gen a
arbitrary @cs))
          spCmd (programName pcs) (programArgs cs <> helpKey)
            (go $ n - 1)
            (\FailureReport
rep -> Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe CsViolationWithCtx -> m (Maybe CsViolationWithCtx))
-> (CallSpecViolation -> Maybe CsViolationWithCtx)
-> CallSpecViolation
-> m (Maybe CsViolationWithCtx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CsViolationWithCtx -> Maybe CsViolationWithCtx
forall a. a -> Maybe a
Just (CsViolationWithCtx -> Maybe CsViolationWithCtx)
-> (CallSpecViolation -> CsViolationWithCtx)
-> CallSpecViolation
-> Maybe CsViolationWithCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. cs -> CallSpecViolation -> CsViolationWithCtx
forall cs.
CallSpec cs =>
cs -> CallSpecViolation -> CsViolationWithCtx
CsViolationWithCtx cs
cs (CallSpecViolation -> m (Maybe CsViolationWithCtx))
-> CallSpecViolation -> m (Maybe CsViolationWithCtx)
forall a b. (a -> b) -> a -> b
$ FailureReport -> CallSpecViolation
HelpKeyExitNonZero FailureReport
rep)


consumeViolations :: MonadIO m => [CsViolationWithCtx] -> m ()
consumeViolations :: forall (m :: * -> *). MonadIO m => [CsViolationWithCtx] -> m ()
consumeViolations = \case
  [] ->
    String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn String
"CallSpecs are valid"
  [CsViolationWithCtx]
vis -> do
    let dashes :: FailureReport
dashes = FailureReport
"-------------------------------------------------------------"
    -- good case for hetftio ??
    FailureReport -> m ()
forall (m :: * -> *). MonadIO m => FailureReport -> m ()
printDoc (FailureReport -> m ()) -> FailureReport -> m ()
forall a b. (a -> b) -> a -> b
$ FailureReport
"Error: quick-process found " FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> Int -> FailureReport
forall a. Pretty a => a -> FailureReport
doc ([CsViolationWithCtx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CsViolationWithCtx]
vis) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
" failed call specs:"
      FailureReport -> FailureReport -> FailureReport
$$ ([FailureReport] -> FailureReport
vcat ([FailureReport] -> FailureReport)
-> [FailureReport] -> FailureReport
forall a b. (a -> b) -> a -> b
$ (Int -> CsViolationWithCtx -> FailureReport)
-> [Int] -> [CsViolationWithCtx] -> [FailureReport]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i CsViolationWithCtx
v -> FailureReport -> FailureReport
forall a. Pretty a => a -> FailureReport
tab (FailureReport
"-- [" FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> Int -> FailureReport
forall a. Pretty a => a -> FailureReport
doc Int
i FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
"] " FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
dashes FailureReport -> FailureReport -> FailureReport
$$ CsViolationWithCtx -> FailureReport
printViolation CsViolationWithCtx
v))
                 [Int
1::Int ..] ([CsViolationWithCtx] -> [CsViolationWithCtx]
sortByProgamName [CsViolationWithCtx]
vis))
      FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
"---------" FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
dashes FailureReport -> FailureReport -> FailureReport
$$ FailureReport
"End of quick-process violation report"
    m ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
  where
    sortByProgamName :: [CsViolationWithCtx] -> [CsViolationWithCtx]
sortByProgamName = (CsViolationWithCtx -> String)
-> [CsViolationWithCtx] -> [CsViolationWithCtx]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (\(CsViolationWithCtx cs
x CallSpecViolation
_) -> Proxy cs -> String
forall cs. CallSpec cs => Proxy cs -> String
programName (Proxy cs -> String) -> Proxy cs -> String
forall a b. (a -> b) -> a -> b
$ cs -> Proxy cs
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure cs
x)
    printViolation :: CsViolationWithCtx -> FailureReport
printViolation (CsViolationWithCtx cs
cs CallSpecViolation
v) =
      case CallSpecViolation
v of
        CallSpecViolation
HelpKeyIgnored -> (String -> FailureReport
text (String -> FailureReport)
-> (Proxy cs -> String) -> Proxy cs -> FailureReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy cs -> String
forall cs. CallSpec cs => Proxy cs -> String
programName (Proxy cs -> FailureReport) -> Proxy cs -> FailureReport
forall a b. (a -> b) -> a -> b
$ cs -> Proxy cs
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure cs
cs) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
": help key ignored"
        ProgramNotFound FailureReport
report' [String]
pathCopy ->
          FailureReport
"[" FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> (String -> FailureReport
text (String -> FailureReport)
-> (Proxy cs -> String) -> Proxy cs -> FailureReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy cs -> String
forall cs. CallSpec cs => Proxy cs -> String
programName (Proxy cs -> FailureReport) -> Proxy cs -> FailureReport
forall a b. (a -> b) -> a -> b
$ cs -> Proxy cs
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure cs
cs) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
"] is not found on PATH:" FailureReport -> FailureReport -> FailureReport
$$ FailureReport -> FailureReport
forall a. Pretty a => a -> FailureReport
tab ([String] -> FailureReport
forall a. Pretty a => [a] -> FailureReport
vsep [String]
pathCopy)
           FailureReport -> FailureReport -> FailureReport
$$ FailureReport
"Report:" FailureReport -> FailureReport -> FailureReport
$$ FailureReport -> FailureReport
forall a. Pretty a => a -> FailureReport
tab FailureReport
report' FailureReport -> FailureReport -> FailureReport
$$ FailureReport
""
        HelpKeyNotSupported FailureReport
report' ->
          FailureReport
"--help key is not supported by [" FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> (String -> FailureReport
text (String -> FailureReport)
-> (Proxy cs -> String) -> Proxy cs -> FailureReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy cs -> String
forall cs. CallSpec cs => Proxy cs -> String
programName (Proxy cs -> FailureReport) -> Proxy cs -> FailureReport
forall a b. (a -> b) -> a -> b
$ cs -> Proxy cs
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure cs
cs) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
"]"
          FailureReport -> FailureReport -> FailureReport
$$ FailureReport
"Report:" FailureReport -> FailureReport -> FailureReport
$$ FailureReport -> FailureReport
forall a. Pretty a => a -> FailureReport
tab FailureReport
report'
        HelpKeyExitNonZero FailureReport
rep ->
          (String -> FailureReport
text (String -> FailureReport)
-> (Proxy cs -> String) -> Proxy cs -> FailureReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy cs -> String
forall cs. CallSpec cs => Proxy cs -> String
programName (Proxy cs -> FailureReport) -> Proxy cs -> FailureReport
forall a b. (a -> b) -> a -> b
$ cs -> Proxy cs
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure cs
cs) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
" - non zero exit code:" FailureReport -> FailureReport -> FailureReport
$$ FailureReport -> FailureReport
forall a. Pretty a => a -> FailureReport
tab FailureReport
rep
        SandboxLaunchFailed FailureReport
rep ->
          (String -> FailureReport
text (String -> FailureReport)
-> (Proxy cs -> String) -> Proxy cs -> FailureReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy cs -> String
forall cs. CallSpec cs => Proxy cs -> String
programName (Proxy cs -> FailureReport) -> Proxy cs -> FailureReport
forall a b. (a -> b) -> a -> b
$ cs -> Proxy cs
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure cs
cs) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
" - non zero exit code:" FailureReport -> FailureReport -> FailureReport
$$ FailureReport -> FailureReport
forall a. Pretty a => a -> FailureReport
tab FailureReport
rep
        UnexpectedCallEffect [CallEffect]
uce -> do
          (String -> FailureReport
text (String -> FailureReport)
-> (Proxy cs -> String) -> Proxy cs -> FailureReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy cs -> String
forall cs. CallSpec cs => Proxy cs -> String
programName (Proxy cs -> FailureReport) -> Proxy cs -> FailureReport
forall a b. (a -> b) -> a -> b
$ cs -> Proxy cs
forall a. a -> Proxy a
forall (f :: * -> *) a. Applicative f => a -> f a
pure cs
cs) FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> FailureReport
": has unsafisfied effects:" FailureReport -> FailureReport -> FailureReport
$$ (String -> FailureReport
text (String -> FailureReport) -> String -> FailureReport
forall a b. (a -> b) -> a -> b
$ [CallEffect] -> String
forall b a. (Show a, IsString b) => a -> b
show [CallEffect]
uce)
           FailureReport -> FailureReport -> FailureReport
$$ FailureReport
"With arguments: " FailureReport -> FailureReport -> FailureReport
forall a. Semigroup a => a -> a -> a
<> [String] -> FailureReport
forall a. Pretty a => a -> FailureReport
tab (cs -> [String]
forall cs. CallSpec cs => cs -> [String]
programArgs cs
cs)

discoverAndVerifyCallSpecs :: Set VerificationMethod -> Int -> Q Exp
discoverAndVerifyCallSpecs :: Set VerificationMethod -> Int -> Q Exp
discoverAndVerifyCallSpecs Set VerificationMethod
activeVerMethods Int
iterations = do
  inArgLocators <- [Dec] -> [Type]
extractInstanceType ([Dec] -> [Type]) -> Q [Dec] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Type] -> Q [Dec]
reifyInstances ''RefinedInArgLocator [Name -> Type
VarT (String -> Name
mkName String
"b")]
  when (inArgLocators == []) $ putStrLn "Discovered 0 InArg locators!!!"
  outArgLocators <- extractInstanceType <$> reifyInstances ''RefinedOutArgLocator [VarT (mkName "c")]
  when (outArgLocators == []) $ putStrLn "Discovered 0 OutArg locators!!!"
  ts <- extractInstanceType <$> reifyInstances ''CallSpec [VarT (mkName "a")]
  when (ts == []) $ putStrLn "Discovered 0 types with CallSpec instance!!!"
  [| fmap concat (sequence $(ListE <$> (mapM (genCsVerification inArgLocators outArgLocators) ts))) >>= consumeViolations |]
  where
    getLocator :: Name -> Type -> Exp
getLocator Name
n Type
t = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
n) (Exp -> Type -> Exp
SigE (Name -> Exp
ConE 'Proxy) (Type -> Type -> Type
AppT (Name -> Type
ConT ''Proxy) Type
t))

    pipeLocators :: Name -> [Type] -> Q Exp
    pipeLocators :: Name -> [Type] -> Q Exp
pipeLocators Name
locName [Type]
ts =
      [| concatM $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> ([Exp] -> Exp) -> [Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
ListE ([Exp] -> Q Exp) -> [Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Exp
getLocator Name
locName (Type -> Exp) -> [Type] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
ts) |]

    genCsVerification :: [Type] -> [Type] -> Type -> Q Exp
    genCsVerification :: [Type] -> [Type] -> Type -> Q Exp
genCsVerification [Type]
inArL [Type]
outArL Type
t =
      [| verifyWithActiveMethods
           $(Name -> [Type] -> Q Exp
pipeLocators 'locateRefinedInArg [Type]
inArL)
           $(Name -> [Type] -> Q Exp
pipeLocators 'locateRefinedOutArg [Type]
outArL)
           $(Set VerificationMethod -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Set VerificationMethod -> m Exp
lift Set VerificationMethod
activeVerMethods)
           $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
SigE (Name -> Exp
ConE 'Proxy) (Type -> Type -> Type
AppT (Name -> Type
ConT ''Proxy) Type
t))
           $(Int -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => Int -> m Exp
lift Int
iterations)
       |]
    extractInstanceType :: [Dec] -> [Type]
    extractInstanceType :: [Dec] -> [Type]
extractInstanceType = (Dec -> Maybe Type) -> [Dec] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Dec -> Maybe Type) -> [Dec] -> [Type])
-> (Dec -> Maybe Type) -> [Dec] -> [Type]
forall a b. (a -> b) -> a -> b
$ \case
      InstanceD Maybe Overlap
_ [Type]
_ (AppT Type
_ Type
t) [Dec]
_ ->
        Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
      Dec
_ -> Maybe Type
forall a. Maybe a
Nothing