{-# LANGUAGE RankNTypes #-}

module Cardano.Rpc.Server.Internal.UtxoRpc.Type.ChainPoint
  ( mkChainPointMsg
  , utxoRpcChainPointMsgToChainPoint
  )
where

import Cardano.Api.Block
import Cardano.Api.Error
import Cardano.Api.Hash
import Cardano.Api.Serialise.Raw
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as U5c
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc

import Cardano.Ledger.BaseTypes (WithOrigin (..))

import RIO

import Data.ByteString.Short qualified as SBS
import Data.ProtoLens (defMessage)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Network.GRPC.Spec

mkChainPointMsg
  :: ChainPoint
  -> WithOrigin BlockNo
  -> UTCTime
  -> Proto UtxoRpc.ChainPoint
mkChainPointMsg :: ChainPoint -> WithOrigin BlockNo -> UTCTime -> Proto ChainPoint
mkChainPointMsg ChainPoint
chainPoint WithOrigin BlockNo
blockNo UTCTime
timestamp = do
  let (Word64
slotNo, ByteString
blockHash) = case ChainPoint
chainPoint of
        ChainPoint
ChainPointAtGenesis -> (Word64
0, ByteString
forall a. Monoid a => a
mempty)
        ChainPoint (SlotNo Word64
slot) (HeaderHash ShortByteString
hash) -> (Word64
slot, ShortByteString -> ByteString
SBS.fromShort ShortByteString
hash)
      blockHeight :: Word64
blockHeight = case WithOrigin BlockNo
blockNo of
        WithOrigin BlockNo
Origin -> Word64
0
        At (BlockNo Word64
h) -> Word64
h
      timestampMs :: Word64
timestampMs = NominalDiffTime -> Word64
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Word64)
-> (UTCTime -> NominalDiffTime) -> UTCTime -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000) (NominalDiffTime -> NominalDiffTime)
-> (UTCTime -> NominalDiffTime) -> UTCTime -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds (UTCTime -> Word64) -> UTCTime -> Word64
forall a b. (a -> b) -> a -> b
$ UTCTime
timestamp
  Proto ChainPoint
forall msg. Message msg => msg
defMessage
    Proto ChainPoint
-> (Proto ChainPoint -> Proto ChainPoint) -> Proto ChainPoint
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ChainPoint) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "slot" a) =>
LensLike' f s a
U5c.slot LensLike' Identity (Proto ChainPoint) Word64
-> Word64 -> Proto ChainPoint -> Proto ChainPoint
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word64
slotNo
    Proto ChainPoint
-> (Proto ChainPoint -> Proto ChainPoint) -> Proto ChainPoint
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ChainPoint) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "hash" a) =>
LensLike' f s a
U5c.hash LensLike' Identity (Proto ChainPoint) ByteString
-> ByteString -> Proto ChainPoint -> Proto ChainPoint
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ByteString
blockHash
    Proto ChainPoint
-> (Proto ChainPoint -> Proto ChainPoint) -> Proto ChainPoint
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ChainPoint) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "height" a) =>
LensLike' f s a
U5c.height LensLike' Identity (Proto ChainPoint) Word64
-> Word64 -> Proto ChainPoint -> Proto ChainPoint
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word64
blockHeight
    Proto ChainPoint
-> (Proto ChainPoint -> Proto ChainPoint) -> Proto ChainPoint
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ChainPoint) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "timestamp" a) =>
LensLike' f s a
U5c.timestamp LensLike' Identity (Proto ChainPoint) Word64
-> Word64 -> Proto ChainPoint -> Proto ChainPoint
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word64
timestampMs

-- | Inverse of 'mkChainPointMsg'. Note: @Origin@ and @At (BlockNo 0)@ both
-- encode to @height=0@, so the decode always maps @0@ back to @Origin@.
utxoRpcChainPointMsgToChainPoint
  :: HasCallStack
  => MonadThrow m
  => Proto UtxoRpc.ChainPoint
  -> m (ChainPoint, WithOrigin BlockNo, UTCTime)
utxoRpcChainPointMsgToChainPoint :: forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
Proto ChainPoint -> m (ChainPoint, WithOrigin BlockNo, UTCTime)
utxoRpcChainPointMsgToChainPoint Proto ChainPoint
msg = do
  let slot :: Word64
slot = Proto ChainPoint
msg Proto ChainPoint
-> Getting Word64 (Proto ChainPoint) Word64 -> Word64
forall s a. s -> Getting a s a -> a
^. Getting Word64 (Proto ChainPoint) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "slot" a) =>
LensLike' f s a
U5c.slot
      blockHash :: ByteString
blockHash = Proto ChainPoint
msg Proto ChainPoint
-> Getting ByteString (Proto ChainPoint) ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Proto ChainPoint) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "hash" a) =>
LensLike' f s a
U5c.hash
      blockHeight :: Word64
blockHeight = Proto ChainPoint
msg Proto ChainPoint
-> Getting Word64 (Proto ChainPoint) Word64 -> Word64
forall s a. s -> Getting a s a -> a
^. Getting Word64 (Proto ChainPoint) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "height" a) =>
LensLike' f s a
U5c.height
      timestamp :: UTCTime
timestamp = NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (Word64 -> NominalDiffTime) -> Word64 -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
1000) (NominalDiffTime -> NominalDiffTime)
-> (Word64 -> NominalDiffTime) -> Word64 -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> UTCTime) -> Word64 -> UTCTime
forall a b. (a -> b) -> a -> b
$ Proto ChainPoint
msg Proto ChainPoint
-> Getting Word64 (Proto ChainPoint) Word64 -> Word64
forall s a. s -> Getting a s a -> a
^. Getting Word64 (Proto ChainPoint) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "timestamp" a) =>
LensLike' f s a
U5c.timestamp
  chainPoint <-
    if Word64
slot Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 Bool -> Bool -> Bool
&& ByteString
blockHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
forall a. Monoid a => a
mempty
      then ChainPoint -> m ChainPoint
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainPoint
ChainPointAtGenesis
      else do
        headerHash <- Either SerialiseAsRawBytesError (Hash BlockHeader)
-> m (Hash BlockHeader)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Typeable e, Error e) =>
Either e a -> m a
liftEitherError (Either SerialiseAsRawBytesError (Hash BlockHeader)
 -> m (Hash BlockHeader))
-> Either SerialiseAsRawBytesError (Hash BlockHeader)
-> m (Hash BlockHeader)
forall a b. (a -> b) -> a -> b
$ AsType (Hash BlockHeader)
-> ByteString -> Either SerialiseAsRawBytesError (Hash BlockHeader)
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes (AsType BlockHeader -> AsType (Hash BlockHeader)
forall a. AsType a -> AsType (Hash a)
AsHash AsType BlockHeader
forall t. HasTypeProxy t => AsType t
asType) ByteString
blockHash
        pure $ ChainPoint (SlotNo slot) headerHash
  let blockNo
        | Word64
blockHeight Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = WithOrigin BlockNo
forall t. WithOrigin t
Origin
        | Bool
otherwise = BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At (Word64 -> BlockNo
BlockNo Word64
blockHeight)
  pure (chainPoint, blockNo, timestamp)