{-# 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
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
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
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')
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"
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
(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
(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"
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 ->
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
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