{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.API.JSONToCBOR
    ( serialiseJSONWithSchema
    , jsonToCBORWithSchema
    , deserialiseJSONWithSchema
    , postprocessJSON
    ) where

import           Data.API.Changes
import           Data.API.JSON
import           Data.API.JSON.Compat
import           Data.API.Time
import           Data.API.Types
import           Data.API.Utils

import           Control.Applicative
import           Data.Aeson hiding (encode)
import qualified Data.ByteString.Base64         as B64
import qualified Data.ByteString.Lazy           as LBS
import qualified Data.Map                       as Map
import           Data.Traversable
import qualified Data.Vector                    as Vec
import           Codec.Serialise     as CBOR
import           Data.Binary.Serialise.CBOR.JSON (cborToJson, jsonToCbor)
import           Codec.CBOR.Term
import           Data.Fixed (Pico)
import           Data.Scientific
import qualified Data.Text                      as T
import qualified Data.Text.Encoding             as TE
import           Data.Time.Clock.POSIX
import           Data.Time (UTCTime(UTCTime))
import           Prelude


-- | Serialise a JSON value as a CBOR term in a generic but
-- schema-dependent fashion.  This is necessary because the JSON
-- representation carries less information than we need in CBOR
-- (e.g. it lacks a distinction between bytestrings and text).
--
-- There is a corner case where this may lose information: if the schema
-- contains a field with type @? json@ (i.e. @'Maybe' 'Value'@), then we have
--
-- > toJSON Nothing     == Null
-- > toJSON (Just Null) == Null
--
-- so 'serialiseJSONWithSchema' cannot distinguish these values, and will use
-- the CBOR-encoding of 'Nothing' for both.
--
serialiseJSONWithSchema :: API -> TypeName -> Value -> LBS.ByteString
serialiseJSONWithSchema :: API -> TypeName -> Value -> ByteString
serialiseJSONWithSchema API
api TypeName
tn Value
v = forall a. Serialise a => a -> ByteString
serialise forall a b. (a -> b) -> a -> b
$ API -> TypeName -> Value -> Term
jsonToCBORWithSchema API
api TypeName
tn Value
v

-- | Convert a JSON value into a CBOR term in a generic but
-- schema-dependent fashion.
jsonToCBORWithSchema :: API -> TypeName -> Value -> Term
jsonToCBORWithSchema :: API -> TypeName -> Value -> Term
jsonToCBORWithSchema = NormAPI -> TypeName -> Value -> Term
jsonToCBORTypeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. API -> NormAPI
apiNormalForm

jsonToCBORTypeName :: NormAPI -> TypeName -> Value -> Term
jsonToCBORTypeName :: NormAPI -> TypeName -> Value -> Term
jsonToCBORTypeName NormAPI
napi TypeName
tn Value
v =
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tn NormAPI
napi of
      Just (NRecordType NormRecordType
nrt) -> NormAPI -> NormRecordType -> Value -> Term
jsonToCBORRecord NormAPI
napi NormRecordType
nrt Value
v
      Just (NUnionType  NormRecordType
nut) -> NormAPI -> NormRecordType -> Value -> Term
jsonToCBORUnion  NormAPI
napi NormRecordType
nut Value
v
      Just (NEnumType   NormEnumType
net) -> NormAPI -> NormEnumType -> Value -> Term
jsonToCBOREnum   NormAPI
napi NormEnumType
net Value
v
      Just (NTypeSynonym APIType
ty) -> NormAPI -> APIType -> Value -> Term
jsonToCBORType   NormAPI
napi APIType
ty  Value
v
      Just (NNewtype     BasicType
bt) -> BasicType -> Value -> Term
jsonToCBORBasic       BasicType
bt  Value
v
      Maybe NormTypeDecl
Nothing                -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"serialiseJSONWithSchema: missing definition for type "
                                          forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (TypeName -> Text
_TypeName TypeName
tn)

jsonToCBORType :: NormAPI -> APIType -> Value -> Term
jsonToCBORType :: NormAPI -> APIType -> Value -> Term
jsonToCBORType NormAPI
napi APIType
ty0 Value
v = case (APIType
ty0, Value
v) of
    (TyList  APIType
ty, Array Array
arr) | forall a. Vector a -> Bool
Vec.null Array
arr -> [Term] -> Term
TList []
                            | Bool
otherwise    -> [Term] -> Term
TListI forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (NormAPI -> APIType -> Value -> Term
jsonToCBORType NormAPI
napi APIType
ty) (forall a. Vector a -> [a]
Vec.toList Array
arr)
    (TyList  APIType
_ , Value
_)         -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected array"
    (TyMaybe APIType
_ , Value
Null)      -> [Term] -> Term
TList []
    (TyMaybe APIType
ty, Value
_)         -> [Term] -> Term
TList [NormAPI -> APIType -> Value -> Term
jsonToCBORType NormAPI
napi APIType
ty Value
v]
    (TyName  TypeName
tn, Value
_)         -> NormAPI -> TypeName -> Value -> Term
jsonToCBORTypeName NormAPI
napi TypeName
tn Value
v
    (TyBasic BasicType
bt, Value
_)         -> BasicType -> Value -> Term
jsonToCBORBasic BasicType
bt Value
v
    (APIType
TyJSON    , Value
_)         -> Value -> Term
jsonToCbor Value
v

-- | Encode a record as a map from field names to values.  Crucially,
-- the fields are in ascending order by field name.
jsonToCBORRecord :: NormAPI -> NormRecordType -> Value -> Term
jsonToCBORRecord :: NormAPI -> NormRecordType -> Value -> Term
jsonToCBORRecord NormAPI
napi NormRecordType
nrt Value
v = case Value
v of
    Object Object
hm -> [(Term, Term)] -> Term
TMap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Object -> (FieldName, APIType) -> (Term, Term)
f Object
hm) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList NormRecordType
nrt
    Value
