{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | The proto file descriptors served by the gRPC Server Reflection API,
-- compiled into this binary, plus a package-qualified symbol index over
-- their contents (services, methods, messages, fields, oneofs, enums and
-- enum values).
--
-- Every proto file cardano-rpc serves is represented here by one
-- 'FileEntry', keyed by the file name embedded in its own descriptor (e.g.
-- @"cardano/rpc/node.proto"@), which is also how dependent files refer to
-- it in their own @dependency@ list.
module Cardano.Rpc.Server.Internal.Reflection.DescriptorTable
  ( FileEntry (..)
  , DescriptorTable
  , descriptorTable
  , fileNames
  , lookupFile
  , lookupSymbol
  , transitiveClosure
  , fileSymbolNames
  )
where

import RIO

import Data.Map.Strict qualified as Map
import Data.ProtoLens (Message, packedFileDescriptor)
import Data.ProtoLens.Descriptor (fileDescriptor)
import Data.Set qualified as Set
import Data.Text qualified as Text

import Proto.Cardano.Rpc.Node (CurrentEra)
import Proto.Google.Protobuf.Descriptor
import Proto.Google.Protobuf.Descriptor_Fields qualified as Descriptor
import Proto.Google.Protobuf.Empty (Empty)
import Proto.Google.Protobuf.FieldMask (FieldMask)
import Proto.Grpc.Reflection.V1.Reflection qualified as ReflectionV1
import Proto.Grpc.Reflection.V1alpha.Reflection qualified as ReflectionV1alpha
import Proto.Utxorpc.V1beta.Cardano.Cardano (TxInput)
import Proto.Utxorpc.V1beta.Query.Query (ReadParamsRequest)
import Proto.Utxorpc.V1beta.Submit.Submit (SubmitTxRequest)
import Proto.Utxorpc.V1beta.Sync.Sync (FollowTipRequest)

-- | The descriptor table for every proto file this server's gRPC API is
-- built from: the six services it registers, plus the well-known
-- @google.protobuf@ types and the reflection protos themselves.
descriptorTable :: DescriptorTable
descriptorTable :: DescriptorTable
descriptorTable =
  DescriptorTable
    { descriptorTableFileIndex :: Map Text FileEntry
descriptorTableFileIndex =
        [(Text, FileEntry)] -> Map Text FileEntry
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FileEntry -> FileDescriptorProto
fileEntryDescriptor FileEntry
entry FileDescriptorProto
-> Getting Text FileDescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text FileDescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Descriptor.name, FileEntry
entry) | FileEntry
entry <- [FileEntry]
entries]
    , descriptorTableSymbolIndex :: Map Text Text
descriptorTableSymbolIndex =
        [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (Text
symbolName, FileEntry -> FileDescriptorProto
fileEntryDescriptor FileEntry
entry FileDescriptorProto
-> Getting Text FileDescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text FileDescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Descriptor.name)
          | FileEntry
entry <- [FileEntry]
entries
          , Text
symbolName <- FileDescriptorProto -> [Text]
fileSymbolNames (FileEntry -> FileDescriptorProto
fileEntryDescriptor FileEntry
entry)
          ]
    }
 where
  entries :: [FileEntry]
entries =
    [ forall msg. Message msg => FileEntry
mkFileEntry @CurrentEra
    , forall msg. Message msg => FileEntry
mkFileEntry @TxInput
    , forall msg. Message msg => FileEntry
mkFileEntry @ReadParamsRequest
    , forall msg. Message msg => FileEntry
mkFileEntry @SubmitTxRequest
    , forall msg. Message msg => FileEntry
mkFileEntry @FollowTipRequest
    , forall msg. Message msg => FileEntry
mkFileEntry @Empty
    , forall msg. Message msg => FileEntry
mkFileEntry @FieldMask
    , forall msg. Message msg => FileEntry
mkFileEntry @ReflectionV1.ServerReflectionRequest
    , forall msg. Message msg => FileEntry
mkFileEntry @ReflectionV1alpha.ServerReflectionRequest
    ]

