{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Proto3.Suite.JSONPB.Class where
import qualified Data.Aeson as A (Encoding, FromJSON (..),
FromJSONKey (..),
FromJSONKeyFunction (..),
ToJSON (..), Value (..),
ToJSON1(..), FromJSON1(..),
ToJSONKey(..),
decode, eitherDecode, json,
(.!=))
import qualified Data.Aeson.Encoding as E
import qualified Data.Aeson.Encoding.Internal as E
import qualified Data.Aeson.Internal as A (formatError, iparse)
import qualified Data.Aeson.Parser as A (eitherDecodeWith)
import qualified Data.Aeson.Types as A (Object, Pair, Parser,
Series,
explicitParseField,
explicitParseFieldMaybe,
object, typeMismatch)
import qualified Data.Attoparsec.ByteString as Atto (skipWhile)
import qualified Data.Attoparsec.ByteString.Char8 as Atto (Parser, endOfInput)
import qualified Data.Binary.Builder as Builder
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as LBS
import Data.Coerce
import Data.Maybe
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Vector as V
import GHC.Exts (Proxy#, proxy#)
import GHC.Generics (Generic)
import GHC.Int (Int32, Int64)
import GHC.Word (Word32, Word64)
import Proto3.Suite.Class (HasDefault (def, isDefault),
Named (nameOf))
import Proto3.Suite.Types (Enumerated (..), Fixed (..))
import Proto3.Wire.Class (ProtoEnum(..))
import Test.QuickCheck.Arbitrary (Arbitrary(..))
class ToJSONPB a where
toJSONPB :: a -> Options -> A.Value
toEncodingPB :: a -> Options -> A.Encoding
toEncodingPB x = A.toEncoding . toJSONPB x
instance ToJSONPB A.Value where
toJSONPB v _ = v
toEncodingPB v _ = E.value v
instance ToJSONPB A.Encoding where
toJSONPB e _ = fromMaybe A.Null . A.decode . Builder.toLazyByteString . E.fromEncoding $ e
toEncodingPB e _ = e
class FromJSONPB a where
parseJSONPB :: A.Value -> A.Parser a
instance FromJSONPB A.Value where
parseJSONPB = pure
encode :: ToJSONPB a => Options -> a -> LBS.ByteString
encode opts x = E.encodingToLazyByteString (toEncodingPB x opts)
{-# INLINE encode #-}
eitherDecode :: FromJSONPB a => LBS.ByteString -> Either String a
eitherDecode = eitherFormatError . A.eitherDecodeWith jsonEOF (A.iparse parseJSONPB)
where
eitherFormatError = either (Left . uncurry A.formatError) Right
{-# INLINE eitherFormatError #-}
jsonEOF :: Atto.Parser A.Value
jsonEOF = A.json <* skipSpace <* Atto.endOfInput
where
skipSpace :: Atto.Parser ()
skipSpace = Atto.skipWhile $ \w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09
{-# INLINE skipSpace #-}
{-# INLINE eitherDecode #-}
class Monoid m => KeyValuePB m where
pair :: ToJSONPB v => Text -> v -> Options -> m
instance KeyValuePB A.Series where pair k v opts = E.pair k (toEncodingPB v opts)
instance KeyValuePB [A.Pair] where pair k v opts = pure (k, toJSONPB v opts)
(.=) :: (HasDefault v, ToJSONPB v, KeyValuePB kvp) => Text -> v -> Options -> kvp
k .= v = mk
where
mk opts@Options{..}
| not optEmitDefaultValuedFields && isDefault v
= mempty
| otherwise
= pair k v opts
(.:) :: (FromJSONPB a, HasDefault a) => A.Object -> Text -> A.Parser a
obj .: key = obj .:? key A..!= def
where
(.:?) = A.explicitParseFieldMaybe parseJSONPB
parseField :: FromJSONPB a
=> A.Object -> Text -> A.Parser a
parseField = A.explicitParseField parseJSONPB
instance HasDefault E.Encoding where
def = E.empty
isDefault = E.nullEncoding
instance HasDefault A.Value where
def = A.Null
isDefault = (== A.Null)
data Options = Options
{ optEmitDefaultValuedFields :: Bool
, optEmitNamedOneof :: Bool
} deriving (Eq, Generic, Show)
instance Arbitrary Options where
arbitrary = Options <$> arbitrary <*> arbitrary
defaultOptions :: Options
defaultOptions = Options
{ optEmitDefaultValuedFields = True
, optEmitNamedOneof = True
}
jsonPBOptions :: Options
jsonPBOptions = Options
{ optEmitDefaultValuedFields = False
, optEmitNamedOneof = False
}
dropNamedPrefix :: Named a => Proxy# a -> String -> String
dropNamedPrefix p = drop (length (nameOf p :: String))
object :: [Options -> [A.Pair]] -> Options -> A.Value
object fs = A.object . mconcat fs
objectOrNull :: [Options -> [A.Pair]] -> Options -> A.Value
objectOrNull fs options = case mconcat fs options of
[] -> A.Null
nonEmpty -> A.object nonEmpty
pairs :: [Options -> A.Series] -> Options -> E.Encoding
pairs fs = E.pairs . mconcat fs
pairsOrNull :: [Options -> A.Series] -> Options -> E.Encoding
pairsOrNull fs options = case mconcat fs options of
E.Empty -> E.null_
nonEmpty -> E.pairs nonEmpty
enumFieldString :: forall a. (Named a, Show a) => a -> A.Value
enumFieldString = A.String . T.pack . dropNamedPrefix (proxy# :: Proxy# a) . show
enumFieldEncoding :: forall a. (Named a, Show a) => a -> A.Encoding
enumFieldEncoding = E.string . dropNamedPrefix (proxy# :: Proxy# a) . show
toAesonValue :: ToJSONPB a => a -> A.Value
toAesonValue = flip toJSONPB defaultOptions
toAesonEncoding :: ToJSONPB a => a -> A.Encoding
toAesonEncoding = flip toEncodingPB defaultOptions
parseFP :: (A.FromJSON a, A.FromJSONKey a) => String -> A.Value -> A.Parser a
parseFP tyDesc v = case v of
A.Number{} -> A.parseJSON v
A.String t -> case A.fromJSONKey of
A.FromJSONKeyTextParser p
-> p t
_ -> fail "internal: parseKeyPB: unexpected FromJSONKey summand"
_ -> A.typeMismatch tyDesc v
parseNumOrDecimalString :: (A.FromJSON a) => String -> A.Value -> A.Parser a
parseNumOrDecimalString tyDesc v = case v of
A.Number{} -> A.parseJSON v
A.String t -> either fail pure . A.eitherDecode . TL.encodeUtf8 . TL.fromStrict $ t
_ -> A.typeMismatch tyDesc v
instance ToJSONPB Bool where
toJSONPB = const . A.toJSON
toEncodingPB = const . A.toEncoding
instance FromJSONPB Bool where
parseJSONPB = A.parseJSON
instance ToJSONPB Int32 where
toJSONPB = const . A.toJSON
toEncodingPB = const . A.toEncoding
instance FromJSONPB Int32 where
parseJSONPB = parseNumOrDecimalString "int32 / sint32"
instance ToJSONPB Word32 where
toJSONPB = const . A.toJSON
toEncodingPB = const . A.toEncoding
instance FromJSONPB Word32 where
parseJSONPB = parseNumOrDecimalString "uint32"
instance ToJSONPB Int64 where
toJSONPB x _ = A.String . T.pack . show $ x
toEncodingPB x _ = E.string (show x)
instance FromJSONPB Int64 where
parseJSONPB = parseNumOrDecimalString "int64 / sint64"
instance ToJSONPB Word64 where
toJSONPB x _ = A.String . T.pack . show $ x
toEncodingPB x _ = E.string (show x)
instance FromJSONPB Word64 where
parseJSONPB = parseNumOrDecimalString "int64 / sint64"
instance ToJSONPB (Fixed Word32) where
toJSONPB = coerce (toJSONPB @Word32)
toEncodingPB = coerce (toEncodingPB @Word32)
instance FromJSONPB (Fixed Word32) where
parseJSONPB = coerce (parseJSONPB @Word32)
instance ToJSONPB (Fixed Word64) where
toJSONPB = coerce (toJSONPB @Word64)
toEncodingPB = coerce (toEncodingPB @Word64)
instance FromJSONPB (Fixed Word64) where
parseJSONPB = coerce (parseJSONPB @Word64)
instance ToJSONPB (Fixed Int32) where
toJSONPB = coerce (toJSONPB @Int32)
toEncodingPB = coerce (toEncodingPB @Int32)
instance FromJSONPB (Fixed Int32) where
parseJSONPB = coerce (parseJSONPB @Int32)
instance ToJSONPB (Fixed Int64) where
toJSONPB = coerce (toJSONPB @Int64)
toEncodingPB = coerce (toEncodingPB @Int64)
instance FromJSONPB (Fixed Int64) where
parseJSONPB = coerce (parseJSONPB @Int64)
instance ToJSONPB Float where
toJSONPB = const . A.toJSON
toEncodingPB = const . A.toEncoding
instance FromJSONPB Float where
parseJSONPB = parseFP "float"
instance ToJSONPB Double where
toJSONPB = const . A.toJSON
toEncodingPB = const . A.toEncoding
instance FromJSONPB Double where
parseJSONPB = parseFP "double"
instance ToJSONPB TL.Text where
toJSONPB = const . A.toJSON
toEncodingPB = const . A.toEncoding
instance FromJSONPB TL.Text where
parseJSONPB = A.parseJSON
bsToJSONPB :: BS.ByteString -> A.Value
bsToJSONPB (T.decodeUtf8' . B64.encode -> ebs) = case ebs of
Right bs -> A.toJSON bs
Left e -> error ("internal: failed to encode B64-encoded bytestring: " ++ show e)
instance ToJSONPB BS.ByteString where
toJSONPB bs _ = bsToJSONPB bs
toEncodingPB bs opts = E.value (toJSONPB bs opts)
instance FromJSONPB BS.ByteString where
parseJSONPB (A.String b64enc) = pure . B64.decodeLenient . T.encodeUtf8 $ b64enc
parseJSONPB v = A.typeMismatch "bytes" v
enumToJSONPB :: (e -> Options -> a)
-> a
-> Enumerated e
-> Options
-> a
enumToJSONPB enc null_ (Enumerated e) opts = either err (\input -> enc input opts) e
where
err 0 = error "enumToJSONPB: The first enum value must be zero in proto3"
err _ = null_
instance ToJSONPB e => ToJSONPB (Enumerated e) where
toJSONPB = enumToJSONPB toJSONPB A.Null
toEncodingPB = enumToJSONPB toEncodingPB E.null_
instance (ProtoEnum e, FromJSONPB e) => FromJSONPB (Enumerated e) where
parseJSONPB A.Null = pure def
parseJSONPB v = Enumerated . Right <$> parseJSONPB v
instance ToJSONPB a => ToJSONPB (V.Vector a) where
toJSONPB v opts = A.Array (V.map (\x -> toJSONPB x opts) v)
toEncodingPB v opts = E.list (\x -> toEncodingPB x opts) (V.toList v)
instance FromJSONPB a => FromJSONPB (V.Vector a) where
parseJSONPB (A.Array vs) = mapM parseJSONPB vs
parseJSONPB A.Null = pure []
parseJSONPB v = A.typeMismatch "repeated" v
instance ToJSONPB a => ToJSONPB (Maybe a) where
toJSONPB mx opts = maybe A.Null (\x -> toJSONPB x opts) mx
toEncodingPB mx opts = maybe E.null_ (\x -> toEncodingPB x opts) mx
instance FromJSONPB a => FromJSONPB (Maybe a) where
parseJSONPB A.Null = pure Nothing
parseJSONPB v = fmap Just (parseJSONPB v)
instance (A.ToJSONKey k, ToJSONPB k, ToJSONPB v) => ToJSONPB (M.Map k v) where
toJSONPB m opts = A.liftToJSON @(M.Map k) (`toJSONPB` opts) (A.Array . V.fromList . map (`toJSONPB` opts)) m
toEncodingPB m opts = A.liftToEncoding @(M.Map k) (`toEncodingPB` opts) (E.list (`toEncodingPB` opts)) m
instance (Ord k, A.FromJSONKey k, FromJSONPB k, FromJSONPB v) => FromJSONPB (M.Map k v) where
parseJSONPB = A.liftParseJSON @(M.Map k) parseJSONPB parseList
where
parseList (A.Array a) = traverse parseJSONPB (V.toList a)
parseList v = A.typeMismatch "not a list" v