{-# LANGUAGE BangPatterns #-}
module Data.Binary.Serialise.CBOR.JSON (
    cborToJson,
    jsonToCbor,
    encodeJSON,
    decodeJSON,
  ) where

import qualified Data.Aeson          as JSON
import qualified Data.Scientific     as Scientific
import qualified Data.Vector         as Vec
import qualified Data.HashMap.Strict as HashMap

import           Data.Text (Text)
import qualified Data.Text                       as Text
import qualified Data.Text.Encoding              as Text
import qualified Data.Text.Lazy                  as Text.Lazy
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy            as LBS
import qualified Data.ByteString.Base64          as Base64
-- import qualified Data.ByteString.Base64.URL      as Base64url
import qualified Data.ByteString.Base16          as Base16

import Codec.Serialise.Decoding
import Codec.Serialise.Encoding
import Codec.CBOR.Term as CBOR
import Codec.Serialise

import Control.Applicative
import Prelude


instance Serialise JSON.Value where
  encode :: Value -> Encoding
encode = Value -> Encoding
encodeJSON
  decode :: Decoder s Value
decode = Decoder s Value
forall s. Decoder s Value
decodeJSON

encodeJSON :: JSON.Value -> Encoding
encodeJSON :: Value -> Encoding
encodeJSON = Term -> Encoding
forall a. Serialise a => a -> Encoding
encode (Term -> Encoding) -> (Value -> Term) -> Value -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Term
jsonToCbor

decodeJSON :: Decoder s JSON.Value
decodeJSON :: Decoder s Value
decodeJSON = Term -> Value
cborToJson (Term -> Value) -> Decoder s Term -> Decoder s Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Term
forall a s. Serialise a => Decoder s a
decode

-- Most of the types in CBOR have direct analogs in JSON.  However, some
-- do not, and someone implementing a CBOR-to-JSON converter has to
-- consider what to do in those cases.  The following non-normative
-- advice deals with these by converting them to a single substitute
-- value, such as a JSON null.

cborToJson :: CBOR.Term -> JSON.Value

-- o  An integer (major type 0 or 1) becomes a JSON number.

-- We modify this advice by only converting numbers in the range -2^53 .. 2^53
-- and otherwise handling them like big nums

cborToJson :: Term -> Value
cborToJson (CBOR.TInt Int
n) = Term -> Value
cborToJson (Integer -> Term
CBOR.TInteger (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n))

-- o  A byte string (major type 2) that is not embedded in a tag that
--    specifies a proposed encoding is encoded in base64url without
--    padding and becomes a JSON string.

cborToJson (CBOR.TBytes  ByteString
bs) = Text -> Value
JSON.String (ByteString -> Text
base64url ByteString
bs)
cborToJson (CBOR.TBytesI ByteString
bs) = Text -> Value
JSON.String (ByteString -> Text
base64url (ByteString -> ByteString
LBS.toStrict ByteString
bs))

-- o  A UTF-8 string (major type 3) becomes a JSON string.  Note that
--    JSON requires escaping certain characters (RFC 4627, Section 2.5):
--    quotation mark (U+0022), reverse solidus (U+005C), and the "C0
--    control characters" (U+0000 through U+001F).  All other characters
--    are copied unchanged into the JSON UTF-8 string.

cborToJson (CBOR.TString  Text
s) = Text -> Value
JSON.String Text
s -- aeson will escape correctly
cborToJson (CBOR.TStringI Text
s) = Text -> Value
JSON.String (Text -> Text
Text.Lazy.toStrict Text
s)

-- o  An array (major type 4) becomes a JSON array.

cborToJson (TList  [Term]
vs) = Array -> Value
JSON.Array ([Value] -> Array
forall a. [a] -> Vector a
Vec.fromList ((Term -> Value) -> [Term] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Value
cborToJson [Term]
vs))

-- o  A map (major type 5) becomes a JSON object.  This is possible
--    directly only if all keys are UTF-8 strings.  A converter might
--    also convert other keys into UTF-8 strings (such as by converting
--    integers into strings containing their decimal representation);
--    however, doing so introduces a danger of key collision.

cborToJson (TMap  [(Term, Term)]
kvs) = [Pair] -> Value
JSON.object [ (Term -> Text
cborToJsonString Term
k, Term -> Value
cborToJson Term
v)
                                     | (Term
k, Term
v) <- [(Term, Term)]
kvs ]

-- o  False (major type 7, additional information 20) becomes a JSON false.

-- o  True (major type 7, additional information 21) becomes a JSON true.
--
-- o  Null (major type 7, additional information 22) becomes a JSON null.

cborToJson (TBool Bool
b) = Bool -> Value
JSON.Bool Bool
b
cborToJson  Term
TNull    = Value
JSON.Null

-- o  A floating-point value (major type 7, additional information 25
--    through 27) becomes a JSON number if it is finite (that is, it can
--    be represented in a JSON number); if the value is non-finite (NaN,
--    or positive or negative Infinity), it is represented by the
--    substitute value.

cborToJson (THalf Float
f)
  | Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
f Bool -> Bool -> Bool
|| Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
f = Value
JSON.Null
  | Bool
otherwise               = Scientific -> Value
JSON.Number (Float -> Scientific
forall a. RealFloat a => a -> Scientific
Scientific.fromFloatDigits Float
f)
cborToJson (TFloat Float
f)
  | Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
f Bool -> Bool -> Bool
|| Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
f = Value
JSON.Null
  | Bool
otherwise               = Scientific -> Value
JSON.Number (Float -> Scientific
forall a. RealFloat a => a -> Scientific
Scientific.fromFloatDigits Float
f)
cborToJson (TDouble Double
f)
  | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
f Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
f = Value
JSON.Null
  | Bool
otherwise               = Scientific -> Value
JSON.Number (Double -> Scientific
forall a. RealFloat a => a -> Scientific
Scientific.fromFloatDigits Double
f)

-- o  Any other simple value (major type 7, any additional information
--    value not yet discussed) is represented by the substitute value.

cborToJson (TSimple Word8
_) = Value
JSON.Null

-- o  A bignum (major type 6, tag value 2 or 3) is represented by
--    encoding its byte string in base64url without padding and becomes
--    a JSON string.  For tag value 3 (negative bignum), a "~" (ASCII
--    tilde) is inserted before the base-encoded value.  (The conversion
--    to a binary blob instead of a number is to prevent a likely
--    numeric overflow for the JSON decoder.)

-- NOTE We ignore this advice and just use 'JSON.Number'.

cborToJson (TInteger Integer
n) = Scientific -> Value
JSON.Number (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
n)

-- o  A byte string with an encoding hint (major type 6, tag value 21
--    through 23) is encoded as described and becomes a JSON string.

cborToJson (TTagged Word64
21 (CBOR.TBytes ByteString
bs)) = Text -> Value
JSON.String (ByteString -> Text
base64url ByteString
bs)
cborToJson (TTagged Word64
22 (CBOR.TBytes ByteString
bs)) = Text -> Value
JSON.String (ByteString -> Text
base64 ByteString
bs)
cborToJson (TTagged Word64
23 (CBOR.TBytes ByteString
bs)) = Text -> Value
JSON.String (ByteString -> Text
base16 ByteString
bs)

--   o  For all other tags (major type 6, any other tag value), the
--      embedded CBOR item is represented as a JSON value; the tag value
--      is ignored.

cborToJson (TTagged Word64
_tag Term
term) = Term -> Value
cborToJson Term
term

-- o  Indefinite-length items are made definite before conversion.

cborToJson (TListI [Term]
kvs) = Term -> Value
cborToJson ([Term] -> Term
TList [Term]
kvs)
cborToJson (TMapI  [(Term, Term)]
kvs) = Term -> Value
cborToJson ([(Term, Term)] -> Term
TMap [(Term, Term)]
kvs)


-- used just for converting CBOR terms to JSON map keys
-- TODO: partial
cborToJsonString :: CBOR.Term -> Text.Text
cborToJsonString :: Term -> Text
cborToJsonString (TInt     Int
n) = String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show Int
n)
cborToJsonString (TInteger Integer
n) = String -> Text
Text.pack (Integer -> String
forall a. Show a => a -> String
show Integer
n)
cborToJsonString (TString  Text
s) = Text
s
cborToJsonString (TStringI Text
s) = Text -> Text
Text.Lazy.toStrict Text
s

