{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumDecimals           #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE UndecidableInstances  #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Instances used in the canonical JSON encoding of `GenesisData`

module Cardano.Prelude.Json.Canonical
  ( SchemaError(..)
  , canonicalDecodePretty
  , canonicalEncodePretty
  )
where

import Cardano.Prelude.Base

import qualified Data.ByteString.Lazy as LB
import Data.Fixed (E12, resolution)
import qualified Data.Text.Lazy.Builder as Builder (fromText)
import Data.Time (NominalDiffTime, UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Formatting (bprint, builder)
import Formatting.Buildable (Buildable(build))
import qualified Text.JSON.Canonical as CanonicalJSON
import Text.JSON.Canonical
  ( FromJSON(fromJSON)
  , Int54
  , JSValue(JSNum, JSString)
  , ReportSchemaErrors(expected)
  , ToJSON(toJSON)
  , expectedButGotValue
  , toJSString
  )

import Cardano.Prelude.Json.Parse (parseJSString)


data SchemaError = SchemaError
  { SchemaError -> Text
seExpected :: !Text
  , SchemaError -> Maybe Text
seActual   :: !(Maybe Text)
  } deriving (Int -> SchemaError -> ShowS
[SchemaError] -> ShowS
SchemaError -> String
(Int -> SchemaError -> ShowS)
-> (SchemaError -> String)
-> ([SchemaError] -> ShowS)
-> Show SchemaError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaError] -> ShowS
$cshowList :: [SchemaError] -> ShowS
show :: SchemaError -> String
$cshow :: SchemaError -> String
showsPrec :: Int -> SchemaError -> ShowS
$cshowsPrec :: Int -> SchemaError -> ShowS
Show, SchemaError -> SchemaError -> Bool
(SchemaError -> SchemaError -> Bool)
-> (SchemaError -> SchemaError -> Bool) -> Eq SchemaError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemaError -> SchemaError -> Bool
$c/= :: SchemaError -> SchemaError -> Bool
== :: SchemaError -> SchemaError -> Bool
$c== :: SchemaError -> SchemaError -> Bool
Eq)

instance Buildable SchemaError where
  build :: SchemaError -> Builder
build SchemaError
se = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Format Builder (Builder -> Builder) -> Builder -> Builder
forall a. Format Builder a -> a
bprint (Format (Builder -> Builder) (Builder -> Builder)
"expected " Format (Builder -> Builder) (Builder -> Builder)
-> Format Builder (Builder -> Builder)
-> Format Builder (Builder -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Builder -> Builder)
forall r. Format r (Builder -> r)
builder) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Builder
Builder.fromText (SchemaError -> Text
seExpected SchemaError
se)
    , case SchemaError -> Maybe Text
seActual SchemaError
se of
      Maybe Text
Nothing     -> Builder
forall a. Monoid a => a
mempty
      Just Text
actual -> Format Builder (Builder -> Builder) -> Builder -> Builder
forall a. Format Builder a -> a
bprint (Format (Builder -> Builder) (Builder -> Builder)
" but got " Format (Builder -> Builder) (Builder -> Builder)
-> Format Builder (Builder -> Builder)
-> Format Builder (Builder -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Builder -> Builder)
forall r. Format r (Builder -> r)
builder) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Builder
Builder.fromText Text
actual
    ]

instance
    (Applicative m, Monad m, MonadError SchemaError m)
    => ReportSchemaErrors m
  where
  expected :: String -> Maybe String -> m a
expected String
expec Maybe String
actual = SchemaError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SchemaError :: Text -> Maybe Text -> SchemaError
SchemaError
    { seExpected :: Text
seExpected = String -> Text
forall a b. ConvertText a b => a -> b
toS String
expec
    , seActual :: Maybe Text
seActual   = (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
forall a b. ConvertText a b => a -> b
toS Maybe String
actual
    }

instance Monad m => ToJSON m Int32 where
  toJSON :: Int32 -> m JSValue
toJSON = JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSValue -> m JSValue) -> (Int32 -> JSValue) -> Int32 -> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int54 -> JSValue
JSNum (Int54 -> JSValue) -> (Int32 -> Int54) -> Int32 -> JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int32 -> Int54
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Monad m => ToJSON m Word16 where
  toJSON :: Word16 -> m JSValue
toJSON = JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSValue -> m JSValue)
-> (Word16 -> JSValue) -> Word16 -> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int54 -> JSValue
JSNum (Int54 -> JSValue) -> (Word16 -> Int54) -> Word16 -> JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word16 -> Int54
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Monad m => ToJSON m Word32 where
  toJSON :: Word32 -> m JSValue