-- | Resolve a fully qualified symbol - a service, method, message, nested
-- message, field, oneof, enum, or enum value name - to the file that
-- declares it.
lookupSymbol :: DescriptorTable -> Text -> Maybe Text
lookupSymbol :: DescriptorTable -> Text -> Maybe Text
lookupSymbol DescriptorTable
table Text
symbolName = Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
symbolName (DescriptorTable -> Map Text Text
descriptorTableSymbolIndex DescriptorTable
table)

-- | The named file, plus every file it transitively depends on, in
-- traversal order with the file itself first, deduplicated. 'Nothing' if
-- the file itself is not in the table; a dependency that is missing from
-- the table (which should not happen - see the table's closure invariant)
-- is silently skipped rather than failing the whole lookup.
transitiveClosure :: DescriptorTable -> Text -> Maybe [FileEntry]
transitiveClosure :: DescriptorTable -> Text -> Maybe [FileEntry]
transitiveClosure DescriptorTable
table Text
rootName = do
  rootEntry <- DescriptorTable -> Text -> Maybe FileEntry
lookupFile DescriptorTable
table Text
rootName
  pure $
    rootEntry : go (Set.singleton rootName) (fileEntryDescriptor rootEntry ^. Descriptor.dependency)
 where
  go :: Set Text -> [Text] -> [FileEntry]
go Set Text
_ [] = []
  go Set Text
seen (Text
depName : [Text]
rest)
    | Text
depName Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
seen = Set Text -> [Text] -> [FileEntry]
go Set Text
seen [Text]
rest
    | Bool
otherwise = case DescriptorTable -> Text -> Maybe FileEntry
lookupFile DescriptorTable
table Text
depName of
        Maybe FileEntry
Nothing -> Set Text -> [Text] -> [FileEntry]
go (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
depName Set Text
seen) [Text]
rest
        Just FileEntry
depEntry ->
          FileEntry
depEntry
            FileEntry -> [FileEntry] -> [FileEntry]
forall a. a -> [a] -> [a]
: Set Text -> [Text] -> [FileEntry]
go (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
depName Set Text
seen) ([Text]
rest [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> FileEntry -> FileDescriptorProto
fileEntryDescriptor FileEntry
depEntry FileDescriptorProto
-> Getting [Text] FileDescriptorProto [Text] -> [Text]
forall s a. s -> Getting a s a -> a
^. Getting [Text] FileDescriptorProto [Text]
forall (f :: * -> *) s a.
(Functor f, HasField s "dependency" a) =>
LensLike' f s a
Descriptor.dependency)

-- | Look up a file by name (e.g. @"cardano/rpc/node.proto"@).
lookupFile :: DescriptorTable -> Text -> Maybe FileEntry
lookupFile :: DescriptorTable -> Text -> Maybe FileEntry
lookupFile DescriptorTable
table Text
fileName = Text -> Map Text FileEntry -> Maybe FileEntry
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
fileName (DescriptorTable -> Map Text FileEntry
descriptorTableFileIndex DescriptorTable
table)

-- | The name of every served proto file.
fileNames :: DescriptorTable -> [Text]
fileNames :: DescriptorTable -> [Text]
fileNames = Map Text FileEntry -> [Text]
forall k a. Map k a -> [k]
Map.keys (Map Text FileEntry -> [Text])
-> (DescriptorTable -> Map Text FileEntry)
-> DescriptorTable
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DescriptorTable -> Map Text FileEntry
descriptorTableFileIndex

-- | Build the 'FileEntry' for the proto file containing @msg@, using one
-- representative message type per file (any message declared in the file
-- works - 'packedFileDescriptor'\/'fileDescriptor' both resolve to the whole
-- containing file, not just @msg@ itself).
mkFileEntry :: forall msg. Message msg => FileEntry
mkFileEntry :: forall msg. Message msg => FileEntry
mkFileEntry =
  FileEntry
    { fileEntryDescriptor :: FileDescriptorProto
fileEntryDescriptor = forall a. Message a => FileDescriptorProto
fileDescriptor @msg
    , fileEntryBytes :: ByteString
fileEntryBytes = Proxy msg -> ByteString
forall msg. Message msg => Proxy msg -> ByteString
packedFileDescriptor (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @msg)
    }

-- | Every package-qualified symbol a file declares: its services (and their
-- methods), top-level and nested messages (and their fields and oneofs),
-- and top-level and nested enums (and their values).
fileSymbolNames :: FileDescriptorProto -> [Text]
fileSymbolNames :: FileDescriptorProto -> [Text]
fileSymbolNames FileDescriptorProto
descriptor =
  (ServiceDescriptorProto -> [Text])
-> [ServiceDescriptorProto] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> ServiceDescriptorProto -> [Text]
serviceSymbolNames Text
packageName) (FileDescriptorProto
descriptor FileDescriptorProto
-> Getting
     [ServiceDescriptorProto]
     FileDescriptorProto
     [ServiceDescriptorProto]
-> [ServiceDescriptorProto]
forall s a. s -> Getting a s a -> a
^. Getting
  [ServiceDescriptorProto]
  FileDescriptorProto
  [ServiceDescriptorProto]
forall (f :: * -> *) s a.
(Functor f, HasField s "service" a) =>
LensLike' f s a
Descriptor.service)
    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (DescriptorProto -> [Text]) -> [DescriptorProto] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> DescriptorProto -> [Text]
messageSymbolNames Text
packageName) (FileDescriptorProto
descriptor FileDescriptorProto
-> Getting [DescriptorProto] FileDescriptorProto [DescriptorProto]
-> [DescriptorProto]
forall s a. s -> Getting a s a -> a
^. Getting [DescriptorProto] FileDescriptorProto [DescriptorProto]
forall (f :: * -> *) s a.
(Functor f, HasField s "messageType" a) =>
LensLike' f s a
Descriptor.messageType)
    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (EnumDescriptorProto -> [Text]) -> [EnumDescriptorProto] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> EnumDescriptorProto -> [Text]
