content: {-
    Copyright (c) Meta Platforms, Inc. and affiliates.
    All rights reserved.
  
    This source code is licensed under the BSD-style license found in the
    LICENSE file in the root directory of this source tree.
  -}
  
  {-# LANGUAGE ApplicativeDo #-}
  
  --
  -- Simple snapshot testing framework for Glass methods
  --
  
  module Glean.Glass.Regression.Snapshot (
      mainGlassSnapshot,
      mainGlassSnapshotGeneric,
      mainGlassSnapshotXLang,
      Output, Getter
    ) where
  
  import Data.Aeson
  import qualified Data.Aeson as Aeson
  import qualified Data.Aeson.Types as Aeson ( parse )
  import Data.Default
  import Data.Foldable ( foldl' )
  import Data.List ( sort )
  import Data.Text ( Text )
  import System.Directory ( copyFile, listDirectory )
  import System.Exit ( ExitCode(ExitFailure, ExitSuccess) )
  import System.FilePath
  import System.IO.Temp (withSystemTempDirectory)
  import System.Process ( readProcessWithExitCode )
  import Options.Applicative hiding ( Success )
  import Test.HUnit ( Test(..), assertFailure )
  import qualified Data.Aeson.Encode.Pretty as J
  import qualified Data.ByteString as S
  import qualified Data.ByteString.Lazy as B
  import qualified Data.Map.Strict as Map
  import qualified Data.Yaml as Yaml
  import Util.List ( uniq )
  import Data.Either.Extra
  
  import qualified Thrift.Protocol
  import qualified Thrift.Protocol.JSON as Thrift
  
  import Glean ( Repo )
  import Glean.Indexer
  import Glean.LocalOrRemote ( LocalOrRemote )
  import Glean.Util.Some ( Some(..) )
  import Glean.Regression.Test
  import qualified Glean.Indexer as Glean
  
  import qualified Glean.Glass.Handler.Documents as Glass
  import qualified Glean.Glass.Handler.Symbols as Glass
  import qualified Glean.Glass.Handler.Cxx as Glass
  import Glean.Glass.Types as Glass
  import Glean.Glass.Env as Glass ( Env )
  import Glean.Glass.Regression.Util as Glass ( withTestEnv )
  import qualified Glean.Regression.Snapshot.Driver as Glean
  import qualified Glean.Glass.SymbolId as Glass
  import qualified Glean.Glass.SymbolId.Cxx.Parse as Cxx
  
  -- queries are just thrift method names, and the toJSON string of the
  -- args you want to pass
  data Query
    = Query {
        action :: Text, -- ^ name of glass.thrift method
        args :: Aeson.Value, -- json object of args to method
        request_args :: Maybe Aeson.Value -- json object of request args to method
    } deriving (Show)
  
  instance FromJSON Query where
    parseJSON = withObject "query" $ \v -> Query
      <$> v .: "action"
      <*> v .: "args"
      <*> v .:? "request_args"
  
  type Output = FilePath
  
  type Getter = IO (Some LocalOrRemote, Repo)
  
  data Config = Config
    { cfgReplace :: Bool
    , cfgIgnoreMatchingLines :: Maybe String
    }
  
  configParser :: Parser Config
  configParser = Config
    <$> switch
         ( long "replace"
        <> help "Replace the output file" )
    <*> optional (strOption
         ( long "ignore-matching-lines"
        <> metavar "REGEX"
        <> help "Ignore changes where all lines match the regex" ))
  
  findQueries :: FilePath -> IO (Map.Map String FilePath)
  findQueries root = do
    files <- listDirectory root
    return $ Map.fromList
      [ (takeBaseName file, root </> file)
      | file <- files
      , ".query" `isExtensionOf` file
      ]
  
  parseQuery :: FilePath -> IO Query
  parseQuery qfile = do
    r <- Yaml.decodeFileEither qfile
    case r of
      Left err -> error
        $ qfile ++ ": invalid query - " ++ Yaml.prettyPrintParseException err
      Right q ->
        return q
  
  mainGlassSnapshot
    :: String
    -> FilePath
    -> Glean.Indexer opts
    -> (Getter -> [Test])
    -> IO ()
  mainGlassSnapshot testName testRoot indexer extras =
    mainGlassSnapshot_ testName testRoot
      (Glean.driverFromIndexer indexer) extras
  
  mainGlassSnapshotGeneric
    :: String
    -> FilePath
    -> Glean.Driver opts
    -> (Getter -> [Test])
    -> IO ()
  mainGlassSnapshotGeneric testName testRoot driver extras =
    mainGlassSnapshot_ testName testRoot driver extras
  
  mainGlassSnapshot_
    :: String
    -> FilePath
    -> Glean.Driver opts
    -> (Getter -> [Test])
    -> IO ()
  mainGlassSnapshot_ testName testRoot driver extras = do
    qs <- findQueries testRoot
    withOutput cfgOutput $ \temp ->
      mainTestIndexGeneric driver configParser testName $ \config _ _ _ get ->
        TestList $ testAll config temp qs get : extras get
    where
      cfgOutput = Nothing
  
      withOutput (Just out) f = f out
      withOutput Nothing f = withSystemTempDirectory testName f
  
  mainGlassSnapshotXLang
    :: String
    -> FilePath
    -> (Glean.Driver opt, Text)
    -> (Indexer opts, Text)
    -> IO ()
  mainGlassSnapshotXLang testName testRoot driver indexer = do
    qs <- findQueries testRoot
    withOutput cfgOutput $ \temp ->
      mainTestIndexXlang driver indexer testName configParser $
        \config get -> TestList [testAll config temp qs get]
    where
      cfgOutput = Nothing
  
      withOutput (Just out) f = f out
      withOutput Nothing f = withSystemTempDirectory testName f
  
  testAll :: Config -> FilePath -> Map.Map String FilePath -> Getter -> Test
  testAll config outDir queries getter = TestList
    [ mkTest config getter name qfile outDir
    | (name, qfile) <- Map.toList queries
    ]
  
  mkTest :: Config -> Getter -> String -> FilePath -> FilePath -> Test
  mkTest Config{..} get name qfile tempDir = TestLabel name $ TestCase $ do
    query <- parseQuery qfile
    let actual = tempDir </> replaceExtension (takeFileName qfile) "out"
        expected = replaceExtension qfile "out"
    (backend, _repo) <- get
    Glass.withTestEnv backend $ \env -> do
      evalQuery env qfile query actual
      if cfgReplace
        then copyFile actual expected
        else diff actual expected cfgIgnoreMatchingLines
  
  
  evalQuery :: Glass.Env -> FilePath -> Query -> FilePath -> IO ()
  evalQuery glassEnv qFile Query{..} oFile = case action of
    "documentSymbolListX" -> withObjectArgs qFile oFile args request_args
      (\req opts -> Glass.documentSymbolListX glassEnv req opts)
    "documentSymbolIndex" -> withObjectArgs qFile oFile args request_args
      (\req opts -> Glass.documentSymbolIndex glassEnv req opts)
    "findReferenceRanges" -> withSymbolId oFile args
      (Glass.findReferenceRanges glassEnv)
    "symbolLocation" -> withSymbolId oFile args
      (Glass.symbolLocation glassEnv)
    "describeSymbol" -> withSymbolId oFile args
      (Glass.describeSymbol glassEnv)
    "resolveSymbols" -> withObjectArgs qFile oFile args request_args
      (Glass.resolveSymbols glassEnv)
    "searchSymbol" ->  withObjectArgs qFile oFile args request_args
      (Glass.searchSymbol glassEnv)
    "searchRelated" -> withObjectAndSymbolId qFile oFile args
      (Glass.searchRelated glassEnv)
    "searchRelatedNeighborhood" -> withSymbolId oFile args
      (\sym opts -> Glass.searchRelatedNeighborhood glassEnv sym opts
         def { relatedNeighborhoodRequest_hide_uninteresting = True } )
    "fileIncludeLocations" -> withObjectArgs qFile oFile args request_args
      (Glass.fileIncludeLocations glassEnv)
    "usrToDefinition" -> withObjectArgs qFile oFile args request_args
      (\x y -> fst <$> Glass.usrToDefinition glassEnv x y)
    -- this lists all symbol ids in a file and then validates them
    -- wrapper for validating C++
    "validateCxxSymbolIds" -> withObjectArgs qFile oFile args request_args
      (validateCxxSymbols glassEnv)
  
    _ -> error $ "Invalid action: " <> show action
  
  -- | Take all the symbol ids and validate them as C++ symbol id syntax
  -- Return the errors and any successes as records
  validateCxxSymbols
    :: Env -> DocumentSymbolsRequest -> RequestOptions
    -> IO [Either [Text] Cxx.SymbolEnv]
  validateCxxSymbols glassEnv req def = do
    res <- Glass.documentSymbolListX glassEnv req def
    let defns = map Glass.definitionSymbolX_sym
          (Glass.documentSymbolListXResult_definitions res)
        refs = map Glass.referenceRangeSymbolX_sym
          (Glass.documentSymbolListXResult_references res)
        syms = uniq (defns ++ refs)
        toks = map getTokens (filter ((== Language_Cpp) . getLanguage) -- only cxx ids thx
                  (rights (map Glass.symbolTokens syms)))
        getLanguage (_, lang, _, _) = lang
        getTokens (_, _, tokens, _) = tokens
    return (map Cxx.validateSymbolId toks)
  
  decodeObjectAsThriftJson
    :: (Thrift.Protocol.ThriftStruct a, ToJSON a)
    => Aeson.Value -> Either String a
  decodeObjectAsThriftJson
    = Thrift.deserializeJSON . S.concat . B.toChunks. encode
  
  withSymbolId
    :: (ToJSON a, DeterministicResponse a)
    => FilePath -> Value -> (SymbolId -> RequestOptions -> IO a) -> IO ()
  withSymbolId oFile args f = do
    req <- case fromJSON args of
            Success sym -> pure (SymbolId sym)
            Error str -> assertFailure $ "Invalid SymbolId: " <> str
    res <- f req def
    writeResult oFile res
  
  withObjectArgs
   :: (Thrift.Protocol.ThriftSerializable req,
       Thrift.Protocol.ThriftSerializable opts,
       ToJSON a, Default opts, DeterministicResponse a)
   => FilePath
   -> FilePath
   -> Value
   -> Maybe Value
   -> (req -> opts -> IO a) -> IO ()
  withObjectArgs qFile oFile args rargs f = do
    req <- parseAsObject qFile args
    opts <- case rargs of
      Nothing -> return def
      Just rargs -> parseAsObject qFile rargs
    res <- f req opts
    writeResult oFile res
  
  withObjectAndSymbolId
   :: (Thrift.Protocol.ThriftStruct req,
      ToJSON req, ToJSON a, DeterministicResponse a)
   => FilePath
   -> FilePath
   -> Value
   -> (SymbolId -> RequestOptions -> req -> IO a) -> IO ()
  withObjectAndSymbolId qFile oFile args f = do
    let argParser = withObject "symbol-and-request" $ \o -> do
          sym <- o .: "symbol"
          req <- o .: "request"
          pure (SymbolId sym, req)
  
    (sym, rawReq) <- case Aeson.parse argParser args of
      Success (a, b) -> pure (a,b)
      Error str -> assertFailure $
          "Invalid json in " <> qFile <> " : " <> str
  
    req <- case decodeObjectAsThriftJson rawReq of
            Left str -> assertFailure $
              "Invalid args in " <> qFile <> " : " <> str
            Right req -> pure req
    res <- f sym def req
    writeResult oFile res
  
  parseAsObject
    :: (Thrift.Protocol.ThriftStruct a, ToJSON a) => String -> Value -> IO a
  parseAsObject file args = case decodeObjectAsThriftJson args of
    Left str -> assertFailure $ "Invalid args in " <> file <> " : " <> str
    Right req -> pure req
  
  writeResult :: (ToJSON a, DeterministicResponse a) => FilePath -> a -> IO ()
  writeResult oFile res = B.writeFile oFile content
    where
      generatedTag = '@':"generated"
      content = J.encodePretty' cfg (generatedTag,det res)
  
      cfg = J.defConfig {
        J.confCompare = compare
      }
  
  class DeterministicResponse a where
    det :: a -> a
  
  instance DeterministicResponse Revision where
    det _ = Revision "testhash"
  
  instance DeterministicResponse (Either [Text] Cxx.SymbolEnv) where
    det = id
  
  instance DeterministicResponse DocumentSymbolListXResult where
    det (DocumentSymbolListXResult refs defs _rev truncated digest fileMap
        contentMatch attributes) =
      DocumentSymbolListXResult (det refs) (det defs) (Revision "testhash")
        truncated
        digest
        fileMap
        -- n.b. don't want to include any test group revision tags
        contentMatch
        attributes
  
  instance DeterministicResponse DocumentSymbolIndex where
    det (DocumentSymbolIndex syms _rev size truncated digest fileMap
        contentMatch attributes) =
      DocumentSymbolIndex (Map.map sort syms) (Revision "testhash") size truncated
        digest
        fileMap
        contentMatch
        attributes
  
  instance DeterministicResponse SymbolSearchResult where
    det (SymbolSearchResult syms deets) =
      SymbolSearchResult (det syms) (det deets)
  
  instance (DeterministicResponse a, Ord a) => DeterministicResponse [a] where
    det = sort . map det
  
  instance DeterministicResponse Range where det = id
  instance DeterministicResponse LocationRange where det = id
  instance DeterministicResponse Glass.QualifiedName where det = id
  instance DeterministicResponse SymbolLocation where
    det (SymbolLocation loc _rev) = SymbolLocation (det loc) (Revision "testhash")
  
  instance DeterministicResponse SymbolResolution where
    det (SymbolResolution qname loc rev kind lang sig) =
      SymbolResolution (det qname) (det loc)
        (det rev) kind lang sig
  
  instance DeterministicResponse SearchRelatedResult where
    det (SearchRelatedResult xs ys) = -- to edit the desc hash
      SearchRelatedResult (det xs) (det ys)
  instance DeterministicResponse RelatedNeighborhoodResult where
    det (RelatedNeighborhoodResult as bs cs ds es fs gs hs is js) =
      RelatedNeighborhoodResult (det as) (det bs) (det cs) (det ds)
        (det es) (det fs) (det gs) (det hs) (det is) (det js)
  instance DeterministicResponse RelatedSymbols where
    det = id
  instance DeterministicResponse InheritedSymbols where
    det (InheritedSymbols a xs) = InheritedSymbols a (det xs)
  instance DeterministicResponse SymbolId where
    det = id
  instance DeterministicResponse DefinitionSymbolX where
    det = id
  instance DeterministicResponse ReferenceRangeSymbolX where
    det = id
  instance DeterministicResponse SymbolBasicDescription where
    det = id
  instance DeterministicResponse (Map.Map Text SymbolBasicDescription) where
    det = Map.map det
  instance DeterministicResponse SymbolDescription where
    det sd = sd
      { symbolDescription_repo_hash = Revision "testhash"
      , symbolDescription_contains_relation = Glass.RelationDescription
          { relationDescription_firstParent = Just $ SymbolId "nondeterministic"
          , relationDescription_firstChild = Just $ SymbolId "nondeterministic"
          , relationDescription_hasMoreChildren =
              relationDescription_hasMoreChildren $
                symbolDescription_contains_relation sd
          , relationDescription_hasMoreParents =
              relationDescription_hasMoreParents $
                symbolDescription_contains_relation sd
          , relationDescription_firstParentName = Nothing
          , relationDescription_firstChildName = Nothing
          }
      , symbolDescription_extends_relation = Glass.RelationDescription
          { relationDescription_firstParent = Just $ SymbolId "nondeterministic"
          , relationDescription_firstChild = Just $ SymbolId "nondeterministic"
          , relationDescription_hasMoreChildren =
             relationDescription_hasMoreChildren $
              symbolDescription_extends_relation sd
          , relationDescription_hasMoreParents =
             relationDescription_hasMoreParents $
              symbolDescription_extends_relation sd
          , relationDescription_firstParentName = Nothing
          , relationDescription_firstChildName = Nothing
          }
      }
  instance DeterministicResponse (Map.Map Text SymbolDescription) where
    det = Map.map det
  instance DeterministicResponse SymbolResult where
    det = id
  instance DeterministicResponse FileIncludeLocationResults where
    det (FileIncludeLocationResults _rev (XRefFileList refs)) =
      FileIncludeLocationResults
       (Revision "testhash")
       (XRefFileList (sort (map det refs)))
  instance DeterministicResponse FileIncludeXRef where
    det (FileIncludeXRef path incs) =
      FileIncludeXRef path (sort incs)
  
  instance DeterministicResponse SymbolResolutionFailure where
    det = id
  
  instance DeterministicResponse (Maybe SymbolResolutionFailure) where
    det Nothing = Nothing
    det (Just x) = Just (det x)
  
  instance DeterministicResponse ResolveSymbolsResult where
    det (ResolveSymbolsResult syms) =
      ResolveSymbolsResult (det syms)
  instance DeterministicResponse ResolvedSymbol where
    det (ResolvedSymbol sym resolutions failure) =
      ResolvedSymbol (det sym) (det resolutions) (det failure)
  instance DeterministicResponse USRSymbolDefinition where
    det (USRSymbolDefinition location sym revision) =
      USRSymbolDefinition (det location) (det sym) (det revision)
  
  diff :: FilePath -> FilePath -> Maybe String -> IO ()
  diff outGenerated outSpec ignoreMatchingLines = do
    let args =
          let outargs = [outGenerated, outSpec] in
          foldl' (\args l -> ("--ignore-matching-lines=" <> l) : args)
            outargs ignoreMatchingLines
    (e, sout, serr) <- readProcessWithExitCode "diff" args ""
    case e of
      ExitSuccess -> return ()
      ExitFailure n -> assertFailure $
        takeFileName outGenerated ++
          if n == 1
            then ": unexpected result\n" ++ sout
            else ": fatal error\n" ++ serr
  