toJSON = JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSValue -> m JSValue)
-> (Word32 -> JSValue) -> Word32 -> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int54 -> JSValue
JSNum (Int54 -> JSValue) -> (Word32 -> Int54) -> Word32 -> JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word32 -> Int54
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Monad m => ToJSON m Word64 where
  toJSON :: Word64 -> m JSValue
toJSON = JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSValue -> m JSValue)
-> (Word64 -> JSValue) -> Word64 -> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. JSString -> JSValue
JSString (JSString -> JSValue) -> (Word64 -> JSString) -> Word64 -> JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> JSString
toJSString (String -> JSString) -> (Word64 -> String) -> Word64 -> JSString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show

instance Monad m => ToJSON m Integer where
  toJSON :: Integer -> m JSValue
toJSON = JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSValue -> m JSValue)
-> (Integer -> JSValue) -> Integer -> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. JSString -> JSValue
JSString (JSString -> JSValue)
-> (Integer -> JSString) -> Integer -> JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> JSString
toJSString (String -> JSString) -> (Integer -> String) -> Integer -> JSString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show

instance Monad m => ToJSON m Natural where
  toJSON :: Natural -> m JSValue
toJSON = JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSValue -> m JSValue)
-> (Natural -> JSValue) -> Natural -> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. JSString -> JSValue
JSString (JSString -> JSValue)
-> (Natural -> JSString) -> Natural -> JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> JSString
toJSString (String -> JSString) -> (Natural -> String) -> Natural -> JSString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Natural -> String
forall a b. (Show a, ConvertText String b) => a -> b
show

-- | For backwards compatibility we convert this to seconds
instance Monad m => ToJSON m UTCTime where
  toJSON :: UTCTime -> m JSValue
toJSON = JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSValue -> m JSValue)
-> (UTCTime -> JSValue) -> UTCTime -> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int54 -> JSValue
JSNum (Int54 -> JSValue) -> (UTCTime -> Int54) -> UTCTime -> JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. POSIXTime -> Int54
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int54) -> (UTCTime -> POSIXTime) -> UTCTime -> Int54
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds

-- | For backwards compatibility we convert this to microseconds
instance Monad m => ToJSON m NominalDiffTime where
  toJSON :: POSIXTime -> m JSValue
toJSON = Integer -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (Integer -> m JSValue)
-> (POSIXTime -> Integer) -> POSIXTime -> m JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1e6) (Integer -> Integer)
-> (POSIXTime -> Integer) -> POSIXTime -> Integer
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. POSIXTime -> Integer
toPicoseconds
   where
    toPicoseconds :: NominalDiffTime -> Integer
    toPicoseconds :: POSIXTime -> Integer
toPicoseconds POSIXTime
t =
      Ratio Integer -> Integer
forall a. Ratio a -> a
numerator (POSIXTime -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational POSIXTime
t Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
* Integer -> Ratio Integer
forall a. Real a => a -> Ratio Integer
toRational (Proxy E12 -> Integer
forall k (a :: k) (p :: k -> *). HasResolution a => p a -> Integer
resolution (Proxy E12 -> Integer) -> Proxy E12 -> Integer
forall a b. (a -> b) -> a -> b
$ Proxy E12
forall k (t :: k). Proxy t
Proxy @E12))

instance ReportSchemaErrors m => FromJSON m Int32 where
  fromJSON :: JSValue -> m Int32
fromJSON (JSNum Int54
i) = Int32 -> m Int32
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int32 -> m Int32) -> (Int54 -> Int32) -> Int54 -> m Int32
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int54 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int54 -> m Int32) -> Int54 -> m Int32
forall a b. (a -> b) -> a -> b
$ Int54
i
  fromJSON JSValue
val       = String -> JSValue -> m Int32
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> JSValue -> m a
expectedButGotValue String
"Int32" JSValue
val

instance ReportSchemaErrors m => FromJSON m Word16 where
  fromJSON :: JSValue -> m Word16
fromJSON (JSNum Int54
i) = Word16 -> m Word16
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word16 -> m Word16) -> (Int54 -> Word16) -> Int54 -> m Word16
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int54 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int54 -> m Word16) -> Int54 -> m Word16
forall a b. (a -> b) -> a -> b
$ Int54
i
  fromJSON JSValue
val       = String -> JSValue -> m Word16
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> JSValue -> m a
expectedButGotValue String
"Word16" JSValue
val

instance ReportSchemaErrors m => FromJSON m Word32 where
  fromJSON :: JSValue -> m Word32
fromJSON (JSNum Int54
i) = Word32 -> m Word32
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> m Word32) -> (Int54 -> Word32) -> Int54 -> m Word32
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int54 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int54 -> m Word32) -> Int54 -> m Word32
forall a b. (a -> b) -> a -> b
$ Int54
i
  fromJSON JSValue
