{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeApplications   #-}
{-| ChainTip type with ToJSON / FromJSON instances
-}
module Convex.NodeClient.ChainTip(
  JSONChainTip(..),
  blockHeaderTip,
  JSONChainPoint(..),
  blockHeaderPoint,
  JSONBlockNo(..),

  -- * Etc.
  chainPointText
) where

import           Cardano.Api               (BlockHeader (..), BlockNo (..),
                                            ChainPoint (..), ChainTip (..),
                                            Hash, chainTipToChainPoint,
                                            deserialiseFromRawBytesHex,
                                            proxyToAsType,
                                            serialiseToRawBytesHexText)
import           Data.Aeson                (FromJSON (..), ToJSON (..), object,
                                            withObject, (.:), (.=))
import qualified Data.Aeson                as Aeson
import           Data.Proxy                (Proxy (..))
import           Data.Text                 (Text)
import qualified Data.Text                 as Text
import qualified Data.Text.Encoding        as Text
import qualified Ouroboros.Consensus.Block as Consensus

newtype JSONChainTip = JSONChainTip{ JSONChainTip -> ChainTip
unJSONChainTip :: ChainTip }
  deriving newtype (JSONChainTip -> JSONChainTip -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSONChainTip -> JSONChainTip -> Bool
$c/= :: JSONChainTip -> JSONChainTip -> Bool
== :: JSONChainTip -> JSONChainTip -> Bool
$c== :: JSONChainTip -> JSONChainTip -> Bool
Eq, Int -> JSONChainTip -> ShowS
[JSONChainTip] -> ShowS
JSONChainTip -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JSONChainTip] -> ShowS
$cshowList :: [JSONChainTip] -> ShowS
show :: JSONChainTip -> String
$cshow :: JSONChainTip -> String
showsPrec :: Int -> JSONChainTip -> ShowS
$cshowsPrec :: Int -> JSONChainTip -> ShowS
Show, [JSONChainTip] -> Encoding
[JSONChainTip] -> Value
JSONChainTip -> Encoding
JSONChainTip -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [JSONChainTip] -> Encoding
$ctoEncodingList :: [JSONChainTip] -> Encoding
toJSONList :: [JSONChainTip] -> Value
$ctoJSONList :: [JSONChainTip] -> Value
toEncoding :: JSONChainTip -> Encoding
$ctoEncoding :: JSONChainTip -> Encoding
toJSON :: JSONChainTip -> Value
$ctoJSON :: JSONChainTip -> Value
ToJSON)

blockHeaderTip :: BlockHeader -> ChainTip
blockHeaderTip :: BlockHeader -> ChainTip
blockHeaderTip (BlockHeader SlotNo
slotNo Hash BlockHeader
blockHash BlockNo
blockNo) =
  SlotNo -> Hash BlockHeader -> BlockNo -> ChainTip
ChainTip SlotNo
slotNo Hash BlockHeader
blockHash BlockNo
blockNo

instance FromJSON JSONChainTip where
  parseJSON :: Value -> Parser JSONChainTip
parseJSON Value
Aeson.Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainTip -> JSONChainTip
JSONChainTip ChainTip
ChainTipAtGenesis)
  parseJSON Value
y          = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JSONChainTip" (\Object
obj ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainTip -> JSONChainTip
JSONChainTip forall a b. (a -> b) -> a -> b
$ SlotNo -> Hash BlockHeader -> BlockNo -> ChainTip
ChainTip
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"slot"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hash" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Text
t :: Text) -> case forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either RawBytesHexError a
deserialiseFromRawBytesHex (forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @(Hash BlockHeader)) (Text -> ByteString
Text.encodeUtf8 Text
t) of { Left RawBytesHexError
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show RawBytesHexError
err); Right Hash BlockHeader
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Hash BlockHeader
x})
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> BlockNo
Consensus.BlockNo (Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"block")) Value
y

