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

import           Data.API.Changes
import           Data.API.JSON
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.HashMap.Strict            as HMap
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).
serialiseJSONWithSchema :: API -> TypeName -> Value -> LBS.ByteString
serialiseJSONWithSchema :: API -> TypeName -> Value -> ByteString
serialiseJSONWithSchema API
api TypeName
tn Value
v = Term -> ByteString
forall a. Serialise a => a -> ByteString
serialise (Term -> ByteString) -> Term -> ByteString
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 (NormAPI -> TypeName -> Value -> Term)
-> (API -> NormAPI) -> API -> TypeName -> Value -> Term
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 TypeName -> NormAPI -> Maybe NormTypeDecl
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                -> [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ [Char]
"serialiseJSONWithSchema: missing definition for type "
                                          [Char] -> [Char] -> [Char]
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) | Array -> Bool
forall a. Vector a -> Bool
Vec.null Array
arr -> [Term] -> Term
TList []
                            | Bool
otherwise    -> [Term] -> Term
TListI ([Term] -> Term) -> [Term] -> Term
forall a b. (a -> b) -> a -> b
$ (Value -> Term) -> [Value] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (NormAPI -> APIType -> Value -> Term
jsonToCBORType NormAPI
napi APIType
ty) (Array -> [Value]
forall a. Vector a -> [a]
Vec.toList Array
arr)
    (TyList  APIType
_ , Value
_)         -> [Char] -> Term
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 ([(Term, Term)] -> Term) -> [(Term, Term)] -> Term
forall a b. (a -> b) -> a -> b
$ ((FieldName, APIType) -> (Term, Term))
-> [(FieldName, APIType)] -> [(Term, Term)]
forall a b. (a -> b) -> [a] -> [b]
map (Object -> (FieldName, APIType) -> (Term, Term)
f Object
hm) ([(FieldName, APIType)] -> [(Term, Term)])
-> [(FieldName, APIType)] -> [(Term, Term)]
forall a b. (a -> b) -> a -> b
$ NormRecordType -> [(FieldName, APIType)]
forall k a. Map k a -> [(k, a)]
Map.toAscList NormRecordType
nrt
    Value
_         -> [Char] -> Term
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 Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup (FieldName -> Text
_FieldName FieldName
fn) Object
hm of
                      Maybe Value
Nothing -> [Char] -> (Term, Term)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Term, Term)) -> [Char] -> (Term, Term)
forall a b. (a -> b) -> a -> b
$ [Char]
"serialiseJSONWithSchema: missing field " [Char] -> [Char] -> [Char]
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 | [(Text
k, Value
r)] <- Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Object
hm -> case FieldName -> NormRecordType -> Maybe APIType
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 -> [Char] -> Term
forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: unexpected alternative in union"
    Value
_ -> [Char] -> Term
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
_        -> [Char] -> Term
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
_)        -> [Char] -> Term
forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected string"
    (BasicType
BTbinary, String Text
t) -> case ByteString -> Either [Char] ByteString
B64.decode (ByteString -> Either [Char] ByteString)
-> ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
t of
                              Left  [Char]
err-> [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> [Char] -> Term
forall a b. (a -> b) -> a -> b
$ [Char]
"serialiseJSONWithSchema: base64-decoding failed: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err
                              Right ByteString
bs -> ByteString -> Term
TBytes ByteString
bs
    (BasicType
BTbinary, Value
_)        -> [Char] -> Term
forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected string"
    (BasicType
BTbool  , Bool Bool
b)   -> Bool -> Term
TBool Bool
b
    (BasicType
BTbool  , Value
_)        -> [Char] -> Term
forall a. HasCallStack => [Char] -> a
error [Char]
"serialiseJSONWithSchema: expected bool"
    (BasicType
BTint   , Number Scientific
n) | Right Int
i <- (Scientific -> Either Double Int
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
_)        -> [Char] -> Term
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 POSIXTime -> (Int, POSIXTime)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (POSIXTime -> (Int, POSIXTime)) -> POSIXTime -> (Int, POSIXTime)
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
utc of
                           -- fractional part must be positive
                           (Int
secs', POSIXTime
frac')
                             | POSIXTime
frac' POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
< POSIXTime
0  -> (Int
secs' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, POSIXTime
frac' POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
1)
                             | Bool
otherwise -> (Int
secs', POSIXTime
frac')
          psecs :: Int
psecs = POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> POSIXTime -> Int
forall a b. (a -> b) -> a -> b
$ POSIXTime
frac POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000000000000
          utc :: UTCTime
utc = HasCallStack => Text -> UTCTime
Text -> UTCTime
unsafeParseUTC Text
t
    (BasicType
BTutc   , Value
_)        -> [Char] -> Term
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 (ByteString -> Term
forall a. Serialise a => ByteString -> a
deserialise ByteString
bs)) of
    Right Value
v  -> Value
v
    Left ValueError
err -> [Char] -> Value
forall a. HasCallStack => [Char] -> a
error ([Char] -> Value) -> [Char] -> Value
forall a b. (a -> b) -> a -> b
$ [Char]
"deserialiseJSONWithSchema could not post-process: " [Char] -> [Char] -> [Char]
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 <- TypeName -> NormAPI -> Maybe NormTypeDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tn NormAPI
napi Maybe NormTypeDecl -> ValueError -> Either ValueError NormTypeDecl
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
_  -> Value -> Either ValueError Value
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 (Array -> Value)
-> Either ValueError Array -> Either ValueError Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Either ValueError Value)
-> Array -> Either ValueError Array
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
_         -> ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedArray Value
v
    TyMaybe APIType
ty -> case Value
v of
                    Array Array
arr -> case Array -> [Value]
forall a. Vector a -> [a]
Vec.toList Array
arr of
                                   []    -> Value -> Either ValueError Value
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]
_ -> ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ [Char] -> JSONError
SyntaxError [Char]
"over-long array when converting Maybe value"
                    Value