_         -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected object"
  where
    f :: Object -> (FieldName, APIType) -> (Term, Term)
f Object
hm (FieldName
fn, APIType
ty) = case forall a. Text -> KeyMap a -> Maybe a
lookupKey (FieldName -> Text
_FieldName FieldName
fn) Object
hm of
                      Maybe Value
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"serialiseJSONWithSchema: missing field " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (FieldName -> Text
_FieldName FieldName
fn)
                      Just Value
v' -> (Text -> Term
TString (FieldName -> Text
_FieldName FieldName
fn), NormAPI -> APIType -> Value -> Term
jsonToCBORType NormAPI
napi APIType
ty Value
v')

-- | Encode a union as a single-element map from the field name to the value.
jsonToCBORUnion :: NormAPI -> NormUnionType -> Value -> Term
jsonToCBORUnion :: NormAPI -> NormRecordType -> Value -> Term
jsonToCBORUnion NormAPI
napi NormRecordType
nut Value
v = case Value
v of
    Object Object
hm | Just (Text
k, Value
r) <- forall a. KeyMap a -> Maybe (Text, a)
matchSingletonObject Object
hm -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> FieldName
FieldName Text
k) NormRecordType
nut of
       Just APIType
ty -> [(Term, Term)] -> Term
TMap [(Text -> Term
TString Text
k, NormAPI -> APIType -> Value -> Term
jsonToCBORType NormAPI
napi APIType
ty Value
r)]
       Maybe APIType
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: unexpected alternative in union"
    Value
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected single-field object"

-- | Encode an enumerated value as its name; we do not check that it
-- actually belongs to the type here.
jsonToCBOREnum :: NormAPI -> NormEnumType -> Value -> Term
jsonToCBOREnum :: NormAPI -> NormEnumType -> Value -> Term
jsonToCBOREnum NormAPI
_ NormEnumType
_ Value
v = case Value
v of
                         String Text
t -> Text -> Term
TString Text
t
                         Value
_        -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected string"

jsonToCBORBasic :: BasicType -> Value -> Term
jsonToCBORBasic :: BasicType -> Value -> Term
jsonToCBORBasic BasicType
bt Value
v = case (BasicType
bt, Value
v) of
    (BasicType
BTstring, String Text
t) -> Text -> Term
TString Text
t
    (BasicType
BTstring, Value
_)        -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected string"
    (BasicType
BTbinary, String Text
t) -> case ByteString -> Either [Char] ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t of
                              Left  [Char]
err-> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"serialiseJSONWithSchema: base64-decoding failed: " forall a. [a] -> [a] -> [a]
++ [Char]
err
                              Right ByteString
bs -> ByteString -> Term
TBytes ByteString
bs
    (BasicType
BTbinary, Value
_)        -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected string"
    (BasicType
BTbool  , Bool Bool
b)   -> Bool -> Term
TBool Bool
b
    (BasicType
BTbool  , Value
_)        -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected bool"
    (BasicType
BTint   , Number Scientific
n) | Right Int
i <- (forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
n :: Either Double Int) -> Int -> Term
TInt Int
i
    (BasicType
BTint   , Value
_)        -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected integer"
    (BasicType
BTutc   , String Text
t) ->
      Word64 -> Term -> Term
