{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

module Hasura.RQL.Types.Relationships.ToSchema
  ( ToSchemaRelationshipDef (..),
    FieldCall (..),
    RemoteArguments (..),
    RemoteFields (..),
    RemoteSchemaFieldInfo (..),
    trrdRemoteField,
    trrdLhsFields,
    trrdRemoteSchema,
    graphQLValueToJSON,
    LHSIdentifier (..),
    tableNameToLHSIdentifier,
    remoteSchemaToLHSIdentifier,
    lhsIdentifierToGraphQLName,
  )
where

import Control.Lens (makeLenses)
import Data.Aeson
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.TH
import Data.Aeson.Types (prependFailure)
import Data.Bifunctor (bimap)
import Data.Char qualified as C
import Data.HashMap.Strict qualified as HM
import Data.Scientific
import Data.Text qualified as T
import Data.Text.Extended (toTxt)
import Hasura.Incremental (Cacheable)
import Hasura.Prelude
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Instances ()
import Hasura.RQL.Types.RemoteSchema
import Language.GraphQL.Draft.Syntax qualified as G

--------------------------------------------------------------------------------
-- metadata

-- | Metadata representation of a relationship to a remote schema.
--
-- FIXME: move this to Hasura/Metadata
data ToSchemaRelationshipDef = ToSchemaRelationshipDef
  { -- | Identifier for this mapping.
    ToSchemaRelationshipDef -> RemoteSchemaName
_trrdRemoteSchema :: RemoteSchemaName,
    -- | The lhs fields that must be forwarded to the remote schema.
    ToSchemaRelationshipDef -> HashSet FieldName
_trrdLhsFields :: HashSet FieldName,
    ToSchemaRelationshipDef -> RemoteFields
_trrdRemoteField :: RemoteFields
  }
  deriving stock (Int -> ToSchemaRelationshipDef -> ShowS
[ToSchemaRelationshipDef] -> ShowS
ToSchemaRelationshipDef -> String
(Int -> ToSchemaRelationshipDef -> ShowS)
-> (ToSchemaRelationshipDef -> String)
-> ([ToSchemaRelationshipDef] -> ShowS)
-> Show ToSchemaRelationshipDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ToSchemaRelationshipDef] -> ShowS
$cshowList :: [ToSchemaRelationshipDef] -> ShowS
show :: ToSchemaRelationshipDef -> String
$cshow :: ToSchemaRelationshipDef -> String
showsPrec :: Int -> ToSchemaRelationshipDef -> ShowS
$cshowsPrec :: Int -> ToSchemaRelationshipDef -> ShowS
Show, ToSchemaRelationshipDef -> ToSchemaRelationshipDef -> Bool
(ToSchemaRelationshipDef -> ToSchemaRelationshipDef -> Bool)
-> (ToSchemaRelationshipDef -> ToSchemaRelationshipDef -> Bool)
-> Eq ToSchemaRelationshipDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ToSchemaRelationshipDef -> ToSchemaRelationshipDef -> Bool
$c/= :: ToSchemaRelationshipDef -> ToSchemaRelationshipDef -> Bool
== :: ToSchemaRelationshipDef -> ToSchemaRelationshipDef -> Bool
$c== :: ToSchemaRelationshipDef -> ToSchemaRelationshipDef -> Bool
Eq, (forall x.
 ToSchemaRelationshipDef -> Rep ToSchemaRelationshipDef x)
-> (forall x.
    Rep ToSchemaRelationshipDef x -> ToSchemaRelationshipDef)
-> Generic ToSchemaRelationshipDef
forall x. Rep ToSchemaRelationshipDef x -> ToSchemaRelationshipDef
forall x. ToSchemaRelationshipDef -> Rep ToSchemaRelationshipDef x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ToSchemaRelationshipDef x -> ToSchemaRelationshipDef
$cfrom :: forall x. ToSchemaRelationshipDef -> Rep ToSchemaRelationshipDef x
Generic)

instance NFData ToSchemaRelationshipDef

instance Cacheable ToSchemaRelationshipDef