cborToJsonString (TBytes  ByteString
bs) = ByteString -> Text
base64url ByteString
bs
cborToJsonString (TBytesI ByteString
bs) = ByteString -> Text
base64url (ByteString -> ByteString
LBS.toStrict ByteString
bs)

-- TODO not strictly following the spec - this uses padding, spec says
-- we shouldn't
-- TODO moreover, api-tools uses base64 rather than base64url!
base64url :: ByteString -> Text
base64url :: ByteString -> Text
base64url = ByteString -> Text
base64 -- Text.decodeLatin1 . Base64url.encode

base64 :: ByteString -> Text
base64 :: ByteString -> Text
base64 = ByteString -> Text
Text.decodeLatin1 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode

base16 :: ByteString -> Text
base16 :: ByteString -> Text
base16 = ByteString -> Text
Text.decodeLatin1 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode


jsonToCbor :: JSON.Value -> CBOR.Term
jsonToCbor :: Value -> Term
jsonToCbor (JSON.Object Object
kvs) = [(Term, Term)] -> Term
CBOR.TMap [ (Text -> Term
CBOR.TString Text
k, Value -> Term
jsonToCbor Value
v)
                                         | (Text
k, Value
v) <- Object -> [Pair]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList Object
kvs ]
jsonToCbor (JSON.Array  Array
vs)  = [Term] -> Term
CBOR.TList [ Value -> Term
jsonToCbor Value
v | Value
v <- Array -> [Value]
forall a. Vector a -> [a]
Vec.toList Array
vs ]
jsonToCbor (JSON.String Text
str) = Text -> Term
CBOR.TString Text
str
jsonToCbor (JSON.Number Scientific
n)   = case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
n of
                                 Left  Double
d -> Double -> Term
CBOR.TDouble Double
d
                                 Right Integer
i
                                   | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
minBound :: Int) Bool -> Bool -> Bool
&&
                                     Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)
                                               -> Int -> Term
CBOR.TInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
                                   | Bool
otherwise -> Integer -> Term
CBOR.TInteger Integer
i
jsonToCbor (JSON.Bool   Bool
b)   = Bool -> Term
CBOR.TBool Bool
b
jsonToCbor  Value
JSON.Null        = Term
CBOR.TNull