{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE TupleSections     #-}

-- | Aeson bridge for MessagePack
module Data.MessagePack.Aeson (
  -- * Conversion functions
  toAeson,
  fromAeson,
  viaFromJSON,
) where

import           Control.Monad.Validate (MonadValidate, refute)
import qualified Data.Aeson             as A
import qualified Data.Aeson.Key         as K
import qualified Data.Aeson.KeyMap      as KM
import           Data.Int               (Int64)
import           Data.MessagePack.Types as MP
import           Data.Scientific        (floatingOrInteger)
import           Data.String            (fromString)
import qualified Data.Vector            as V
import           Data.Word              (Word64)

-- | Convert 'MP.Object' to JSON 'A.Value'
toAeson :: MonadValidate MP.DecodeError m => MP.Object -> m A.Value
toAeson :: Object -> m Value
toAeson = \case
  Object
ObjectNil      -> Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
A.Null
  ObjectBool Bool
b   -> Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> (Bool -> Value) -> Bool -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
A.Bool (Bool -> m Value) -> Bool -> m Value
forall a b. (a -> b) -> a -> b
$ Bool
b
  ObjectInt Int64
n    -> Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> (Int64 -> Value) -> Int64 -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
A.Number (Scientific -> Value) -> (Int64 -> Scientific) -> Int64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> m Value) -> Int64 -> m Value
forall a b. (a -> b) -> a -> b
$ Int64
n
  ObjectWord Word64
n   -> Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> (Word64 -> Value) -> Word64 -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
A.Number (Scientific -> Value) -> (Word64 -> Scientific) -> Word64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> m Value) -> Word64 -> m Value
forall a b. (a -> b) -> a -> b
$ Word64
n
  ObjectFloat Float
f  -> Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> (Float -> Value) -> Float -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
A.Number (Scientific -> Value) -> (Float -> Scientific) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Float -> m Value) -> Float -> m Value
forall a b. (a -> b) -> a -> b
$ Float
f
  ObjectDouble Double
d -> Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> (Double -> Value) -> Double -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
A.Number (Scientific -> Value) -> (Double -> Scientific) -> Double -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> m Value) -> Double -> m Value
forall a b. (a -> b) -> a -> b
$ Double
d
  ObjectStr Text
t    -> Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> (Text -> Value) -> Text -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
A.String (Text -> m Value) -> Text -> m Value
forall a b. (a -> b) -> a -> b
$ Text
t
  ObjectBin ByteString
_    -> DecodeError -> m Value
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute DecodeError
"ObjectBin is not supported by JSON"
  ObjectArray Vector Object
v  -> Array -> Value
A.Array (Array -> Value) -> m Array -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object -> m Value) -> Vector Object -> m Array
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM Object -> m Value
forall (m :: * -> *).
MonadValidate DecodeError m =>
Object -> m Value
toAeson Vector Object
v
  ObjectMap Vector (Object, Object)
m    ->
    Object -> Value
A.Object (Object -> Value)
-> (Vector (Key, Value) -> Object) -> Vector (Key, Value) -> 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)
-> (Vector (Key, Value) -> [(Key, Value)])
-> Vector (Key, Value)
-> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Key, Value) -> [(Key, Value)]
forall a. Vector a -> [a]
V.toList
      (Vector (Key, Value) -> Value)
-> m (Vector (Key, Value)) -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Object, Object) -> m (Key, Value))
-> Vector (Object, Object) -> m (Vector (Key, Value))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
V.mapM (\(Object
k, Object
v) -> (,) (Key -> Value -> (Key, Value))
-> m Key -> m (Value -> (Key, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Key
K.fromText (Text -> Key) -> m Text -> m Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> m Text
from Object
k) m (Value -> (Key, Value)) -> m Value -> m (Key, Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> m Value
forall (m :: * -> *).
MonadValidate DecodeError m =>
Object -> m Value
toAeson Object
v) Vector (Object, Object)
m
      where from :: Object -> m Text
from = Config -> Object -> m Text
forall a (m :: * -> *).
(MessagePack a, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Object -> m a
MP.fromObjectWith Config
MP.defaultConfig
  ObjectExt Word8
_ ByteString
_  -> DecodeError -> m Value
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute DecodeError
"ObjectExt is not supported by JSON"

isWord64 :: Integer -> Bool
isWord64 :: Integer -> Bool
isWord64 Integer
n = Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
minBound :: Word64) Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64)

isInt64 :: Integer -> Bool
isInt64 :: Integer -> Bool
isInt64 Integer
n = Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
forall a. Bounded a => a
minBound :: Int64) Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
forall a. Bounded a => a
maxBound :: Int64)