-- | Targeted field in a remote schema relationship.
-- TODO: explain about subfields and why this is a container
newtype RemoteFields = RemoteFields {RemoteFields -> NonEmpty FieldCall
unRemoteFields :: NonEmpty FieldCall}
  deriving (Int -> RemoteFields -> ShowS
[RemoteFields] -> ShowS
RemoteFields -> String
(Int -> RemoteFields -> ShowS)
-> (RemoteFields -> String)
-> ([RemoteFields] -> ShowS)
-> Show RemoteFields
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RemoteFields] -> ShowS
$cshowList :: [RemoteFields] -> ShowS
show :: RemoteFields -> String
$cshow :: RemoteFields -> String
showsPrec :: Int -> RemoteFields -> ShowS
$cshowsPrec :: Int -> RemoteFields -> ShowS
Show, RemoteFields -> RemoteFields -> Bool
(RemoteFields -> RemoteFields -> Bool)
-> (RemoteFields -> RemoteFields -> Bool) -> Eq RemoteFields
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RemoteFields -> RemoteFields -> Bool
$c/= :: RemoteFields -> RemoteFields -> Bool
== :: RemoteFields -> RemoteFields -> Bool
$c== :: RemoteFields -> RemoteFields -> Bool
Eq, (forall x. RemoteFields -> Rep RemoteFields x)
-> (forall x. Rep RemoteFields x -> RemoteFields)
-> Generic RemoteFields
forall x. Rep RemoteFields x -> RemoteFields
forall x. RemoteFields -> Rep RemoteFields x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RemoteFields x -> RemoteFields
$cfrom :: forall x. RemoteFields -> Rep RemoteFields x
Generic)

instance NFData RemoteFields

instance Cacheable RemoteFields

instance FromJSON RemoteFields where
  parseJSON :: Value -> Parser RemoteFields
parseJSON = String -> Parser RemoteFields -> Parser RemoteFields
forall a. String -> Parser a -> Parser a
prependFailure String
details (Parser RemoteFields -> Parser RemoteFields)
-> (Value -> Parser RemoteFields) -> Value -> Parser RemoteFields
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty FieldCall -> RemoteFields)
-> Parser (NonEmpty FieldCall) -> Parser RemoteFields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty FieldCall -> RemoteFields
RemoteFields (Parser (NonEmpty FieldCall) -> Parser RemoteFields)
-> (Value -> Parser (NonEmpty FieldCall))
-> Value
-> Parser RemoteFields
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser (NonEmpty FieldCall)
parseRemoteFields
    where
      details :: String
details = String
"Remote fields are represented by an object that maps each field name to its arguments."
      parseRemoteFields :: Value -> Parser (NonEmpty FieldCall)
parseRemoteFields = String
-> (Object -> Parser (NonEmpty FieldCall))
-> Value
-> Parser (NonEmpty FieldCall)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RemoteFields" \Object
hashmap -> case Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
hashmap of
        [(Key
fieldNameKey, Value
callValue)] -> do
          Name
fieldName <- Value -> Parser Name
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser Name) -> Value -> Parser Name
forall a b. (a -> b) -> a -> b
$ Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Text
K.toText Key
fieldNameKey
          Object
callObject <- Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON Value
callValue
          RemoteArguments
arguments <- Object
callObject Object -> Key -> Parser RemoteArguments
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"arguments"
          Maybe Value
maybeSubField <- Object
callObject Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"field"
          [FieldCall]
subFields <-
            [FieldCall] -> Maybe [FieldCall] -> [FieldCall]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [FieldCall] -> [FieldCall])
-> Parser (Maybe [FieldCall]) -> Parser [FieldCall]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
-> (Value -> Parser [FieldCall]) -> Parser (Maybe [FieldCall])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe Value
maybeSubField \Value
fieldValue -> do
              NonEmpty FieldCall
remoteFields <- Value -> Parser (NonEmpty FieldCall)
parseRemoteFields Value
fieldValue
              [FieldCall] -> Parser [FieldCall]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty FieldCall -> [FieldCall]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty FieldCall
remoteFields)
          NonEmpty FieldCall -> Parser (NonEmpty FieldCall)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty FieldCall -> Parser (NonEmpty FieldCall))
-> NonEmpty FieldCall -> Parser (NonEmpty FieldCall)
forall a b. (a -> b) -> a -> b
$ FieldCall :: Name -> RemoteArguments -> FieldCall
FieldCall {fcName :: Name
fcName = Name
fieldName, fcArguments :: RemoteArguments
fcArguments = RemoteArguments
arguments} FieldCall -> [FieldCall] -> NonEmpty FieldCall
forall a. a -> [a] -> NonEmpty a
:| [FieldCall]
subFields
        [] -> String -> Parser (NonEmpty FieldCall)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expecting one single mapping, received none."
        [(Key, Value)]
