{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP          #-}

module Codec.CBOR.JSON
 ( encodeValue
 , decodeValue
 ) where

import           Data.Monoid
import           Control.Applicative
import           Prelude hiding (decodeFloat)

import           Codec.CBOR.Encoding
import           Codec.CBOR.Decoding
import           Data.Aeson                          ( Value(..) )
import qualified Data.Aeson                          as Aeson
import qualified Data.ByteString.Base64.URL          as Base64url
import           Data.Scientific                     as Scientific
import qualified Data.Text                           as T
import qualified Data.Text.Encoding                  as TE
import qualified Data.Vector                         as V

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key                      as K
import qualified Data.Aeson.KeyMap                   as KM
#else
import qualified Data.HashMap.Lazy                   as HM
#endif

-- | Encode a JSON value into CBOR.
encodeValue :: Value -> Encoding
encodeValue :: Value -> Encoding
encodeValue (Object Object
vs) = Object -> Encoding
encodeObject Object
vs
encodeValue (Array  Array
vs) = Array -> Encoding
encodeArray  Array
vs
encodeValue (String Text
s)  = Text -> Encoding
encodeString Text
s
encodeValue (Number Scientific
n)  = case forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
n of
                            Left  Double
d -> Double -> Encoding
encodeDouble  Double
d
                            Right Integer
i -> Integer -> Encoding
encodeInteger Integer
i
encodeValue (Bool   Bool
b)  = Bool -> Encoding
encodeBool Bool
b
encodeValue  Value
Null       = Encoding
encodeNull

encodeObject :: Aeson.Object -> Encoding
encodeObject :: Object -> Encoding
encodeObject Object
vs =
     Word -> Encoding
encodeMapLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)
  forall a. Semigroup a => a -> a -> a
<> forall {v} {a}. (Key -> v -> a -> a) -> a -> KeyMap v -> a
foldrWithKey (\Key
k Value
v Encoding
r -> Key -> Encoding
encodeString' Key
k forall a. Semigroup a => a -> a -> a
<> Value -> Encoding
encodeValue Value
v forall a. Semigroup a => a -> a -> a
<> Encoding
r) forall a. Monoid a => a
mempty Object
vs
  where
#if MIN_VERSION_aeson(2,0,0)
    size :: Int
size = forall v. KeyMap v -> Int
KM.size Object
vs
    foldrWithKey :: (Key -> v -> a -> a) -> a -> KeyMap v -> a
foldrWithKey = forall {v} {a}. (Key -> v -> a -> a) -> a -> KeyMap v -> a
KM.foldrWithKey
    encodeString' :: Key -> Encoding
encodeString' = Text -> Encoding
encodeString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
#else
    size = HM.size vs
    foldrWithKey = HM.foldrWithKey
    encodeString' = encodeString
#endif

encodeArray :: Aeson.Array -> Encoding
encodeArray :: Array -> Encoding
encodeArray Array
vs =
    Word -> Encoding
encodeListLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Vector a -> Int
V.length Array
vs))
 forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b -> b) -> b -> Vector a -> b
V.foldr (\Value
v Encoding
r -> Value -> Encoding
encodeValue Value
v forall a. Semigroup a => a -> a -> a
<> Encoding
r) forall a. Monoid a => a
mempty Array
vs

-- | Decode an arbitrary CBOR value into JSON.
decodeValue :: Bool -> Decoder s Value
decodeValue :: forall s. Bool -> Decoder s Value
decodeValue Bool
lenient = do
    TokenType
tkty <- forall s. Decoder s TokenType
peekTokenType
    case TokenType
tkty of
      TokenType
TypeUInt    -> forall s. Decoder s Value
decodeNumberIntegral
      TokenType
TypeUInt64  -> forall s. Decoder s Value
decodeNumberIntegral
      TokenType
TypeNInt    -> forall s. Decoder s Value
decodeNumberIntegral
      TokenType
TypeNInt64  -> forall s. Decoder s Value
decodeNumberIntegral
      TokenType
TypeInteger -> forall s. Decoder s Value
decodeNumberIntegral
      TokenType
TypeFloat16 -> forall s. Decoder s Value
decodeNumberFloat16
      TokenType
TypeFloat32 -> forall s. Decoder s Value
decodeNumberFloating
      TokenType
TypeFloat64 -> forall s. Decoder s Value
decodeNumberFloating
      TokenType
TypeBool    -> Bool -> Value
Bool   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Bool
decodeBool
      TokenType
TypeNull    -> Value
Null   forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  forall s. Decoder s ()
decodeNull
      TokenType
