{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Cardano.Api.TextView
  ( -- * \"TextView\" format
    TextView (..)
  , TextViewError (..)
  , TextViewType (..)
  , TextViewDescription (..)
  , renderTextViewError
  , expectTextViewOfType
  , textViewJSONConfig
  , textViewJSONKeyOrder
  , textShow

    -- * File IO support
  , TextViewFileError (..)
  , renderTextViewFileError
  ) where

import           Cardano.Prelude
import           Prelude (String)

import           Cardano.Binary
import           Control.Monad (fail)
import           Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:), (.=))
import           Data.Aeson.Encode.Pretty (Config (..), defConfig, keyOrder)
import           Data.Aeson.Types (Parser)

import qualified Data.ByteString.Base16 as Base16
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text

newtype TextViewType
  = TextViewType { TextViewType -> ByteString
unTextViewType :: ByteString }
  deriving (TextViewType -> TextViewType -> Bool
(TextViewType -> TextViewType -> Bool)
-> (TextViewType -> TextViewType -> Bool) -> Eq TextViewType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextViewType -> TextViewType -> Bool
$c/= :: TextViewType -> TextViewType -> Bool
== :: TextViewType -> TextViewType -> Bool
$c== :: TextViewType -> TextViewType -> Bool
Eq, String -> TextViewType
(String -> TextViewType) -> IsString TextViewType
forall a. (String -> a) -> IsString a
fromString :: String -> TextViewType
$cfromString :: String -> TextViewType
IsString, Int -> TextViewType -> ShowS
[TextViewType] -> ShowS
TextViewType -> String
(Int -> TextViewType -> ShowS)
-> (TextViewType -> String)
-> ([TextViewType] -> ShowS)
-> Show TextViewType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextViewType] -> ShowS
$cshowList :: [TextViewType] -> ShowS
show :: TextViewType -> String
$cshow :: TextViewType -> String
showsPrec :: Int -> TextViewType -> ShowS
$cshowsPrec :: Int -> TextViewType -> ShowS
Show, b -> TextViewType -> TextViewType
NonEmpty TextViewType -> TextViewType
TextViewType -> TextViewType -> TextViewType
(TextViewType -> TextViewType -> TextViewType)
-> (NonEmpty TextViewType -> TextViewType)
-> (forall b. Integral b => b -> TextViewType -> TextViewType)
-> Semigroup TextViewType
forall b. Integral b => b -> TextViewType -> TextViewType
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> TextViewType -> TextViewType
$cstimes :: forall b. Integral b => b -> TextViewType -> TextViewType
sconcat :: NonEmpty TextViewType -> TextViewType
$csconcat :: NonEmpty TextViewType -> TextViewType
<> :: TextViewType -> TextViewType -> TextViewType
$c<> :: TextViewType -> TextViewType -> TextViewType
Semigroup)

newtype TextViewDescription
  = TextViewDescription { TextViewDescription -> ByteString
unTextViewDescription :: ByteString }
  deriving (TextViewDescription -> TextViewDescription -> Bool
(TextViewDescription -> TextViewDescription -> Bool)
-> (TextViewDescription -> TextViewDescription -> Bool)
-> Eq TextViewDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextViewDescription -> TextViewDescription -> Bool
$c/= :: TextViewDescription -> TextViewDescription -> Bool
== :: TextViewDescription -> TextViewDescription -> Bool
$c== :: TextViewDescription -> TextViewDescription -> Bool
Eq, String -> TextViewDescription
(String -> TextViewDescription) -> IsString TextViewDescription
forall a. (String -> a) -> IsString a
fromString :: String -> TextViewDescription
$cfromString :: String -> TextViewDescription
IsString, Int -> TextViewDescription -> ShowS
[TextViewDescription] -> ShowS
TextViewDescription -> String
(Int -> TextViewDescription -> ShowS)
-> (TextViewDescription -> String)
-> ([TextViewDescription] -> ShowS)
-> Show TextViewDescription
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextViewDescription] -> ShowS
$cshowList :: [TextViewDescription] -> ShowS
show :: TextViewDescription -> String
$cshow :: TextViewDescription -> String
showsPrec :: Int -> TextViewDescription -> ShowS
$cshowsPrec :: Int -> TextViewDescription -> ShowS
Show, b -> TextViewDescription -> TextViewDescription
NonEmpty TextViewDescription -> TextViewDescription
TextViewDescription -> TextViewDescription -> TextViewDescription
(TextViewDescription -> TextViewDescription -> TextViewDescription)
-> (NonEmpty TextViewDescription -> TextViewDescription)
-> (forall b.
    Integral b =>
    b -> TextViewDescription -> TextViewDescription)
-> Semigroup TextViewDescription
forall b.
Integral b =>
b -> TextViewDescription -> TextViewDescription
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> TextViewDescription -> TextViewDescription
$cstimes :: forall b.
Integral b =>
b -> TextViewDescription -> TextViewDescription
sconcat :: NonEmpty TextViewDescription -> TextViewDescription
$csconcat :: NonEmpty TextViewDescription -> TextViewDescription
<> :: TextViewDescription -> TextViewDescription -> TextViewDescription
$c<> :: TextViewDescription -> TextViewDescription -> TextViewDescription
Semigroup)

