{-# LANGUAGE OverloadedStrings #-}

module Network.GRPC.Spec.RPC.JSON (
    JsonRpc

    -- Aeson support
  , JsonObject(..)
  , Required(..)
  , Optional(..)
  , DecodeFields -- opaque
  , EncodeFields -- opaque
  ) where

import Control.DeepSeq (NFData(..))
import Data.Aeson (ToJSON(..), FromJSON(..), (.=), (.:), (.:?))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.ByteString.Char8 qualified as BS.Char8
import Data.Kind
import Data.Proxy
import Data.String
import GHC.TypeLits

import Network.GRPC.Spec.CustomMetadata.Typed
import Network.GRPC.Spec.RPC
import Network.GRPC.Spec.RPC.StreamType

-- | gRPC using JSON as the message encoding
--
-- "JSON over gRPC" is a bit of an ambiguous phrase. It can be a very general
-- term, simply meaning using an otherwise-unspecified JSON encoding, or it can
-- refer to "Protobuf over JSON" (see
-- <https://protobuf.dev/programming-guides/proto3/#json>). In this module we
-- deal with the former, and don't deal with anything Protobuf-specific at all,
-- nor do we rely on any of the infrastructure generated by the Protobuf
-- compiler (in other words, there is no need to use @protoc@). See
-- <https://grpc.io/blog/grpc-with-json/> for a Java example of using gRPC with
-- JSON without Protobuf.
--
-- In the absence of the infrastructure provided by @protoc@, you will need to
-- manually provide 'Input' and 'Output' instances for each RPC you use.
-- For example:
--
-- > type Create   = JsonRpc KeyValueService "Create"
-- > type Delete   = JsonRpc KeyValueService "Delete"
-- > ..
-- >
-- > type instance Input  Create   = ..
-- > type instance Output Create   = ..
-- > type instance Input  Retrieve = ..
-- > type instance Output Retrieve = ..
-- > ..
--
-- On the client, you will need 'ToJSON' instances for inputs and 'FromJSON'
-- instances for outputs; on the server the situation is dual. You may find it
-- convenient to use t'JsonObject' (but this is certainly not required).
--
-- TODO: <https://github.com/well-typed/grapesy/issues/166>
-- We don't currently offer explicit support for "Protobuf JSON".
data JsonRpc (serv :: Symbol) (meth :: Symbol)

instance ( KnownSymbol serv
         , KnownSymbol meth

           -- Serialization
         , NFData (Input  (JsonRpc serv meth))
         , NFData (Output (JsonRpc serv meth))

           -- Debugging constraints
         , Show (Input  (JsonRpc serv meth))
         , Show (Output (JsonRpc serv meth))
         , Show (RequestMetadata (JsonRpc serv meth))
         , Show (ResponseInitialMetadata (JsonRpc serv meth))
         , Show (ResponseTrailingMetadata (JsonRpc serv meth))
         ) => IsRPC (JsonRpc serv meth) where
  rpcContentType :: Proxy (JsonRpc serv meth) -> ByteString
rpcContentType Proxy (JsonRpc serv meth)
_ = ByteString -> ByteString
defaultRpcContentType ByteString
"json"
  rpcServiceName :: HasCallStack => Proxy (JsonRpc serv meth) -> ByteString
rpcServiceName Proxy (JsonRpc serv meth)
_ = String -> ByteString
BS.Char8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy serv -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @serv)
  rpcMethodName :: HasCallStack => Proxy (JsonRpc serv meth) -> ByteString
rpcMethodName  Proxy (JsonRpc serv meth)
_ = String -> ByteString
BS.Char8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Proxy meth -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @meth)
  rpcMessageType :: HasCallStack => Proxy (JsonRpc serv meth) -> Maybe ByteString
rpcMessageType Proxy (JsonRpc serv meth)
_ = Maybe ByteString
forall a. Maybe a
Nothing

instance ( IsRPC (JsonRpc serv meth)

           -- Serialization constraints
         , ToJSON   (Input  (JsonRpc serv meth))
         , FromJSON (Output (JsonRpc serv meth))

           -- Metadata constraints
         , BuildMetadata (RequestMetadata          (JsonRpc serv meth))
         , ParseMetadata (ResponseInitialMetadata  (JsonRpc serv meth))
         , ParseMetadata (ResponseTrailingMetadata (JsonRpc serv meth))
         ) => SupportsClientRpc (JsonRpc serv meth) where
  rpcSerializeInput :: Proxy (JsonRpc serv meth)
-> Input (JsonRpc serv meth) -> ByteString
rpcSerializeInput    Proxy (JsonRpc serv meth)
_ = Input (JsonRpc serv meth) -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode
  rpcDeserializeOutput :: Proxy (JsonRpc serv meth)
-> ByteString -> Either String (Output (JsonRpc serv meth))
rpcDeserializeOutput Proxy (JsonRpc serv meth)
_ = ByteString -> Either String (Output (JsonRpc serv meth))
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode

instance ( IsRPC (JsonRpc serv meth)

           -- Serialization constraints
         , FromJSON (Input  (JsonRpc serv meth))
         , ToJSON   (Output (JsonRpc serv meth))

           -- Metadata constraints
         , ParseMetadata (RequestMetadata           (JsonRpc serv meth))
         , BuildMetadata (ResponseInitialMetadata   (JsonRpc serv meth))
         , StaticMetadata (ResponseTrailingMetadata (JsonRpc serv meth))
         ) => SupportsServerRpc (JsonRpc serv meth) where
  rpcDeserializeInput :: Proxy (JsonRpc serv meth)
-> ByteString -> Either String (Input (JsonRpc serv meth))
rpcDeserializeInput Proxy (JsonRpc serv meth)
_ = ByteString -> Either String (Input (JsonRpc serv meth))
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode
  rpcSerializeOutput :: Proxy (JsonRpc serv meth)
-> Output (JsonRpc serv meth) -> ByteString
rpcSerializeOutput  Proxy (JsonRpc serv meth)
_ = Output (JsonRpc serv meth) -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode

-- | For JSON protocol we do not check communication protocols
instance ValidStreamingType styp
      => SupportsStreamingType (JsonRpc serv meth) styp

{-------------------------------------------------------------------------------
  Support for constructing JSON objects
-------------------------------------------------------------------------------}