TypeString  -> Text -> Value
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Text
decodeString

      TokenType
TypeListLen      -> forall s. Decoder s Int
decodeListLen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s. Bool -> Int -> Decoder s Value
decodeListN Bool
lenient
      TokenType
TypeListLenIndef -> forall s. Decoder s ()
decodeListLenIndef forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. Bool -> [Value] -> Decoder s Value
decodeListIndef Bool
lenient []
      TokenType
TypeMapLen       -> forall s. Decoder s Int
decodeMapLen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall s. Bool -> Int -> Object -> Decoder s Value
decodeMapN Bool
lenient) forall a. Monoid a => a
mempty

      TokenType
TypeBytes   -> ByteString -> Value
bytesToBase64Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s ByteString
decodeBytes

      TokenType
_           -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected CBOR token type for a JSON value: "
                         forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TokenType
tkty
    where
      bytesToBase64Text :: ByteString -> Value
bytesToBase64Text = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeLatin1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64url.encode


decodeNumberIntegral :: Decoder s Value
decodeNumberIntegral :: forall s. Decoder s Value
decodeNumberIntegral = Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Integer
decodeInteger

decodeNumberFloating :: Decoder s Value
decodeNumberFloating :: forall s. Decoder s Value
decodeNumberFloating = Scientific -> Value
Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => a -> Scientific
Scientific.fromFloatDigits forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Double
decodeDouble

decodeNumberFloat16 :: Decoder s Value
decodeNumberFloat16 :: forall s. Decoder s Value
decodeNumberFloat16 = do
    Float
f <- forall s. Decoder s Float
decodeFloat
    if forall a. RealFloat a => a -> Bool
isNaN Float
f Bool -> Bool -> Bool
|| forall a. RealFloat a => a -> Bool
isInfinite Float
f
        then forall (m :: * -> *) a. Monad m => a -> m a
return Value
Null
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Number (forall a. RealFloat a => a -> Scientific
Scientific.fromFloatDigits Float
f)

decodeListN :: Bool -> Int -> Decoder s Value
decodeListN :: forall s. Bool -> Int -> Decoder s Value
decodeListN !Bool
lenient !Int
n = do
  Array
vec <- forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
V.replicateM Int
n (forall s. Bool -> Decoder s Value
decodeValue Bool
lenient)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Array -> Value
Array Array
vec

decodeListIndef :: Bool -> [Value] -> Decoder s Value
decodeListIndef :: forall s. Bool -> [Value] -> Decoder s Value
decodeListIndef !Bool
lenient [Value]
acc = do
    Bool
stop <- forall s. Decoder s Bool
decodeBreakOr
    if Bool
stop then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Array -> Value
Array (forall a. [a] -> Vector a
V.fromList (forall a. [a] -> [a]
reverse [Value]
acc))
            else do !Value
tm <- forall s. Bool -> Decoder s Value
decodeValue Bool
lenient
                    forall s. Bool -> [Value] -> Decoder s Value
decodeListIndef Bool
lenient (Value
tm forall a. a -> [a] -> [a]
: [Value]
acc)

decodeMapN :: Bool -> Int -> Aeson.Object -> Decoder s Value
decodeMapN :: forall s. Bool -> Int -> Object -> Decoder s Value
decodeMapN !Bool
lenient !Int
n Object
acc =
    case Int
n of
      Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Object -> Value
Object Object
acc
      Int
_ -> do
        !Text
tk <- forall s. Bool -> Decoder s Value
decodeValue Bool
lenient forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Value
v -> case Value
v of
                 String Text
s           -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
                 -- These cases are only allowed when --lenient is passed,
                 -- as printing them as strings may result in key collisions.
                 Number Scientific
d | Bool
lenient -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (forall a. Show a => a -> String
show Scientific
d)
                 Bool   Bool
b | Bool
lenient -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (forall a. Show a => a -> String
show Bool
b)
                 Value
_        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Could not decode map key type"
        !Value
tv  <- forall s. Bool -> Decoder s Value
decodeValue Bool
lenient
        forall s. Bool -> Int -> Object -> Decoder s Value
decodeMapN Bool
lenient (Int
nforall a. Num a => a -> a -> a
-Int
1) (forall {v}. Text -> v -> KeyMap v -> KeyMap v
insert Text
tk Value
tv Object
acc)
  where
#if MIN_VERSION_aeson(2,0,0)
    insert :: Text -> v -> KeyMap v -> KeyMap v
insert Text
k v
v KeyMap v
m = forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert (Text -> Key
K.fromText Text
k) v
v KeyMap v
m
#else
    insert k v m = HM.insert k v m
#endif