enumSymbolNames Text
packageName) (FileDescriptorProto
descriptor FileDescriptorProto
-> Getting
     [EnumDescriptorProto] FileDescriptorProto [EnumDescriptorProto]
-> [EnumDescriptorProto]
forall s a. s -> Getting a s a -> a
^. Getting
  [EnumDescriptorProto] FileDescriptorProto [EnumDescriptorProto]
forall (f :: * -> *) s a.
(Functor f, HasField s "enumType" a) =>
LensLike' f s a
Descriptor.enumType)
 where
  packageName :: Text
packageName = FileDescriptorProto
descriptor FileDescriptorProto
-> Getting Text FileDescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text FileDescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "package" a) =>
LensLike' f s a
Descriptor.package

-- | A service's own symbol, plus one per method it declares.
serviceSymbolNames :: Text -> ServiceDescriptorProto -> [Text]
serviceSymbolNames :: Text -> ServiceDescriptorProto -> [Text]
serviceSymbolNames Text
packageName ServiceDescriptorProto
service =
  Text
serviceName Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (MethodDescriptorProto -> Text)
-> [MethodDescriptorProto] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
qualify Text
serviceName (Text -> Text)
-> (MethodDescriptorProto -> Text) -> MethodDescriptorProto -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MethodDescriptorProto
-> Getting Text MethodDescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text MethodDescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Descriptor.name)) (ServiceDescriptorProto
service ServiceDescriptorProto
-> Getting
     [MethodDescriptorProto]
     ServiceDescriptorProto
     [MethodDescriptorProto]
-> [MethodDescriptorProto]
forall s a. s -> Getting a s a -> a
^. Getting
  [MethodDescriptorProto]
  ServiceDescriptorProto
  [MethodDescriptorProto]
forall (f :: * -> *) s a.
(Functor f, HasField s "method" a) =>
LensLike' f s a
Descriptor.method)
 where
  serviceName :: Text
