{-# LANGUAGE DeriveDataTypeable #-}

-- | JSON serialisation
module Cardano.Api.Serialise.Json
  ( serialiseToJSON
  , ToJSON (..)
  , ToJSONKey
  , deserialiseFromJSON
  , prettyPrintJSON
  , FromJSON (..)
  , FromJSONKey
  , JsonDecodeError (..)
  , readFileJSON
  , writeFileJSON
  , textWithMaxLength
  , toRationalJSON
  )
where

import Cardano.Api.Error
import Cardano.Api.Pretty

import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither)
import Data.Aeson (FromJSON (..), FromJSONKey, ToJSON (..), ToJSONKey, Value)
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.Types qualified as Aeson
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Data (Data)
import Data.Scientific (fromRationalRepetendLimited)
import Data.Text (Text)
import Data.Text qualified as T

newtype JsonDecodeError = JsonDecodeError String
  deriving (JsonDecodeError -> JsonDecodeError -> Bool
(JsonDecodeError -> JsonDecodeError -> Bool)
-> (JsonDecodeError -> JsonDecodeError -> Bool)
-> Eq JsonDecodeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JsonDecodeError -> JsonDecodeError -> Bool
== :: JsonDecodeError -> JsonDecodeError -> Bool
$c/= :: JsonDecodeError -> JsonDecodeError -> Bool
/= :: JsonDecodeError -> JsonDecodeError -> Bool
Eq, Int -> JsonDecodeError -> ShowS
[JsonDecodeError] -> ShowS
JsonDecodeError -> [Char]
(Int -> JsonDecodeError -> ShowS)
-> (JsonDecodeError -> [Char])
-> ([JsonDecodeError] -> ShowS)
-> Show JsonDecodeError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonDecodeError -> ShowS
showsPrec :: Int -> JsonDecodeError -> ShowS
$cshow :: JsonDecodeError -> [Char]
show :: JsonDecodeError -> [Char]
$cshowList :: [JsonDecodeError] -> ShowS
showList :: [JsonDecodeError] -> ShowS
Show, Typeable JsonDecodeError
Typeable JsonDecodeError =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> JsonDecodeError -> c JsonDecodeError)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c JsonDecodeError)
-> (JsonDecodeError -> Constr)
-> (JsonDecodeError -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c JsonDecodeError))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c JsonDecodeError))
-> ((forall b. Data b => b -> b)
    -> JsonDecodeError -> JsonDecodeError)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> JsonDecodeError -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> JsonDecodeError -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> JsonDecodeError -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> JsonDecodeError -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> JsonDecodeError -> m JsonDecodeError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> JsonDecodeError -> m JsonDecodeError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> JsonDecodeError -> m JsonDecodeError)
-> Data JsonDecodeError
JsonDecodeError -> Constr
JsonDecodeError -> DataType
(forall b. Data b => b -> b) -> JsonDecodeError -> JsonDecodeError
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> JsonDecodeError -> u
forall u. (forall d. Data d => d -> u) -> JsonDecodeError -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> JsonDecodeError -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> JsonDecodeError -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> JsonDecodeError -> m JsonDecodeError
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> JsonDecodeError -> m JsonDecodeError
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c JsonDecodeError
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> JsonDecodeError -> c JsonDecodeError
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c JsonDecodeError)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c JsonDecodeError)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> JsonDecodeError -> c JsonDecodeError
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> JsonDecodeError -> c JsonDecodeError
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c JsonDecodeError
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c JsonDecodeError
$ctoConstr :: JsonDecodeError -> Constr
toConstr :: JsonDecodeError -> Constr
$cdataTypeOf :: JsonDecodeError -> DataType
dataTypeOf :: JsonDecodeError -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c JsonDecodeError)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c JsonDecodeError)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c JsonDecodeError)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c JsonDecodeError)
$cgmapT :: (forall b. Data b => b -> b) -> JsonDecodeError -> JsonDecodeError
gmapT :: (forall b. Data b => b -> b) -> JsonDecodeError -> JsonDecodeError
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> JsonDecodeError -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> JsonDecodeError -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> JsonDecodeError -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> JsonDecodeError -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> JsonDecodeError -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> JsonDecodeError -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> JsonDecodeError -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> JsonDecodeError -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> JsonDecodeError -> m JsonDecodeError
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> JsonDecodeError -> m JsonDecodeError
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> JsonDecodeError -> m JsonDecodeError
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> JsonDecodeError -> m JsonDecodeError
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> JsonDecodeError -> m JsonDecodeError
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> JsonDecodeError -> m JsonDecodeError
Data)

instance Error JsonDecodeError where
  prettyError :: forall ann. JsonDecodeError -> Doc ann
prettyError (JsonDecodeError [Char]
err) =
    [Char] -> Doc ann
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Char]
err