_ -> String -> Parser (NonEmpty FieldCall)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expecting one single mapping, received too many."

instance ToJSON RemoteFields where
  toJSON :: RemoteFields -> Value
toJSON (RemoteFields NonEmpty FieldCall
fields) = NonEmpty FieldCall -> Value
remoteFieldsJson NonEmpty FieldCall
fields
    where
      remoteFieldsJson :: NonEmpty FieldCall -> Value
remoteFieldsJson (FieldCall
field :| [FieldCall]
subfields) =
        [(Key, Value)] -> Value
object
          [ Text -> Key
K.fromText (Name -> Text
G.unName (FieldCall -> Name
fcName FieldCall
field))
              Key -> Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [(Key, Value)] -> Value
object
                ( [Maybe (Key, Value)] -> [(Key, Value)]
forall (f :: * -> *) a. Filterable f => f (Maybe a) -> f a
catMaybes
                    [ (Key, Value) -> Maybe (Key, Value)
forall a. a -> Maybe a
Just ((Key, Value) -> Maybe (Key, Value))
-> (Key, Value) -> Maybe (Key, Value)
forall a b. (a -> b) -> a -> b
$ Key
"arguments" Key -> RemoteArguments -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FieldCall -> RemoteArguments
fcArguments FieldCall
field,
                      [FieldCall] -> Maybe (NonEmpty FieldCall)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [FieldCall]
subfields Maybe (NonEmpty FieldCall)
-> (NonEmpty FieldCall -> (Key, Value)) -> Maybe (Key, Value)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \NonEmpty FieldCall
sf -> Key
"field" Key -> Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty FieldCall -> Value
remoteFieldsJson NonEmpty FieldCall
sf
                    ]
                )
          ]

-- | Associates a field name with the arguments it will be passed in the query.
--
-- https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments
data FieldCall = FieldCall
  { FieldCall -> Name
fcName :: G.Name,
    FieldCall -> RemoteArguments
fcArguments :: RemoteArguments
  }
  deriving (Int -> FieldCall -> ShowS
[FieldCall] -> ShowS
FieldCall -> String
(Int -> FieldCall -> ShowS)
-> (FieldCall -> String)
-> ([FieldCall] -> ShowS)
-> Show FieldCall
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldCall] -> ShowS
$cshowList :: [FieldCall] -> ShowS
show :: FieldCall -> String
$cshow :: FieldCall -> String
showsPrec :: Int -> FieldCall -> ShowS
$cshowsPrec :: Int -> FieldCall -> ShowS
Show, FieldCall -> FieldCall -> Bool
(FieldCall -> FieldCall -> Bool)
-> (FieldCall -> FieldCall -> Bool) -> Eq FieldCall
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldCall -> FieldCall -> Bool
$c/= :: FieldCall -> FieldCall -> Bool
== :: FieldCall -> FieldCall -> Bool
$c== :: FieldCall -> FieldCall -> Bool
Eq, (forall x. FieldCall -> Rep FieldCall x)
-> (forall x. Rep FieldCall x -> FieldCall) -> Generic FieldCall
forall x. Rep FieldCall x -> FieldCall
forall x. FieldCall -> Rep FieldCall x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FieldCall x -> FieldCall
$cfrom :: forall x. FieldCall -> Rep FieldCall x
Generic)

instance NFData FieldCall

instance Cacheable FieldCall

instance Hashable FieldCall