serviceName = Text -> Text -> Text
qualify Text
packageName (ServiceDescriptorProto
service ServiceDescriptorProto
-> Getting Text ServiceDescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text ServiceDescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Descriptor.name)

-- | A message's own symbol, plus every symbol nested inside it, recursively:
-- its fields and oneof declarations (both scoped to the message itself,
-- like enum values are), its nested messages, and its nested enums.
messageSymbolNames :: Text -> DescriptorProto -> [Text]
messageSymbolNames :: Text -> DescriptorProto -> [Text]
messageSymbolNames Text
enclosingName DescriptorProto
message =
  Text
messageName
    Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (DescriptorProto -> [Text]) -> [DescriptorProto] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> DescriptorProto -> [Text]
messageSymbolNames Text
messageName) (DescriptorProto
message DescriptorProto
-> Getting [DescriptorProto] DescriptorProto [DescriptorProto]
-> [DescriptorProto]
forall s a. s -> Getting a s a -> a
^. Getting [DescriptorProto] DescriptorProto [DescriptorProto]
forall (f :: * -> *) s a.
(Functor f, HasField s "nestedType" a) =>
LensLike' f s a
Descriptor.nestedType)
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (EnumDescriptorProto -> [Text]) -> [EnumDescriptorProto] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> EnumDescriptorProto -> [Text]
enumSymbolNames Text
messageName) (DescriptorProto
message DescriptorProto
-> Getting
     [EnumDescriptorProto] DescriptorProto [EnumDescriptorProto]
-> [EnumDescriptorProto]
forall s a. s -> Getting a s a -> a
^. Getting [EnumDescriptorProto] DescriptorProto [EnumDescriptorProto]
forall (f :: * -> *) s a.
(Functor f, HasField s "enumType" a) =>
LensLike' f s a
Descriptor.enumType)
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (FieldDescriptorProto -> Text) -> [FieldDescriptorProto] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
qualify Text
messageName (Text -> Text)
-> (FieldDescriptorProto -> Text) -> FieldDescriptorProto -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDescriptorProto
-> Getting Text FieldDescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text FieldDescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Descriptor.name)) (DescriptorProto
message DescriptorProto
-> Getting
     [FieldDescriptorProto] DescriptorProto [FieldDescriptorProto]
-> [FieldDescriptorProto]
forall s a. s -> Getting a s a -> a
^. Getting
  [FieldDescriptorProto] DescriptorProto [FieldDescriptorProto]
forall (f :: * -> *) s a.
(Functor f, HasField s "field" a) =>
LensLike' f s a
Descriptor.field)
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (OneofDescriptorProto -> Text) -> [OneofDescriptorProto] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
qualify Text
messageName (Text -> Text)
-> (OneofDescriptorProto -> Text) -> OneofDescriptorProto -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OneofDescriptorProto
-> Getting Text OneofDescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text OneofDescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Descriptor.name)) (DescriptorProto
message DescriptorProto
-> Getting
     [OneofDescriptorProto] DescriptorProto [OneofDescriptorProto]
-> [OneofDescriptorProto]
forall s a. s -> Getting a s a -> a
^. Getting
  [OneofDescriptorProto] DescriptorProto [OneofDescriptorProto]
forall (f :: * -> *) s a.
(Functor f, HasField s "oneofDecl" a) =>
LensLike' f s a
Descriptor.oneofDecl)
 where
  messageName :: Text
messageName = Text -> Text -> Text
qualify Text
enclosingName (DescriptorProto
message DescriptorProto -> Getting Text DescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text DescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Descriptor.name)