val       = String -> JSValue -> m Word32
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> JSValue -> m a
expectedButGotValue String
"Word32" JSValue
val

instance ReportSchemaErrors m => FromJSON m Word64 where
  fromJSON :: JSValue -> m Word64
fromJSON = (Text -> Either String Word64) -> JSValue -> m Word64
forall a (m :: * -> *) e.
(Typeable a, ReportSchemaErrors m, Buildable e) =>
(Text -> Either e a) -> JSValue -> m a
parseJSString (String -> Either String Word64
forall a. Read a => String -> Either String a
readEither (String -> Either String Word64)
-> (Text -> String) -> Text -> Either String Word64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
forall a b. ConvertText a b => a -> b
toS)

instance ReportSchemaErrors m => FromJSON m Integer where
  fromJSON :: JSValue -> m Integer
fromJSON = (Text -> Either String Integer) -> JSValue -> m Integer
forall a (m :: * -> *) e.
(Typeable a, ReportSchemaErrors m, Buildable e) =>
(Text -> Either e a) -> JSValue -> m a
parseJSString (String -> Either String Integer
forall a. Read a => String -> Either String a
readEither (String -> Either String Integer)
-> (Text -> String) -> Text -> Either String Integer
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
forall a b. ConvertText a b => a -> b
toS)

instance MonadError SchemaError m => FromJSON m Natural where
  fromJSON :: JSValue -> m Natural
fromJSON = (Text -> Either String Natural) -> JSValue -> m Natural
forall a (m :: * -> *) e.
(Typeable a, ReportSchemaErrors m, Buildable e) =>
(Text -> Either e a) -> JSValue -> m a
parseJSString (String -> Either String Natural
forall a. Read a => String -> Either String a
readEither (String -> Either String Natural)
-> (Text -> String) -> Text -> Either String Natural
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
forall a b. ConvertText a b => a -> b
toS)

instance MonadError SchemaError m => FromJSON m UTCTime where
  fromJSON :: JSValue -> m UTCTime
fromJSON = (Int54 -> UTCTime) -> m Int54 -> m UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> (Int54 -> POSIXTime) -> Int54 -> UTCTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int54 -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (m Int54 -> m UTCTime)
-> (JSValue -> m Int54) -> JSValue -> m UTCTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. FromJSON m Int54 => JSValue -> m Int54
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON @_ @Int54

instance MonadError SchemaError m => FromJSON m NominalDiffTime where
  fromJSON :: JSValue -> m POSIXTime
fromJSON = (Integer -> POSIXTime) -> m Integer -> m POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ratio Integer -> POSIXTime
forall a. Fractional a => Ratio Integer -> a
fromRational (Ratio Integer -> POSIXTime)
-> (Integer -> Ratio Integer) -> Integer -> POSIXTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
1e6)) (m Integer -> m POSIXTime)
-> (JSValue -> m Integer) -> JSValue -> m POSIXTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. JSValue -> m Integer
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON

canonicalDecodePretty
  :: forall a
   . CanonicalJSON.FromJSON (Either SchemaError) a
  => LB.ByteString
  -> Either Text a
canonicalDecodePretty :: ByteString -> Either Text a
canonicalDecodePretty ByteString
y = do
  JSValue
eVal <- (String -> Text) -> Either String JSValue -> Either Text JSValue
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
forall a b. ConvertText a b => a -> b
toS (ByteString -> Either String JSValue
CanonicalJSON.parseCanonicalJSON ByteString
y)
  (SchemaError -> Text) -> Either SchemaError a -> Either Text a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SchemaError -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (JSValue -> Either SchemaError a
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
CanonicalJSON.fromJSON JSValue
eVal :: Either SchemaError a)

canonicalEncodePretty
  :: forall a . CanonicalJSON.ToJSON Identity a => a -> LB.ByteString
canonicalEncodePretty :: a -> ByteString
canonicalEncodePretty a
x =
  ByteString -> ByteString
LB.fromStrict
    (ByteString -> ByteString)
-> (String -> ByteString) -> String -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
encodeUtf8
    (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertText a b => a -> b
toS
    (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ JSValue -> String
CanonicalJSON.prettyCanonicalJSON
    (JSValue -> String) -> JSValue -> String
forall a b. (a -> b) -> a -> b
$ Identity JSValue -> JSValue
forall a. Identity a -> a
runIdentity
    (Identity JSValue -> JSValue) -> Identity JSValue -> JSValue
forall a b. (a -> b) -> a -> b
$ a -> Identity JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
CanonicalJSON.toJSON a
x