JSON.hs

{-# 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 _ = defaultRpcContentType "json"
  rpcServiceName _ = BS.Char8.pack $ symbolVal (Proxy @serv)
  rpcMethodName  _ = BS.Char8.pack $ symbolVal (Proxy @meth)
  rpcMessageType _ = 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    _ = Aeson.encode
  rpcDeserializeOutput _ = 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 _ = Aeson.eitherDecode
  rpcSerializeOutput  _ = 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 _ JsonObject = showString "JsonObject"

instance (Show x, Show (JsonObject fs))
      => Show (JsonObject ('(f, x) : fs)) where
  showsPrec p (x :* xs) = showParen (p >= 6) $
        showsPrec 6 x
      . showString " :* "
      . showsPrec 6 xs

instance NFData (JsonObject '[]) where
  rnf JsonObject = ()

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

-- | Required field
newtype Required a = Required {
     getRequired :: a
   }
 deriving stock (Show)
 deriving newtype (NFData)

-- | Optional field
--
-- 'Maybe' will be represented by the /absence/ of the field in the object.
newtype Optional a = Optional {
      getOptional :: Maybe a
    }
 deriving stock (Show)
 deriving newtype (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 = undefined

instance EncodeFields '[] where
  encodeFields JsonObject = []

instance (KnownSymbol f, ToJSON x, EncodeFields fs)
      => EncodeFields ('(f, Required x) : fs) where
  encodeFields (Required x :* xs) =
        (fromString (symbolVal (Proxy @f)) .= x)
      : encodeFields xs

instance (KnownSymbol f, ToJSON x, EncodeFields fs)
      => EncodeFields ('(f, Optional x) : fs) where
  encodeFields (Optional Nothing  :* xs) = encodeFields xs
  encodeFields (Optional (Just x) :* xs) =
        (fromString (symbolVal (Proxy @f)) .= x)
      : encodeFields xs

instance EncodeFields fs => ToJSON (JsonObject fs) where
  toJSON = Aeson.object . 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 = undefined

instance DecodeFields '[] where
  decodeFields _ = return JsonObject

instance (KnownSymbol f, FromJSON x, DecodeFields fs)
      => DecodeFields ('(f, Required x) : fs) where
  decodeFields obj = do
      fs <- decodeFields 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 obj = do
      fs <- decodeFields obj
      x  <- obj .:? fromString (symbolVal (Proxy @f))
      return (Optional x :* fs)

instance DecodeFields fs => FromJSON (JsonObject fs) where
  parseJSON = Aeson.withObject "JsonObject" $ decodeFields