-- | A 'TextView' is a structured envelope for serialised binary values
-- with an external format with a semi-readable textual format.
--
-- It contains a \"type\" field, e.g. \"PublicKeyByron\" or \"TxSignedShelley\"
-- to indicate the type of the encoded data. This is used as a sanity check
-- and to help readers.
--
-- It also contains a \"title\" field which is free-form, and could be used
-- to indicate the role or purpose to a reader.
--
data TextView = TextView
  { TextView -> TextViewType
tvType :: !TextViewType
  , TextView -> TextViewDescription
tvDescription :: !TextViewDescription
  , TextView -> ByteString
tvRawCBOR :: !ByteString
  } deriving (TextView -> TextView -> Bool
(TextView -> TextView -> Bool)
-> (TextView -> TextView -> Bool) -> Eq TextView
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextView -> TextView -> Bool
$c/= :: TextView -> TextView -> Bool
== :: TextView -> TextView -> Bool
$c== :: TextView -> TextView -> Bool
Eq, Int -> TextView -> ShowS
[TextView] -> ShowS
TextView -> String
(Int -> TextView -> ShowS)
-> (TextView -> String) -> ([TextView] -> ShowS) -> Show TextView
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextView] -> ShowS
$cshowList :: [TextView] -> ShowS
show :: TextView -> String
$cshow :: TextView -> String
showsPrec :: Int -> TextView -> ShowS
$cshowsPrec :: Int -> TextView -> ShowS
Show)

instance ToJSON TextView where
  toJSON :: TextView -> Value
toJSON (TextView (TextViewType ByteString
tvType') (TextViewDescription ByteString
desc) ByteString
rawCBOR) =
    [Pair] -> Value
object [ Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 ByteString
tvType'
           , Text
"description" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 ByteString
desc
           , Text
"cborHex" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 (ByteString -> ByteString
Base16.encode ByteString
rawCBOR)
           ]

instance FromJSON TextView where
  parseJSON :: Value -> Parser TextView
parseJSON = String -> (Object -> Parser TextView) -> Value -> Parser TextView
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"TextView" ((Object -> Parser TextView) -> Value -> Parser TextView)
-> (Object -> Parser TextView) -> Value -> Parser TextView
forall a b. (a -> b) -> a -> b
$ \Object
v -> TextViewType -> TextViewDescription -> ByteString -> TextView
TextView
                (TextViewType -> TextViewDescription -> ByteString -> TextView)
-> Parser TextViewType
-> Parser (TextViewDescription -> ByteString -> TextView)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> TextViewType
TextViewType (ByteString -> TextViewType)
-> (Text -> ByteString) -> Text -> TextViewType
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
Text.encodeUtf8 (Text -> TextViewType) -> Parser Text -> Parser TextViewType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"type")
                Parser (TextViewDescription -> ByteString -> TextView)
-> Parser TextViewDescription -> Parser (ByteString -> TextView)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> TextViewDescription
TextViewDescription (ByteString -> TextViewDescription)
-> (Text -> ByteString) -> Text -> TextViewDescription
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> ByteString
Text.encodeUtf8 (Text -> TextViewDescription)
-> Parser Text -> Parser TextViewDescription
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"description")
                Parser (ByteString -> TextView)
-> Parser ByteString -> Parser TextView
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> Parser ByteString
parseJSONBase16 (Value -> Parser ByteString) -> Parser Value -> Parser ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"cborHex")

parseJSONBase16 :: Value -> Parser ByteString
parseJSONBase16 :: Value -> Parser ByteString
parseJSONBase16 Value
v = do
  Text
t <- Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
  (String -> Parser ByteString)
-> (ByteString -> Parser ByteString)
-> Either String ByteString
-> Parser ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either String ByteString
decodeEitherBase16 (Text -> ByteString
Text.encodeUtf8 Text
t))

textViewJSONConfig :: Config
textViewJSONConfig :: Config
textViewJSONConfig = Config
defConfig { confCompare :: Text -> Text -> Ordering
confCompare = Text -> Text -> Ordering
textViewJSONKeyOrder }

textViewJSONKeyOrder :: Text -> Text -> Ordering
textViewJSONKeyOrder :: Text -> Text -> Ordering
textViewJSONKeyOrder = [Text] -> Text -> Text -> Ordering
keyOrder [Text
"type", Text
"description", Text
"cborHex"]


-- | The errors that the pure 'TextView' parsing\/decoding functions can return.
--
data TextViewError
  = TextViewFormatError !Text
  | TextViewTypeError   ![TextViewType] !TextViewType -- ^ expected, actual
  | TextViewDecodeError !DecoderError
  | TextViewAesonDecodeError !String
  deriving (TextViewError -> TextViewError -> Bool
(TextViewError -> TextViewError -> Bool)
-> (TextViewError -> TextViewError -> Bool) -> Eq TextViewError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextViewError -> TextViewError -> Bool
$c/= :: TextViewError -> TextViewError -> Bool
== :: TextViewError -> TextViewError -> Bool
$c== :: TextViewError -> TextViewError -> Bool
Eq, Int -> TextViewError -> ShowS
[TextViewError] -> ShowS
TextViewError -> String
(Int -> TextViewError -> ShowS)
-> (TextViewError -> String)
-> ([TextViewError] -> ShowS)
-> Show TextViewError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextViewError] -> ShowS
$cshowList :: [TextViewError] -> ShowS
show :: TextViewError -> String
$cshow :: TextViewError -> String
showsPrec :: Int -> TextViewError -> ShowS
$cshowsPrec :: Int -> TextViewError -> ShowS
Show)