_         -> ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
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 -> case Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Object
obj of
        [(Text
k1, Number Scientific
v0), (Text
km12, Number Scientific
v1)]
          | Text -> [Char]
T.unpack Text
k1 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"1" Bool -> Bool -> Bool
&& Text -> [Char]
T.unpack Text
km12 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"-12" ->
          -- Taken from @Codec.Serialise.Class@:
          let psecs :: Pico
              psecs :: Pico
psecs = Scientific -> Pico
forall a b. (Real a, Fractional b) => a -> b
realToFrac Scientific
v1 Pico -> Pico -> Pico
forall a. Fractional a => a -> a -> a
/ Pico
1000000000000

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

          in Value -> Either ValueError Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either ValueError Value)
-> Value -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$! Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$! UTCTime -> Text
printUTC (UTCTime -> Text) -> UTCTime -> Text
forall a b. (a -> b) -> a -> b
$! UTCTime -> UTCTime
forceUTCTime (POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
dt)
        [(Text, Value)]
_ -> ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError JSONError
UnexpectedField
      String Text
t -> case Text -> Maybe UTCTime
parseUTC Text
t of
        Maybe UTCTime
Nothing -> ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ [Char] -> JSONError
SyntaxError ([Char] -> JSONError) -> [Char] -> JSONError
forall a b. (a -> b) -> a -> b
$
                     [Char]
"UTC time in wrong format: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
        Just UTCTime
utcTime -> Value -> Either ValueError Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either ValueError Value)
-> Value -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$! Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$! UTCTime -> Text
printUTC (UTCTime -> Text) -> UTCTime -> Text
forall a b. (a -> b) -> a -> b
$! UTCTime -> UTCTime
forceUTCTime UTCTime
utcTime
      Value
_ -> ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject Value
v
    TyBasic BasicType
_  -> Value -> Either ValueError Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
    APIType
TyJSON     -> Value -> Either ValueError Value
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 (Object -> Value)
-> Either ValueError Object -> Either ValueError Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Value -> Either ValueError Value)
-> Object -> Either ValueError Object
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HMap.traverseWithKey Text -> Value -> Either ValueError Value
f Object
hm
    Value
_         -> ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
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 <- FieldName -> NormRecordType -> Maybe APIType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> FieldName
FieldName Text
t) NormRecordType
nrt Maybe APIType -> ValueError -> Either ValueError APIType
forall a e. Maybe a -> e -> Either e a
?! JSONError -> ValueError
JSONError JSONError
UnexpectedField
                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 | [(Text
k, Value
r)] <- Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Object
hm
              , Just APIType
ty <- FieldName -> NormRecordType -> Maybe APIType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> FieldName
FieldName Text
k) NormRecordType
nut
              -> Object -> Value
Object (Object -> Value) -> (Value -> Object) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HMap.singleton Text
k (Value -> Value)
-> Either ValueError Value -> Either ValueError Value
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
_ -> ValueError -> Either ValueError Value
forall a b. a -> Either a b
Left (ValueError -> Either ValueError Value)
-> ValueError -> Either ValueError Value
forall a b. (a -> b) -> a -> b
$ JSONError -> ValueError
JSONError (JSONError -> ValueError) -> JSONError -> ValueError
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedObject Value
v