serialiseToJSON :: ToJSON a => a -> ByteString
serialiseToJSON :: forall a. ToJSON a => a -> ByteString
serialiseToJSON = LazyByteString -> ByteString
LBS.toStrict (LazyByteString -> ByteString)
-> (a -> LazyByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
Aeson.encode

prettyPrintJSON :: ToJSON a => a -> ByteString
prettyPrintJSON :: forall a. ToJSON a => a -> ByteString
prettyPrintJSON = LazyByteString -> ByteString
LBS.toStrict (LazyByteString -> ByteString)
-> (a -> LazyByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encodePretty

deserialiseFromJSON
  :: FromJSON a
  => ByteString
  -> Either JsonDecodeError a
deserialiseFromJSON :: forall a. FromJSON a => ByteString -> Either JsonDecodeError a
deserialiseFromJSON =
  ([Char] -> Either JsonDecodeError a)
-> (a -> Either JsonDecodeError a)
-> Either [Char] a
-> Either JsonDecodeError a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (JsonDecodeError -> Either JsonDecodeError a
forall a b. a -> Either a b
Left (JsonDecodeError -> Either JsonDecodeError a)
-> ([Char] -> JsonDecodeError)
-> [Char]
-> Either JsonDecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> JsonDecodeError
JsonDecodeError) a -> Either JsonDecodeError a
forall a b. b -> Either a b
Right
    (Either [Char] a -> Either JsonDecodeError a)
-> (ByteString -> Either [Char] a)
-> ByteString
-> Either JsonDecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] a
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecodeStrict'

readFileJSON
  :: FromJSON a
  => FilePath
  -> IO (Either (FileError JsonDecodeError) a)
readFileJSON :: forall a.
FromJSON a =>
[Char] -> IO (Either (FileError JsonDecodeError) a)
readFileJSON [Char]
path =
  ExceptT (FileError JsonDecodeError) IO a
-> IO (Either (FileError JsonDecodeError) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (FileError JsonDecodeError) IO a
 -> IO (Either (FileError JsonDecodeError) a))
-> ExceptT (FileError JsonDecodeError) IO a
-> IO (Either (FileError JsonDecodeError) a)
forall a b. (a -> b) -> a -> b
$ do
    ByteString
content <- [Char]
-> ([Char] -> IO ByteString)
-> ExceptT (FileError JsonDecodeError) IO ByteString
forall (m :: * -> *) s e.
MonadIO m =>
[Char] -> ([Char] -> IO s) -> ExceptT (FileError e) m s
fileIOExceptT [Char]
path [Char] -> IO ByteString
BS.readFile
    (JsonDecodeError -> FileError JsonDecodeError)
-> ExceptT JsonDecodeError IO a
-> ExceptT (FileError JsonDecodeError) IO a
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ([Char] -> JsonDecodeError -> FileError JsonDecodeError
forall e. [Char] -> e -> FileError e
FileError [Char]
path) (ExceptT JsonDecodeError IO a
 -> ExceptT (FileError JsonDecodeError) IO a)
-> ExceptT JsonDecodeError IO a
-> ExceptT (FileError JsonDecodeError) IO a
forall a b. (a -> b) -> a -> b
$
      Either JsonDecodeError a -> ExceptT JsonDecodeError IO a
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Either JsonDecodeError a -> ExceptT JsonDecodeError IO a)
-> Either JsonDecodeError a -> ExceptT JsonDecodeError IO a
forall a b. (a -> b) -> a -> b
$
        ByteString -> Either JsonDecodeError a
forall a. FromJSON a => ByteString -> Either JsonDecodeError a
deserialiseFromJSON ByteString
content

writeFileJSON
  :: ToJSON a
  => FilePath
  -> a
  -> IO (Either (FileError ()) ())
writeFileJSON :: forall a. ToJSON a => [Char] -> a -> IO (Either (FileError ()) ())
writeFileJSON [Char]
path a
x =
  ExceptT (FileError ()) IO () -> IO (Either (FileError ()) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (FileError ()) IO () -> IO (Either (FileError ()) ()))
-> ExceptT (FileError ()) IO () -> IO (Either (FileError ()) ())
forall a b. (a -> b) -> a -> b
$
    (IOException -> FileError ())
-> IO () -> ExceptT (FileError ()) IO ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT ([Char] -> IOException -> FileError ()
forall e. [Char] -> IOException -> FileError e
FileIOError [Char]
path) (IO () -> ExceptT (FileError ()) IO ())
-> IO () -> ExceptT (FileError ()) IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> ByteString -> IO ()
BS.writeFile [Char]
path (a -> ByteString
forall a. ToJSON a => a -> ByteString
serialiseToJSON a
x)

-- | Parser for 'Text' that validates that the number of characters is
-- under a given maximum. The 'String' parameter is meant to be the name
-- of the field in order to be able to give context in case of error.
textWithMaxLength :: String -> Int -> Value -> Aeson.Parser Text
textWithMaxLength :: [Char] -> Int -> Value -> Parser Text
textWithMaxLength [Char]
fieldName Int
maxLen Value
value = do
  Text
txt <- Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value
  if Text -> Int
T.length Text
txt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxLen
    then Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
txt
    else
      [Char] -> Parser Text
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser Text) -> [Char] -> Parser Text
forall a b. (a -> b) -> a -> b
$
        [Char]
"key \""
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
fieldName
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\" exceeds maximum length of "
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
maxLen
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" characters. Got length: "
          [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
T.length Text
txt)

-- Rationals and JSON are an awkward mix. We cannot convert rationals
-- like @1/3@ to JSON numbers. But _most_ of the numbers we want to use
-- in practice have simple decimal representations. Our solution here is
-- to use simple decimal representations where we can and representation
-- in a @{"numerator": 1, "denominator": 3}@ style otherwise.
--
toRationalJSON :: Rational -> Value
toRationalJSON :: Rational -> Value
toRationalJSON Rational
r =
  case Int
-> Rational
-> Either (Scientific, Rational) (Scientific, Maybe Int)
fromRationalRepetendLimited Int
20 Rational
r of
    Right (Scientific
s, Maybe Int
Nothing) -> Scientific -> Value
forall a. ToJSON a => a -> Value
toJSON Scientific
s
    Either (Scientific, Rational) (Scientific, Maybe Int)
_ -> Rational -> Value
forall a. ToJSON a => a -> Value
toJSON Rational
r