renderTextViewError :: TextViewError -> Text
renderTextViewError :: TextViewError -> Text
renderTextViewError TextViewError
tve =
  case TextViewError
tve of
    TextViewFormatError Text
err -> Text
"TextView format error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a b. ConvertText a b => a -> b
toS Text
err

    TextViewTypeError [TextViewType
expType] TextViewType
actType ->
        Text
"TextView type error: "
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeLatin1 (TextViewType -> ByteString
unTextViewType TextViewType
expType)
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Actual: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeLatin1 (TextViewType -> ByteString
unTextViewType TextViewType
actType)

    TextViewTypeError [TextViewType]
expTypes TextViewType
actType ->
        Text
"TextView type error: "
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Expected one of: "
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", "
          [ ByteString -> Text
Text.decodeLatin1 (TextViewType -> ByteString
unTextViewType TextViewType
expType) | TextViewType
expType <- [TextViewType]
expTypes ]
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Actual: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeLatin1 (TextViewType -> ByteString
unTextViewType TextViewType
actType)
    TextViewAesonDecodeError String
decErr -> Text
"TextView aeson decode error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
textShow String
decErr
    TextViewDecodeError DecoderError
decErr -> Text
"TextView decode error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> DecoderError -> Text
forall a. Show a => a -> Text
textShow DecoderError
decErr

-- ----------------------------------------------------------------------------

-- | Check that the \"type\" of the 'TextView' is as expected.
--
-- For example, one might check that the type is \"TxSignedShelley\".
--
expectTextViewOfType :: TextViewType -> TextView -> Either TextViewError ()
expectTextViewOfType :: TextViewType -> TextView -> Either TextViewError ()
expectTextViewOfType TextViewType
expectedType TextView
tv = do
    let actualType :: TextViewType
actualType = TextView -> TextViewType
tvType TextView
tv
    Bool -> Either TextViewError () -> Either TextViewError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TextViewType
expectedType TextViewType -> TextViewType -> Bool
forall a. Eq a => a -> a -> Bool
== TextViewType
actualType) (Either TextViewError () -> Either TextViewError ())
-> Either TextViewError () -> Either TextViewError ()
forall a b. (a -> b) -> a -> b
$
      TextViewError -> Either TextViewError ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([TextViewType] -> TextViewType -> TextViewError
TextViewTypeError [TextViewType
expectedType] TextViewType
actualType)


-- ----------------------------------------------------------------------------

-- | The errors that the IO 'TextView' reading\/decoding actions can return.
--
data TextViewFileError
  = TextViewFileError !FilePath !TextViewError
  | TextViewFileIOError !FilePath !IOException
  deriving (TextViewFileError -> TextViewFileError -> Bool
(TextViewFileError -> TextViewFileError -> Bool)
-> (TextViewFileError -> TextViewFileError -> Bool)
-> Eq TextViewFileError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextViewFileError -> TextViewFileError -> Bool
$c/= :: TextViewFileError -> TextViewFileError -> Bool
== :: TextViewFileError -> TextViewFileError -> Bool
$c== :: TextViewFileError -> TextViewFileError -> Bool
Eq, Int -> TextViewFileError -> ShowS
[TextViewFileError] -> ShowS
TextViewFileError -> String
(Int -> TextViewFileError -> ShowS)
-> (TextViewFileError -> String)
-> ([TextViewFileError] -> ShowS)
-> Show TextViewFileError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextViewFileError] -> ShowS
$cshowList :: [TextViewFileError] -> ShowS
show :: TextViewFileError -> String
$cshow :: TextViewFileError -> String
showsPrec :: Int -> TextViewFileError -> ShowS
$cshowsPrec :: Int -> TextViewFileError -> ShowS
Show)

renderTextViewFileError :: TextViewFileError -> Text
renderTextViewFileError :: TextViewFileError -> Text
renderTextViewFileError TextViewFileError
tvfe =
  case TextViewFileError
tvfe of
    TextViewFileError String
fp TextViewError
err -> String -> Text
forall a b. ConvertText a b => a -> b
toS String
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TextViewError -> Text
renderTextViewError TextViewError
err
    TextViewFileIOError String
fp IOException
ioExcpt ->
      Text
"TextView IO exception at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOException -> Text
forall a. Show a => a -> Text
textShow IOException
ioExcpt


-- ----------------------------------------------------------------------------

textShow :: Show a => a -> Text
textShow :: a -> Text
textShow = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> String
forall a b. (Show a, ConvertText String b) => a -> b
show