-- | An enum's own symbol, plus one per value it declares. Protobuf scopes
-- an enum VALUE's fully qualified name to the enum's own enclosing scope
-- (the package, or the containing message), not to the enum type itself,
-- so a value's symbol is a SIBLING of its enum's symbol, not nested under
-- it - e.g. @cardano.rpc.conway@, not @cardano.rpc.Era.conway@.
enumSymbolNames :: Text -> EnumDescriptorProto -> [Text]
enumSymbolNames :: Text -> EnumDescriptorProto -> [Text]
enumSymbolNames Text
enclosingName EnumDescriptorProto
enum =
  Text -> Text -> Text
qualify Text
enclosingName (EnumDescriptorProto
enum EnumDescriptorProto
-> Getting Text EnumDescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text EnumDescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Descriptor.name)
    Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (EnumValueDescriptorProto -> Text)
-> [EnumValueDescriptorProto] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
qualify Text
enclosingName (Text -> Text)
-> (EnumValueDescriptorProto -> Text)
-> EnumValueDescriptorProto
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumValueDescriptorProto
-> Getting Text EnumValueDescriptorProto Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text EnumValueDescriptorProto Text
forall (f :: * -> *) s a.
(Functor f, HasField s "name" a) =>
LensLike' f s a
Descriptor.name)) (EnumDescriptorProto
enum EnumDescriptorProto
-> Getting
     [EnumValueDescriptorProto]
     EnumDescriptorProto
     [EnumValueDescriptorProto]
-> [EnumValueDescriptorProto]
forall s a. s -> Getting a s a -> a
^. Getting
  [EnumValueDescriptorProto]
  EnumDescriptorProto
  [EnumValueDescriptorProto]
forall (f :: * -> *) s a.
(Functor f, HasField s "value" a) =>
LensLike' f s a
Descriptor.value)

-- | Join a package\/enclosing-message prefix and a name with a dot, or just
-- the name if the prefix is empty (a file with no @package@ declaration).
qualify :: Text -> Text -> Text
qualify :: Text -> Text -> Text
qualify Text
prefix Text
name
  | Text -> Bool
Text.null Text
prefix = Text
name
  | Bool
otherwise = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

-- | One served proto file: its decoded descriptor, used to walk dependencies
-- and resolve symbols, and the packed bytes of that same descriptor, sent
-- verbatim in a @FileDescriptorResponse@.
data FileEntry = FileEntry
  { FileEntry -> FileDescriptorProto
fileEntryDescriptor :: FileDescriptorProto
  , FileEntry -> ByteString
fileEntryBytes :: ByteString
  }
  deriving (FileEntry -> FileEntry -> Bool
(FileEntry -> FileEntry -> Bool)
-> (FileEntry -> FileEntry -> Bool) -> Eq FileEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileEntry -> FileEntry -> Bool
== :: FileEntry -> FileEntry -> Bool
$c/= :: FileEntry -> FileEntry -> Bool
/= :: FileEntry -> FileEntry -> Bool
Eq, Int -> FileEntry -> ShowS
[FileEntry] -> ShowS
FileEntry -> String
(Int -> FileEntry -> ShowS)
-> (FileEntry -> String)
-> ([FileEntry] -> ShowS)
-> Show FileEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileEntry -> ShowS
showsPrec :: Int -> FileEntry -> ShowS
$cshow :: FileEntry -> String
show :: FileEntry -> String
$cshowList :: [FileEntry] -> ShowS
showList :: [FileEntry] -> ShowS
Show)

data DescriptorTable = DescriptorTable
  { DescriptorTable -> Map Text FileEntry
descriptorTableFileIndex :: Map Text FileEntry
  , DescriptorTable -> Map Text Text
descriptorTableSymbolIndex :: Map Text Text
  -- ^ Fully qualified symbol (service, method, message, field, oneof, enum,
  -- or enum value name) to the file name that declares it.
  }