-- | Convert JSON 'A.Value' to 'MP.Object'
fromAeson :: MonadValidate MP.DecodeError m => A.Value -> m MP.Object
fromAeson :: Value -> m Object
fromAeson = \case
  Value
A.Null      -> Object -> m Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
ObjectNil
  A.Bool Bool
b    -> Object -> m Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> m Object) -> (Bool -> Object) -> Bool -> m Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Object
ObjectBool (Bool -> m Object) -> Bool -> m Object
forall a b. (a -> b) -> a -> b
$ Bool
b
  A.Number Scientific
s  ->
    -- NOTE floatingOrInteger can OOM on untrusted input
    case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
s of
      Left  Double
f -> Object -> m Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> m Object) -> (Double -> Object) -> Double -> m Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Object
ObjectDouble (Double -> m Object) -> Double -> m Object
forall a b. (a -> b) -> a -> b
$ Double
f
      Right Integer
i
        | Integer -> Bool
isWord64 Integer
i -> Object -> m Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> m Object) -> (Integer -> Object) -> Integer -> m Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Object
ObjectWord (Word64 -> Object) -> (Integer -> Word64) -> Integer -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> m Object) -> Integer -> m Object
forall a b. (a -> b) -> a -> b
$ Integer
i
        | Integer -> Bool
isInt64  Integer
i -> Object -> m Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> m Object) -> (Integer -> Object) -> Integer -> m Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Object
ObjectInt  (Int64 -> Object) -> (Integer -> Int64) -> Integer -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> m Object) -> Integer -> m Object
forall a b. (a -> b) -> a -> b
$ Integer
i
        | Bool
otherwise  -> DecodeError -> m Object
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute DecodeError
"number out of bounds"
  A.String Text
t  -> Object -> m Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> m Object) -> (Text -> Object) -> Text -> m Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Object
ObjectStr (Text -> m Object) -> Text -> m Object
forall a b. (a -> b) -> a -> b
$ Text
t
  A.Array Array
v   -> Vector Object -> Object
ObjectArray (Vector Object -> Object) -> m (Vector Object) -> m Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> m Object) -> Array -> m (Vector Object)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> m Object
forall (m :: * -> *).
MonadValidate DecodeError m =>
Value -> m Object
fromAeson Array
v
  A.Object Object
o  -> Vector (Object, Object) -> Object
ObjectMap (Vector (Object, Object) -> Object)
-> ([(Object, Object)] -> Vector (Object, Object))
-> [(Object, Object)]
-> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Object, Object)] -> Vector (Object, Object)
forall a. [a] -> Vector a
V.fromList ([(Object, Object)] -> Object) -> m [(Object, Object)] -> m Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Key, Value) -> m (Object, Object))
-> [(Key, Value)] -> m [(Object, Object)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Key, Value) -> m (Object, Object)
forall (f :: * -> *).
MonadValidate DecodeError f =>
(Key, Value) -> f (Object, Object)
fromEntry (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
o)
    where
      fromEntry :: (Key, Value) -> f (Object, Object)
fromEntry (Key
k, Value
v) = (Text -> Object
ObjectStr (Key -> Text
K.toText Key
k),) (Object -> (Object, Object)) -> f Object -> f (Object, Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> f Object
forall (m :: * -> *).
MonadValidate DecodeError m =>
Value -> m Object
fromAeson Value
v

-- | Helpers to piggyback off a JSON encoder / decoder when creating a MessagePack
-- instance.
--
-- Not as efficient as a direct encoder.
viaFromJSON :: (MonadValidate MP.DecodeError m, A.FromJSON a) => MP.Object -> m a
viaFromJSON :: Object -> m a
viaFromJSON Object
o = do
  Value
v <- Object -> m Value
forall (m :: * -> *).
MonadValidate DecodeError m =>
Object -> m Value
toAeson Object
o
  case Value -> Result a
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
v of
    A.Success a
a -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    A.Error   String
e -> DecodeError -> m a
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute (String -> DecodeError
forall a. IsString a => String -> a
fromString String
e)