newtype JSONChainPoint = JSONChainPoint ChainPoint
  deriving newtype (JSONChainPoint -> JSONChainPoint -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSONChainPoint -> JSONChainPoint -> Bool
$c/= :: JSONChainPoint -> JSONChainPoint -> Bool
== :: JSONChainPoint -> JSONChainPoint -> Bool
$c== :: JSONChainPoint -> JSONChainPoint -> Bool
Eq, Int -> JSONChainPoint -> ShowS
[JSONChainPoint] -> ShowS
JSONChainPoint -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JSONChainPoint] -> ShowS
$cshowList :: [JSONChainPoint] -> ShowS
show :: JSONChainPoint -> String
$cshow :: JSONChainPoint -> String
showsPrec :: Int -> JSONChainPoint -> ShowS
$cshowsPrec :: Int -> JSONChainPoint -> ShowS
Show)

instance ToJSON JSONChainPoint where
  toJSON :: JSONChainPoint -> Value
toJSON (JSONChainPoint ChainPoint
jp) = case ChainPoint
jp of
    ChainPoint
ChainPointAtGenesis -> forall a. ToJSON a => a -> Value
toJSON (String
"ChainPointAtGenesis" :: String)
    ChainPoint SlotNo
s Hash BlockHeader
h      -> [Pair] -> Value
object [Key
"slot" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SlotNo
s, Key
"block_header" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Hash BlockHeader
h]

instance FromJSON JSONChainPoint where
  parseJSON :: Value -> Parser JSONChainPoint
parseJSON (Aeson.String Text
"ChainPointAtGenesis") = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChainPoint -> JSONChainPoint
JSONChainPoint ChainPoint
ChainPointAtGenesis)
  parseJSON Value
x = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JSONChainPoint" (\Object
obj ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ChainPoint -> JSONChainPoint
JSONChainPoint (SlotNo -> Hash BlockHeader -> ChainPoint
ChainPoint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"slot" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"block_header")) Value
x

newtype JSONBlockNo = JSONBlockNo{JSONBlockNo -> BlockNo
unJSONBlockNo :: BlockNo }
  deriving newtype (JSONBlockNo -> JSONBlockNo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSONBlockNo -> JSONBlockNo -> Bool
$c/= :: JSONBlockNo -> JSONBlockNo -> Bool
== :: JSONBlockNo -> JSONBlockNo -> Bool
$c== :: JSONBlockNo -> JSONBlockNo -> Bool
Eq, Int -> JSONBlockNo -> ShowS
[JSONBlockNo] -> ShowS
JSONBlockNo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JSONBlockNo] -> ShowS
$cshowList :: [JSONBlockNo] -> ShowS
show :: JSONBlockNo -> String
$cshow :: JSONBlockNo -> String
showsPrec :: Int -> JSONBlockNo -> ShowS
$cshowsPrec :: Int -> JSONBlockNo -> ShowS
Show)

instance ToJSON JSONBlockNo where
  toJSON :: JSONBlockNo -> Value
toJSON (JSONBlockNo (BlockNo Word64
n)) = forall a. ToJSON a => a -> Value
toJSON Word64
n

instance FromJSON JSONBlockNo where
  parseJSON :: Value -> Parser JSONBlockNo
parseJSON Value
x = (BlockNo -> JSONBlockNo
JSONBlockNo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> BlockNo
BlockNo) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
x

blockHeaderPoint :: BlockHeader -> ChainPoint
blockHeaderPoint :: BlockHeader -> ChainPoint
blockHeaderPoint = ChainTip -> ChainPoint
chainTipToChainPoint forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> ChainTip
blockHeaderTip

chainPointText :: ChainPoint -> Text
chainPointText :: ChainPoint -> Text
chainPointText = \case
  ChainPoint
ChainPointAtGenesis -> Text
"Genesis"
  ChainPoint (Consensus.SlotNo Word64
slot) Hash BlockHeader
blockHeader ->
    forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText Hash BlockHeader
blockHeader forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show Word64
slot)