-- | Arguments to a remote GraphQL fields, represented as a mapping from name to
-- GraphQL Value. Said values can be variable names, in which case they'll be
-- referring to values we're closed over.
-- TODO: expand on this
newtype RemoteArguments = RemoteArguments
  { RemoteArguments -> HashMap Name (Value Name)
getRemoteArguments :: HashMap G.Name (G.Value G.Name)
  }
  deriving (Int -> RemoteArguments -> ShowS
[RemoteArguments] -> ShowS
RemoteArguments -> String
(Int -> RemoteArguments -> ShowS)
-> (RemoteArguments -> String)
-> ([RemoteArguments] -> ShowS)
-> Show RemoteArguments
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RemoteArguments] -> ShowS
$cshowList :: [RemoteArguments] -> ShowS
show :: RemoteArguments -> String
$cshow :: RemoteArguments -> String
showsPrec :: Int -> RemoteArguments -> ShowS
$cshowsPrec :: Int -> RemoteArguments -> ShowS
Show, RemoteArguments -> RemoteArguments -> Bool
(RemoteArguments -> RemoteArguments -> Bool)
-> (RemoteArguments -> RemoteArguments -> Bool)
-> Eq RemoteArguments
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RemoteArguments -> RemoteArguments -> Bool
$c/= :: RemoteArguments -> RemoteArguments -> Bool
== :: RemoteArguments -> RemoteArguments -> Bool
$c== :: RemoteArguments -> RemoteArguments -> Bool
Eq, (forall x. RemoteArguments -> Rep RemoteArguments x)
-> (forall x. Rep RemoteArguments x -> RemoteArguments)
-> Generic RemoteArguments
forall x. Rep RemoteArguments x -> RemoteArguments
forall x. RemoteArguments -> Rep RemoteArguments x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RemoteArguments x -> RemoteArguments
$cfrom :: forall x. RemoteArguments -> Rep RemoteArguments x
Generic, Eq RemoteArguments
Eq RemoteArguments
-> (Accesses -> RemoteArguments -> RemoteArguments -> Bool)
-> Cacheable RemoteArguments
Accesses -> RemoteArguments -> RemoteArguments -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses -> RemoteArguments -> RemoteArguments -> Bool
$cunchanged :: Accesses -> RemoteArguments -> RemoteArguments -> Bool
$cp1Cacheable :: Eq RemoteArguments
Cacheable, RemoteArguments -> ()
(RemoteArguments -> ()) -> NFData RemoteArguments
forall a. (a -> ()) -> NFData a
rnf :: RemoteArguments -> ()
$crnf :: RemoteArguments -> ()
NFData)

instance Hashable RemoteArguments

instance FromJSON RemoteArguments where
  parseJSON :: Value -> Parser RemoteArguments
parseJSON = String -> Parser RemoteArguments -> Parser RemoteArguments
forall a. String -> Parser a -> Parser a
prependFailure String
details (Parser RemoteArguments -> Parser RemoteArguments)
-> (Value -> Parser RemoteArguments)
-> Value
-> Parser RemoteArguments
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap Name (Value Name) -> RemoteArguments)
-> Parser (HashMap Name (Value Name)) -> Parser RemoteArguments
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HashMap Name (Value Name) -> RemoteArguments
RemoteArguments (Parser (HashMap Name (Value Name)) -> Parser RemoteArguments)
-> (Value -> Parser (HashMap Name (Value Name)))
-> Value
-> Parser RemoteArguments
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> (Object -> Parser (HashMap Name (Value Name)))
-> Value
-> Parser (HashMap Name (Value Name))
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RemoteArguments" Object -> Parser (HashMap Name (Value Name))
parseObjectFieldsToGValue
    where
      details :: String
details = String
"Remote arguments are represented by an object that maps each argument name to its value."

      parseObjectFieldsToGValue :: Object -> Parser (HashMap Name (Value Name))
parseObjectFieldsToGValue Object
keyMap =
        [(Name, Value Name)] -> HashMap Name (Value Name)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Name, Value Name)] -> HashMap Name (Value Name))
-> Parser [(Name, Value Name)]
-> Parser (HashMap Name (Value Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Key, Value)]
-> ((Key, Value) -> Parser (Name, Value Name))
-> Parser [(Name, Value Name)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
keyMap) \(Key -> Text
K.toText -> Text
key, Value
value) -> do
          Name