-- | Convenient way to construct JSON values
--
-- Example:
--
-- > type instance Input Create =
-- >   JsonObject '[ '("key"   , Required Key)
-- >               , '("value" , Required Value)
-- >               ]
data JsonObject :: [(Symbol, Type)] -> Type where
  JsonObject :: JsonObject '[]
  (:*) :: forall f x fs. x -> JsonObject fs -> JsonObject ('(f, x) : fs)

instance Show (JsonObject '[]) where
  showsPrec :: Int -> JsonObject '[] -> ShowS
showsPrec Int
_ JsonObject '[]
JsonObject = String -> ShowS
showString String
"JsonObject"

instance (Show x, Show (JsonObject fs))
      => Show (JsonObject ('(f, x) : fs)) where
  showsPrec :: Int -> JsonObject ('(f, x) : fs) -> ShowS
showsPrec Int
p (x
x :* JsonObject fs
xs) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        Int -> x -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
6 x
x
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" :* "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> JsonObject fs -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
6 JsonObject fs
xs

instance NFData (JsonObject '[]) where
  rnf :: JsonObject '[] -> ()
rnf JsonObject '[]
JsonObject = ()

instance (NFData x, NFData (JsonObject fs))
      => NFData (JsonObject ('(f, x) : fs)) where
  rnf :: JsonObject ('(f, x) : fs) -> ()
rnf (x
x :* JsonObject fs
xs) = (x, JsonObject fs) -> ()
forall a. NFData a => a -> ()
rnf (x
x, JsonObject fs
xs)

-- | Required field
newtype Required a = Required {
     forall a. Required a -> a
getRequired :: a
   }
 deriving stock (Int -> Required a -> ShowS
[Required a] -> ShowS
Required a -> String
(Int -> Required a -> ShowS)
-> (Required a -> String)
-> ([Required a] -> ShowS)
-> Show (Required a)
forall a. Show a => Int -> Required a -> ShowS
forall a. Show a => [Required a] -> ShowS
forall a. Show a => Required a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Required a -> ShowS
showsPrec :: Int -> Required a -> ShowS
$cshow :: forall a. Show a => Required a -> String
show :: Required a -> String
$cshowList :: forall a. Show a => [Required a] -> ShowS
showList :: [Required a] -> ShowS
Show)
 deriving newtype (Required a -> ()
(Required a -> ()) -> NFData (Required a)
forall a. NFData a => Required a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => Required a -> ()
rnf :: Required a -> ()
NFData)

-- | Optional field
--
-- 'Maybe' will be represented by the /absence/ of the field in the object.
newtype Optional a = Optional {
      forall a. Optional a -> Maybe a
getOptional :: Maybe a
    }
 deriving stock (Int -> Optional a -> ShowS
[Optional a] -> ShowS
Optional a -> String
(Int -> Optional a -> ShowS)
-> (Optional a -> String)
-> ([Optional a] -> ShowS)
-> Show (Optional a)
forall a. Show a => Int -> Optional a -> ShowS
forall a. Show a => [Optional a] -> ShowS
forall a. Show a => Optional a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Optional a -> ShowS
showsPrec :: Int -> Optional a -> ShowS
$cshow :: forall a. Show a => Optional a -> String
show :: Optional a -> String
$cshowList :: forall a. Show a => [Optional a] -> ShowS
showList :: [Optional a] -> ShowS
Show)
 deriving newtype (Optional a -> ()
(Optional a -> ()) -> NFData (Optional a)
forall a. NFData a => Optional a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => Optional a -> ()
rnf :: Optional a -> ()
NFData)

infixr 5 :*

-- | Auxiliary class used for the 'ToJSON' instance for t'JsonObject'
--
-- It is not possible (nor necessary) to define additional instances.
class EncodeFields fs where
  encodeFields :: JsonObject fs -> [Aeson.Pair]
  encodeFields = JsonObject fs -> [Pair]
forall a. HasCallStack => a
undefined

instance EncodeFields '[] where
  encodeFields :: JsonObject '[] -> [Pair]
encodeFields JsonObject '[]
JsonObject = []

instance (KnownSymbol f, ToJSON x, EncodeFields fs)
      => EncodeFields ('(f, Required x) : fs) where
  encodeFields :: JsonObject ('(f, Required x) : fs) -> [Pair]
encodeFields (Required x
x :* JsonObject fs
xs) =
        (String -> Key
forall a. IsString a => String -> a
fromString (Proxy f -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @f)) Key -> x -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= x
x)
      Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: JsonObject fs -> [Pair]
forall (fs :: [(Symbol, *)]).
EncodeFields fs =>
JsonObject fs -> [Pair]
encodeFields JsonObject fs
xs

instance (KnownSymbol f, ToJSON x, EncodeFields fs)
      => EncodeFields ('(f, Optional x) : fs) where
  encodeFields :: JsonObject ('(f, Optional x) : fs) -> [Pair]
encodeFields (Optional Maybe x
Nothing  :* JsonObject fs
xs) = JsonObject fs -> [Pair]
forall (fs :: [(Symbol, *)]).
EncodeFields fs =>
JsonObject fs -> [Pair]
encodeFields JsonObject fs
xs
  encodeFields (Optional (Just x
x) :* JsonObject fs
xs) =
        (String -> Key
forall a. IsString a => String -> a
fromString (Proxy f -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @f)) Key -> x -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= x
x)
      Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: JsonObject fs -> [Pair]
forall (fs :: [(Symbol, *)]).
EncodeFields fs =>
JsonObject fs -> [Pair]
encodeFields JsonObject fs
xs

instance EncodeFields fs => ToJSON (JsonObject fs) where
  toJSON :: JsonObject fs -> Value
toJSON = [Pair] -> Value
Aeson.object ([Pair] -> Value)
-> (JsonObject fs -> [Pair]) -> JsonObject fs -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonObject fs -> [Pair]
forall (fs :: [(Symbol, *)]).
EncodeFields fs =>
JsonObject fs -> [Pair]
encodeFields

-- | Auxiliary class used for the 'FromJSON' instance for t'JsonObject'
--
-- It is not possible (nor necessary) to define additional instances.
class DecodeFields fs where
  decodeFields :: Aeson.Object -> Aeson.Parser (JsonObject fs)
  decodeFields = Object -> Parser (JsonObject fs)
forall a. HasCallStack => a
undefined

instance DecodeFields '[] where
  decodeFields :: Object -> Parser (JsonObject '[])
decodeFields Object
_ = JsonObject '[] -> Parser (JsonObject '[])
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return JsonObject '[]
JsonObject

instance (KnownSymbol f, FromJSON x, DecodeFields fs)
      => DecodeFields ('(f, Required x) : fs) where
  decodeFields :: Object -> Parser (JsonObject ('(f, Required x) : fs))
decodeFields Object
obj = do
      fs <- Object -> Parser (JsonObject fs)
forall (fs :: [(Symbol, *)]).
DecodeFields fs =>
Object -> Parser (JsonObject fs)
decodeFields Object
obj
      x  <- obj .: fromString (symbolVal (Proxy @f))
      return (Required x :* fs)

instance (KnownSymbol f, FromJSON x, DecodeFields fs)
      => DecodeFields ('(f, Optional x) : fs) where
  decodeFields :: Object -> Parser (JsonObject ('(f, Optional x) : fs))
decodeFields Object
obj = do
      fs <- Object -> Parser (JsonObject fs)
forall (fs :: [(Symbol, *)]).
DecodeFields fs =>
Object -> Parser (JsonObject fs)
decodeFields Object
obj
      x  <- obj .:? fromString (symbolVal (Proxy @f))
      return (Optional x :* fs)

instance DecodeFields fs => FromJSON (JsonObject fs) where
  parseJSON :: Value -> Parser (JsonObject fs)
parseJSON = String
-> (Object -> Parser (JsonObject fs))
-> Value
-> Parser (JsonObject fs)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"JsonObject" ((Object -> Parser (JsonObject fs))
 -> Value -> Parser (JsonObject fs))
-> (Object -> Parser (JsonObject fs))
-> Value
-> Parser (JsonObject fs)
forall a b. (a -> b) -> a -> b
$ Object -> Parser (JsonObject fs)
forall (fs :: [(Symbol, *)]).
DecodeFields fs =>
Object -> Parser (JsonObject fs)
decodeFields