TTagged Word64
1000 ([(Term, Term)] -> Term
TMap [ (Int -> Term
TInt Int
1, Int -> Term
TInt Int
secs)
                         , (Int -> Term
TInt (-Int
12), Int -> Term
TInt Int
psecs) ])
        where  -- taken from @Codec.Serialise.Class@:
          (Int
secs, POSIXTime
frac) = case forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
utc of
                           -- fractional part must be positive
                           (Int
secs', POSIXTime
frac')
                             | POSIXTime
frac' forall a. Ord a => a -> a -> Bool
< POSIXTime
0  -> (Int
secs' forall a. Num a => a -> a -> a
- Int
1, POSIXTime
frac' forall a. Num a => a -> a -> a
+ POSIXTime
1)
                             | Bool
otherwise -> (Int
secs', POSIXTime
frac')
          psecs :: Int
psecs = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ POSIXTime
frac forall a. Num a => a -> a -> a
* POSIXTime
1000000000000
          utc :: UTCTime
utc = HasCallStack => Text -> UTCTime
unsafeParseUTC Text
t
    (BasicType
BTutc   , Value
_)        -> forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected string"


-- | When a JSON value has been deserialised from CBOR, the
-- representation may need some modifications in order to match the
-- result of 'toJSON' on a Haskell datatype.  In particular, Aeson's
-- representation of 'Maybe' does not round-trip (because 'Nothing' is
-- encoded as 'Null' and @'Just' x@ as @'toJSON' x@), so CBOR uses a
-- different representation (as an empty or 1-element list).
deserialiseJSONWithSchema :: API -> TypeName -> LBS.ByteString -> Value
deserialiseJSONWithSchema :: API -> TypeName -> ByteString -> Value
deserialiseJSONWithSchema API
api TypeName
tn ByteString
bs = case API -> TypeName -> Value -> Either ValueError Value
postprocessJSON API
api TypeName
tn (Term -> Value
cborToJson (forall a. Serialise a => ByteString -> a
deserialise ByteString
bs)) of
    Right Value
v  -> Value
v
    Left ValueError
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"deserialiseJSONWithSchema could not post-process: " forall a. [a] -> [a] -> [a]
++ ValueError -> [Char]
prettyValueError ValueError
err

postprocessJSON :: API -> TypeName -> Value -> Either ValueError Value
postprocessJSON :: API -> TypeName -> Value -> Either ValueError Value
postprocessJSON API
api = NormAPI -> TypeName -> Value -> Either ValueError Value
postprocessJSONTypeName (API -> NormAPI
apiNormalForm API
api)

postprocessJSONTypeName :: NormAPI -> TypeName -> Value -> Either ValueError Value
postprocessJSONTypeName :: NormAPI -> TypeName -> Value -> Either ValueError Value
postprocessJSONTypeName NormAPI
napi TypeName
tn Value
v = do
    NormTypeDecl
t <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tn NormAPI
napi forall a e. Maybe a -> e -> Either e a
?! ApplyFailure -> ValueError
InvalidAPI (TypeName -> ApplyFailure
TypeDoesNotExist TypeName
tn)
    case NormTypeDecl
t of
      NRecordType NormRecordType
nrt -> NormAPI -> NormRecordType -> Value -> Either ValueError Value
postprocessJSONRecord NormAPI
napi NormRecordType
nrt Value
v
      NUnionType  NormRecordType
nut -> NormAPI -> NormRecordType -> Value -> Either ValueError Value
postprocessJSONUnion  NormAPI
napi NormRecordType
nut Value
v
      NEnumType    NormEnumType
_  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
      NTypeSynonym APIType
ty -> NormAPI -> APIType -> Value -> Either ValueError Value
postprocessJSONType   NormAPI
napi APIType
ty  Value
v
      NNewtype     BasicType
bt -> NormAPI -> APIType -> Value -> Either ValueError Value
postprocessJSONType   NormAPI
napi (BasicType -> APIType
TyBasic BasicType
bt) Value
v

postprocessJSONType :: NormAPI -> APIType -> Value -> Either ValueError Value
postprocessJSONType :: NormAPI -> APIType -> Value -> Either ValueError Value
postprocessJSONType NormAPI
napi APIType
ty0 Value
v = case APIType
ty0 of
    TyList APIType
ty  -> case Value
v of
                   Array Array
arr -> Array -> Value
Array forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (NormAPI -> APIType -> Value -> Either ValueError Value
postprocessJSONType NormAPI
napi APIType
ty) Array
arr
                   Value
_         -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedArray Value
v
    TyMaybe APIType
ty -> case Value
v of
                    Array Array
arr -> case forall a. Vector a -> [a]
Vec.toList Array
arr of
                                   []    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
                                   [Value
v1]  -> NormAPI -> APIType -> Value -> Either ValueError Value
postprocessJSONType NormAPI
napi APIType
ty Value
v1
                                   Value
_:Value
_:[Value]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ [Char] -> JSONError
SyntaxError [Char]
"over-long array when converting Maybe value"
                    Value
_         -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedArray Value
v
    TyName TypeName
tn  -> NormAPI -> TypeName -> Value -> Either ValueError Value
postprocessJSONTypeName NormAPI
napi TypeName
tn Value
v
    TyBasic BasicType
BTutc -> case Value
v of
      Object Object
obj
        | Just (Number Scientific
v0) <- forall a. Text -> KeyMap a -> Maybe a
lookupKey Text
"1" Object
obj
        , Just (Number Scientific
v1) <- forall a. Text -> KeyMap a -> Maybe a
lookupKey Text
"-12" Object
obj ->
          -- Taken from @Codec.Serialise.Class@:
          let psecs :: Pico
              psecs :: Pico
psecs = forall a b. (Real a, Fractional b) => a -> b
realToFrac Scientific
v1 forall a. Fractional a => a -> a -> a
/ Pico
1000000000000

              dt :: POSIXTime
              dt :: POSIXTime
dt = forall a b. (Real a, Fractional b) => a -> b
realToFrac Scientific
v0 forall a. Num a => a -> a -> a
+ forall a b. (Real a, Fractional b) => a -> b
realToFrac Pico
psecs

          in forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Text -> Value
String forall a b. (a -> b) -> a -> b
$! UTCTime -> Text
printUTC forall a b. (a -> b) -> a -> b
$! UTCTime -> UTCTime
forceUTCTime (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
dt)
        | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (Expected -> [Char] -> Value -> JSONError
Expected Expected
ExpObject [Char]
"UTCTime" Value
v)
      String Text
t -> case Text -> Maybe UTCTime
parseUTC Text
t of
        Maybe UTCTime
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ [Char] -> JSONError
SyntaxError forall a b. (a -> b) -> a -> b
$
                     [Char]
"UTC time in wrong format: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
        Just UTCTime
utcTime -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Text -> Value
String forall a b. (a -> b) -> a -> b
$! UTCTime -> Text
printUTC forall a b. (a -> b) -> a -> b
$! UTCTime -> UTCTime
forceUTCTime UTCTime
utcTime
      Value
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject Value
v
    TyBasic BasicType
_  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
    APIType
TyJSON     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v

-- | Force the unnecessarily lazy @'UTCTime'@ representation.
forceUTCTime :: UTCTime -> UTCTime
forceUTCTime :: UTCTime -> UTCTime
forceUTCTime t :: UTCTime
t@(UTCTime !Day
_day !DiffTime
_daytime) = UTCTime
t

postprocessJSONRecord :: NormAPI -> NormRecordType -> Value -> Either ValueError Value
postprocessJSONRecord :: NormAPI -> NormRecordType -> Value -> Either ValueError Value
postprocessJSONRecord NormAPI
napi NormRecordType
nrt Value
v = case Value
v of
    Object Object
hm -> Object -> Value
Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) v1 v2.
Applicative f =>
(Text -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2)
traverseObjectWithKey Text -> Value -> Either ValueError Value
f Object
hm
    Value
_         -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject Value
v
  where
    f :: Text -> Value -> Either ValueError Value
f Text
t Value
v' = do APIType
ty <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> FieldName
FieldName Text
t) NormRecordType
nrt forall a e. Maybe a -> e -> Either e a
?! JSONError -> ValueError
JSONError JSONError
MissingField
                NormAPI -> APIType -> Value -> Either ValueError Value
postprocessJSONType NormAPI
napi APIType
ty Value
v'

postprocessJSONUnion :: NormAPI -> NormUnionType -> Value -> Either ValueError Value
postprocessJSONUnion :: NormAPI -> NormRecordType -> Value -> Either ValueError Value
postprocessJSONUnion NormAPI
napi NormRecordType
nut Value
v = case Value
v of
    Object Object
hm | Just (Text
k, Value
r) <- forall a. KeyMap a -> Maybe (Text, a)
matchSingletonObject Object
hm
              , Just APIType
ty <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> FieldName
FieldName Text
k) NormRecordType
nut
              -> Object -> Value
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> a -> KeyMap a
singletonObject Text
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormAPI -> APIType -> Value -> Either ValueError Value
postprocessJSONType NormAPI
napi APIType
ty Value
r
    Value
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject Value
v