name <- Text -> Maybe Name
G.mkName Text
key Maybe Name -> Parser Name -> Parser Name
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` String -> Parser Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Text -> String
T.unpack Text
key String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is an invalid key name")
          Value Name
parsedValue <- Value -> Parser (Value Name)
parseValueAsGValue Value
value
          (Name, Value Name) -> Parser (Name, Value Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, Value Name
parsedValue)

      parseValueAsGValue :: Value -> Parser (Value Name)
parseValueAsGValue = \case
        Object Object
obj ->
          HashMap Name (Value Name) -> Value Name
forall var. HashMap Name (Value var) -> Value var
G.VObject (HashMap Name (Value Name) -> Value Name)
-> Parser (HashMap Name (Value Name)) -> Parser (Value Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser (HashMap Name (Value Name))
parseObjectFieldsToGValue Object
obj
        Array Array
array ->
          [Value Name] -> Value Name
forall var. [Value var] -> Value var
G.VList ([Value Name] -> Value Name)
-> (Vector (Value Name) -> [Value Name])
-> Vector (Value Name)
-> Value Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Value Name) -> [Value Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector (Value Name) -> Value Name)
-> Parser (Vector (Value Name)) -> Parser (Value Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser (Value Name))
-> Array -> Parser (Vector (Value Name))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Parser (Value Name)
parseValueAsGValue Array
array
        String Text
text ->
          case Text -> Maybe (Char, Text)
T.uncons Text
text of
            Just (Char
'$', Text
rest)
              | Text -> Bool
T.null Text
rest -> String -> Parser (Value Name)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Value Name)) -> String -> Parser (Value Name)
forall a b. (a -> b) -> a -> b
$ String
"Empty variable name"
              | Bool
otherwise -> case Text -> Maybe Name
G.mkName Text
rest of
                Maybe Name
Nothing -> String -> Parser (Value Name)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Value Name)) -> String -> Parser (Value Name)
forall a b. (a -> b) -> a -> b
$ String
"Invalid variable name '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
rest String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'"
                Just Name
name' -> Value Name -> Parser (Value Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Name -> Parser (Value Name))
-> Value Name -> Parser (Value Name)
forall a b. (a -> b) -> a -> b
$ Name -> Value Name
forall var. var -> Value var
G.VVariable Name
name'
            Maybe (Char, Text)
_ -> Value Name -> Parser (Value Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Value Name
forall var. Text -> Value var
G.VString Text
text)
        Number !Scientific
scientificNum ->
          Value Name -> Parser (Value Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Name -> Parser (Value Name))
-> Value Name -> Parser (Value Name)
forall a b. (a -> b) -> a -> b
$ case Scientific -> Either Float Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
scientificNum of
            -- this number couldn't be interpreted as an integer
            Left (Float
_ :: Float) -> Scientific -> Value Name
forall var. Scientific -> Value var
G.VFloat Scientific
scientificNum
            -- this number was successfully interpreted as an integer
            Right Integer
n -> Integer -> Value Name
forall var. Integer -> Value var
G.VInt Integer
n
        Bool !Bool
boolean ->
          Value Name -> Parser (Value Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value Name -> Parser (Value Name))
-> Value Name -> Parser (Value Name)
forall a b. (a -> b) -> a -> b
$ Bool -> Value Name
forall var. Bool -> Value var
G.VBoolean Bool
boolean
        Value
Null ->
          Value Name -> Parser (Value Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value Name
forall var. Value var
G.VNull

instance ToJSON RemoteArguments where
  toJSON :: RemoteArguments -> Value
toJSON (RemoteArguments HashMap Name (Value Name)
fields) = HashMap Name (Value Name) -> Value
fieldsToObject HashMap Name (Value Name)
fields
    where
      fieldsToObject :: HashMap Name (Value Name) -> Value
fieldsToObject =
        Object -> Value
Object (Object -> Value)
-> (HashMap Name (Value Name) -> Object)
-> HashMap Name (Value Name)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList ([(Key, Value)] -> Object)
-> (HashMap Name (Value Name) -> [(Key, Value)])
-> HashMap Name (Value Name)
-> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, Value Name) -> (Key, Value))
-> [(Name, Value Name)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> Key)
-> (Value Name -> Value) -> (Name, Value Name) -> (Key, Value)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Text -> Key
K.fromText (Text -> Key) -> (Name -> Text) -> Name -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
G.unName) Value Name -> Value
gValueToValue) ([(Name, Value Name)] -> [(Key, Value)])
-> (HashMap Name (Value Name) -> [(Name, Value Name)])
-> HashMap Name (Value Name)
-> [(Key, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Name (Value Name) -> [(Name, Value Name)]
forall k v. HashMap k v -> [(k, v)]
HM.toList

      gValueToValue :: Value Name -> Value
gValueToValue =
        \case
          G.VVariable Name
v -> Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
v)
          G.VInt Integer
i -> Integer -> Value
forall a. ToJSON a => a -> Value
toJSON Integer
i
          G.VFloat Scientific
f -> Scientific -> Value
forall a. ToJSON a => a -> Value
toJSON Scientific
f
          G.VString Text
s -> Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
s
          G.VBoolean Bool
b -> Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
b
          Value Name
G.VNull -> Value
Null
          G.VEnum EnumValue
s -> EnumValue -> Value
forall a. ToJSON a => a -> Value
toJSON EnumValue
s
          G.VList [Value Name]
list -> [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ((Value Name -> Value) -> [Value Name] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Value Name -> Value
gValueToValue [Value Name]
list)
          G.VObject HashMap Name (Value Name)
obj -> HashMap Name (Value Name) -> Value
fieldsToObject HashMap Name (Value Name)
obj

-- schema cache representation

-- A textual identifier for an entity on which remote relationships can be
-- defined. This is used in error messages and type name generation for
-- arguments in remote relationship fields to remote schemas (See
-- RemoteRelationship.Validate)
newtype LHSIdentifier = LHSIdentifier {LHSIdentifier -> Text
getLHSIdentifier :: Text}
  deriving (Int -> LHSIdentifier -> ShowS
[LHSIdentifier] -> ShowS
LHSIdentifier -> String
(Int -> LHSIdentifier -> ShowS)
-> (LHSIdentifier -> String)
-> ([LHSIdentifier] -> ShowS)
-> Show LHSIdentifier
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LHSIdentifier] -> ShowS
$cshowList :: [LHSIdentifier] -> ShowS
show :: LHSIdentifier -> String
$cshow :: LHSIdentifier -> String
showsPrec :: Int -> LHSIdentifier -> ShowS
$cshowsPrec :: Int -> LHSIdentifier -> ShowS
Show, LHSIdentifier -> LHSIdentifier -> Bool
(LHSIdentifier -> LHSIdentifier -> Bool)
-> (LHSIdentifier -> LHSIdentifier -> Bool) -> Eq LHSIdentifier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LHSIdentifier -> LHSIdentifier -> Bool
$c/= :: LHSIdentifier -> LHSIdentifier -> Bool
== :: LHSIdentifier -> LHSIdentifier -> Bool
$c== :: LHSIdentifier -> LHSIdentifier -> Bool
Eq, (forall x. LHSIdentifier -> Rep LHSIdentifier x)
-> (forall x. Rep LHSIdentifier x -> LHSIdentifier)
-> Generic LHSIdentifier
forall x. Rep LHSIdentifier x -> LHSIdentifier
forall x. LHSIdentifier -> Rep LHSIdentifier x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LHSIdentifier x -> LHSIdentifier
$cfrom :: forall x. LHSIdentifier -> Rep LHSIdentifier x
Generic)

instance Cacheable LHSIdentifier

tableNameToLHSIdentifier :: (Backend b) => TableName b -> LHSIdentifier
tableNameToLHSIdentifier :: TableName b -> LHSIdentifier
tableNameToLHSIdentifier = Text -> LHSIdentifier
LHSIdentifier (Text -> LHSIdentifier)
-> (TableName b -> Text) -> TableName b -> LHSIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableName b -> Text
forall a. ToTxt a => a -> Text
toTxt

remoteSchemaToLHSIdentifier :: RemoteSchemaName -> LHSIdentifier
remoteSchemaToLHSIdentifier :: RemoteSchemaName -> LHSIdentifier
remoteSchemaToLHSIdentifier = Text -> LHSIdentifier
LHSIdentifier (Text -> LHSIdentifier)
-> (RemoteSchemaName -> Text) -> RemoteSchemaName -> LHSIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteSchemaName -> Text
forall a. ToTxt a => a -> Text
toTxt

-- | Generates a valid graphql name from an arbitrary LHS identifier.
-- This is done by replacing all unrecognized characters by '_'. This
-- function still returns a @Maybe@ value, in cases we can't adjust
-- the raw text (such as the case of empty identifiers).
lhsIdentifierToGraphQLName :: LHSIdentifier -> Maybe G.Name
lhsIdentifierToGraphQLName :: LHSIdentifier -> Maybe Name
lhsIdentifierToGraphQLName (LHSIdentifier Text
rawText) = Text -> Maybe Name
G.mkName (Text -> Maybe Name) -> Text -> Maybe Name
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> Text -> Text
T.map Char -> Char
adjust Text
rawText
  where
    adjust :: Char -> Char
adjust Char
c =
      if Char -> Bool
C.isAsciiUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
C.isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
C.isDigit Char
c
        then Char
c
        else Char
'_'

-- | Schema cache information for a table field targeting a remote schema.
data RemoteSchemaFieldInfo = RemoteSchemaFieldInfo
  { -- | Field name to which we'll map the remote in hasura; this becomes part
    --   of the hasura schema.
    RemoteSchemaFieldInfo -> RelName
_rrfiName :: RelName,
    -- | Input arguments to the remote field info; The '_rfiParamMap' will only
    --   include the arguments to the remote field that is being joined. The
    --   names of the arguments here are modified, it will be in the format of
    --   <Original Field Name>_remote_rel_<hasura table schema>_<hasura table name><remote relationship name>
    RemoteSchemaFieldInfo
-> HashMap Name RemoteSchemaInputValueDefinition
_rrfiParamMap :: HashMap G.Name RemoteSchemaInputValueDefinition,
    RemoteSchemaFieldInfo -> RemoteFields
_rrfiRemoteFields :: RemoteFields,
    RemoteSchemaFieldInfo -> RemoteSchemaInfo
_rrfiRemoteSchema :: RemoteSchemaInfo,
    -- | The new input value definitions created for this remote field
    RemoteSchemaFieldInfo
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
_rrfiInputValueDefinitions :: [G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition],
    -- | Name of the remote schema, that's used for joining
    RemoteSchemaFieldInfo -> RemoteSchemaName
_rrfiRemoteSchemaName :: RemoteSchemaName,
    -- | TODO: this one should be gone when 'validateRemoteRelationship'
    -- function is cleaned up
    RemoteSchemaFieldInfo -> LHSIdentifier
_rrfiLHSIdentifier :: LHSIdentifier
  }
  deriving ((forall x. RemoteSchemaFieldInfo -> Rep RemoteSchemaFieldInfo x)
-> (forall x. Rep RemoteSchemaFieldInfo x -> RemoteSchemaFieldInfo)
-> Generic RemoteSchemaFieldInfo
forall x. Rep RemoteSchemaFieldInfo x -> RemoteSchemaFieldInfo
forall x. RemoteSchemaFieldInfo -> Rep RemoteSchemaFieldInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RemoteSchemaFieldInfo x -> RemoteSchemaFieldInfo
$cfrom :: forall x. RemoteSchemaFieldInfo -> Rep RemoteSchemaFieldInfo x
Generic, RemoteSchemaFieldInfo -> RemoteSchemaFieldInfo -> Bool
(RemoteSchemaFieldInfo -> RemoteSchemaFieldInfo -> Bool)
-> (RemoteSchemaFieldInfo -> RemoteSchemaFieldInfo -> Bool)
-> Eq RemoteSchemaFieldInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RemoteSchemaFieldInfo -> RemoteSchemaFieldInfo -> Bool
$c/= :: RemoteSchemaFieldInfo -> RemoteSchemaFieldInfo -> Bool
== :: RemoteSchemaFieldInfo -> RemoteSchemaFieldInfo -> Bool
$c== :: RemoteSchemaFieldInfo -> RemoteSchemaFieldInfo -> Bool
Eq, Int -> RemoteSchemaFieldInfo -> ShowS
[RemoteSchemaFieldInfo] -> ShowS
RemoteSchemaFieldInfo -> String
(Int -> RemoteSchemaFieldInfo -> ShowS)
-> (RemoteSchemaFieldInfo -> String)
-> ([RemoteSchemaFieldInfo] -> ShowS)
-> Show RemoteSchemaFieldInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RemoteSchemaFieldInfo] -> ShowS
$cshowList :: [RemoteSchemaFieldInfo] -> ShowS
show :: RemoteSchemaFieldInfo -> String
$cshow :: RemoteSchemaFieldInfo -> String
showsPrec :: Int -> RemoteSchemaFieldInfo -> ShowS
$cshowsPrec :: Int -> RemoteSchemaFieldInfo -> ShowS
Show)

instance Cacheable RemoteSchemaFieldInfo

instance ToJSON RemoteSchemaFieldInfo where
  toJSON :: RemoteSchemaFieldInfo -> Value
toJSON RemoteSchemaFieldInfo {[TypeDefinition [Name] RemoteSchemaInputValueDefinition]
HashMap Name RemoteSchemaInputValueDefinition
RelName
RemoteSchemaName
RemoteSchemaInfo
LHSIdentifier
RemoteFields
_rrfiLHSIdentifier :: LHSIdentifier
_rrfiRemoteSchemaName :: RemoteSchemaName
_rrfiInputValueDefinitions :: [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
_rrfiRemoteSchema :: RemoteSchemaInfo
_rrfiRemoteFields :: RemoteFields
_rrfiParamMap :: HashMap Name RemoteSchemaInputValueDefinition
_rrfiName :: RelName
_rrfiLHSIdentifier :: RemoteSchemaFieldInfo -> LHSIdentifier
_rrfiRemoteSchemaName :: RemoteSchemaFieldInfo -> RemoteSchemaName
_rrfiInputValueDefinitions :: RemoteSchemaFieldInfo
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
_rrfiRemoteSchema :: RemoteSchemaFieldInfo -> RemoteSchemaInfo
_rrfiRemoteFields :: RemoteSchemaFieldInfo -> RemoteFields
_rrfiParamMap :: RemoteSchemaFieldInfo
-> HashMap Name RemoteSchemaInputValueDefinition
_rrfiName :: RemoteSchemaFieldInfo -> RelName
..} =
    [(Key, Value)] -> Value
object
      [ Key
"name" Key -> RelName -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RelName
_rrfiName,
        Key
"param_map" Key -> HashMap Name Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (RemoteSchemaInputValueDefinition -> Value)
-> HashMap Name RemoteSchemaInputValueDefinition
-> HashMap Name Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RemoteSchemaInputValueDefinition -> Value
toJsonInpValInfo HashMap Name RemoteSchemaInputValueDefinition
_rrfiParamMap,
        Key
"remote_fields" Key -> RemoteFields -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RemoteFields
_rrfiRemoteFields,
        Key
"remote_schema" Key -> RemoteSchemaInfo -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RemoteSchemaInfo
_rrfiRemoteSchema
      ]
    where
      toJsonInpValInfo :: RemoteSchemaInputValueDefinition -> Value
toJsonInpValInfo (RemoteSchemaInputValueDefinition (G.InputValueDefinition Maybe Description
desc Name
name GType
type' Maybe (Value Void)
defVal [Directive Void]
_directives) Maybe (Value RemoteSchemaVariable)
_preset) =
        [(Key, Value)] -> Value
object
          [ Key
"desc" Key -> Maybe Description -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Description
desc,
            Key
"name" Key -> Name -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Name
name,
            Key
"def_val" Key -> Maybe Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Value Void -> Value) -> Maybe (Value Void) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value Void -> Value
graphQLValueToJSON Maybe (Value Void)
defVal,
            Key
"type" Key -> GType -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= GType
type'
          ]

-- FIXME: deduplicate this
graphQLValueToJSON :: G.Value Void -> Value
graphQLValueToJSON :: Value Void -> Value
graphQLValueToJSON = \case
  Value Void
G.VNull -> Value
Null
  G.VInt Integer
i -> Integer -> Value
forall a. ToJSON a => a -> Value
toJSON Integer
i
  G.VFloat Scientific
f -> Scientific -> Value
forall a. ToJSON a => a -> Value
toJSON Scientific
f
  G.VString Text
t -> Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
t
  G.VBoolean Bool
b -> Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
b
  G.VEnum (G.EnumValue Name
n) -> Name -> Value
forall a. ToJSON a => a -> Value
toJSON Name
n
  G.VList [Value Void]
values -> [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ Value Void -> Value
graphQLValueToJSON (Value Void -> Value) -> [Value Void] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value Void]
values
  G.VObject HashMap Name (Value Void)
objects -> HashMap Name Value -> Value
forall a. ToJSON a => a -> Value
toJSON (HashMap Name Value -> Value) -> HashMap Name Value -> Value
forall a b. (a -> b) -> a -> b
$ Value Void -> Value
graphQLValueToJSON (Value Void -> Value)
-> HashMap Name (Value Void) -> HashMap Name Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Name (Value Void)
objects

--------------------------------------------------------------------------------
-- template haskell generation

$(makeLenses ''ToSchemaRelationshipDef)
$(deriveJSON hasuraJSON ''ToSchemaRelationshipDef)