{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Rpc.Server.Internal.Orphans where

import Cardano.Api.Era
import Cardano.Api.Error
import Cardano.Api.Ledger qualified as L
import Cardano.Api.Pretty
import Cardano.Api.Serialise.Raw
import Cardano.Api.Tx
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as U5c

import RIO hiding (toList)

import Data.Default
import Data.ProtoLens (defMessage)
import Data.ProtoLens.Message (Message)
import Data.Ratio (denominator, numerator, (%))
import Network.GRPC.Spec

---------------
-- Conversion
---------------

-- It's easier to use 'Proto a' wrappers for RPC types, because it makes lens automatically available.

-- | Convert a 'Rational' into a protobuf 'U5c.RationalNumber'.
--
-- The UTxO RPC spec fixes the field widths to an @int32@ numerator and a
-- @uint32@ denominator, while on-chain rationals (e.g. bounded ratios backed
-- by 'Word64') can exceed both. When the numerator and the denominator fit
-- their fields, the conversion is exact. Otherwise the result is the best
-- representable approximation of the value: magnitudes beyond
-- @maxBound \@Int32@ are clamped to it, so out-of-range negative values
-- clamp to @-maxBound \@Int32@ (one above @minBound \@Int32@), and other
-- values are approximated using continued fractions, keeping both
-- components within their field bounds.
-- The conversion is therefore lossy for such out-of-range values, and values
-- close enough to zero may approximate to zero.
instance Inject Rational (Proto U5c.RationalNumber) where
  inject :: Rational -> Proto RationalNumber
inject Rational
r =
    Proto RationalNumber
forall msg. Message msg => msg
defMessage
      Proto RationalNumber
-> (Proto RationalNumber -> Proto RationalNumber)
-> Proto RationalNumber
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto RationalNumber) Int32
forall (f :: * -> *) s a.
(Functor f, HasField s "numerator" a) =>
LensLike' f s a
U5c.numerator LensLike' Identity (Proto RationalNumber) Int32
-> Int32 -> Proto RationalNumber -> Proto RationalNumber
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Int32
forall a. Num a => Integer -> a
fromInteger Integer
num
      Proto RationalNumber
-> (Proto RationalNumber -> Proto RationalNumber)
-> Proto RationalNumber
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto RationalNumber) Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "denominator" a) =>
LensLike' f s a
U5c.denominator LensLike' Identity (Proto RationalNumber) Word32
-> Word32 -> Proto RationalNumber -> Proto RationalNumber
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Word32
forall a. Num a => Integer -> a
fromInteger Integer
den
   where
    (Integer
num, Integer
den)
      | Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound @Int32)
      , Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxNum
      , Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxDen =
          (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r, Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r)
      | Bool
otherwise = do
          let approximation :: Rational
approximation = Rational -> Rational
bestApproximation (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ Rational -> Rational
forall a. Num a => a -> a
abs Rational
r
          (Integer -> Integer
forall a. Num a => a -> a
signum (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Rational -> Integer
forall a. Ratio a -> a
numerator Rational
approximation, Rational -> Integer
forall a. Ratio a -> a
denominator Rational
approximation)

    maxNum :: Integer
maxNum = Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Int32) :: Integer

    maxDen :: Integer
maxDen = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word32) :: Integer

    -- Best approximation of a non-negative rational keeping the numerator and
    -- the denominator within 'maxNum' and 'maxDen' respectively: walk the
    -- continued fraction convergents of the value until a bound is exceeded,
    -- then pick the closer of the last in-bounds convergent and the largest
    -- in-bounds semiconvergent.
    bestApproximation :: Rational -> Rational
    bestApproximation :: Rational -> Rational
bestApproximation Rational
x
      | Rational
x Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
maxNum = Integer
maxNum Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1
      | Bool
otherwise = Integer -> Integer -> Integer -> Integer -> Rational -> Rational
go Integer
0 Integer
1 Integer
1 Integer
0 Rational
x
     where
      -- (hPrev, kPrev) and (hCur, kCur) are the components of the two most
      -- recent convergents, y is the current complete quotient. The first
      -- convergent (floor x % 1) is always in bounds because x <= maxNum, so
      -- the out-of-bounds branch never divides by kCur = 0.
      go :: Integer -> Integer -> Integer -> Integer -> Rational -> Rational
      go :: Integer -> Integer -> Integer -> Integer -> Rational -> Rational
go Integer
hPrev Integer
kPrev Integer
hCur Integer
kCur Rational
y = do
        let a :: Integer
a = Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Rational
y
            hNew :: Integer
hNew = Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
hCur Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
hPrev
            kNew :: Integer
kNew = Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
kCur Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
kPrev
            rest :: Rational
rest = Rational
y Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
a
        if Integer
hNew Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
maxNum Bool -> Bool -> Bool
|| Integer
kNew Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
maxDen
          then do
            -- the largest coefficient for which the semiconvergent still fits
            -- both bounds
            let aFromNum :: Integer
aFromNum = if Integer
hCur Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 then (Integer
maxNum Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
hPrev) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
hCur else Integer
a
                aMax :: Integer
aMax = Integer
a Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
`min` Integer
aFromNum Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
`min` ((Integer
maxDen Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
kPrev) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
kCur)
                semiconvergent :: Rational
semiconvergent = (Integer
aMax Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
hCur Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
hPrev) Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% (Integer
aMax Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
kCur Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
kPrev)
                convergent :: Rational
convergent = Integer
hCur Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
kCur
            if Integer
aMax Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
1 Bool -> Bool -> Bool
&& Rational -> Rational
forall a. Num a => a -> a
abs (Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
semiconvergent) Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational -> Rational
forall a. Num a => a -> a
abs (Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
convergent)
              then Rational
semiconvergent
              else Rational
convergent
          else
            if Rational
rest Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0
              then Integer
hNew Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
kNew
              else Integer -> Integer -> Integer -> Integer -> Rational -> Rational
go Integer
hCur Integer
kCur Integer
hNew Integer
kNew (Rational -> Rational
forall a. Fractional a => a -> a
recip Rational
rest)

instance Inject (Proto U5c.ExUnits) L.ExUnits where
  inject :: Proto ExUnits -> ExUnits
inject Proto ExUnits
r =
    L.ExUnits
      { exUnitsMem :: Natural
L.exUnitsMem = Proto ExUnits
r Proto ExUnits -> Getting Natural (Proto ExUnits) Natural -> Natural
forall s a. s -> Getting a s a -> a
^. LensLike' (Const Natural) (Proto ExUnits) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "memory" a) =>
LensLike' f s a
U5c.memory LensLike' (Const Natural) (Proto ExUnits) Word64
-> ((Natural -> Const Natural Natural)
    -> Word64 -> Const Natural Word64)
-> Getting Natural (Proto ExUnits) Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Natural) -> SimpleGetter Word64 Natural
forall s a. (s -> a) -> SimpleGetter s a
to Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      , exUnitsSteps :: Natural
L.exUnitsSteps = Proto ExUnits
r Proto ExUnits -> Getting Natural (Proto ExUnits) Natural -> Natural
forall s a. s -> Getting a s a -> a
^. LensLike' (Const Natural) (Proto ExUnits) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "steps" a) =>
LensLike' f s a
U5c.steps LensLike' (Const Natural) (Proto ExUnits) Word64
-> ((Natural -> Const Natural Natural)
    -> Word64 -> Const Natural Word64)
-> Getting Natural (Proto ExUnits) Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Natural) -> SimpleGetter Word64 Natural
forall s a. (s -> a) -> SimpleGetter s a
to Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      }

instance Inject L.ExUnits (Proto U5c.ExUnits) where
  inject :: ExUnits -> Proto ExUnits
inject L.ExUnits{exUnitsMem :: ExUnits -> Natural
L.exUnitsMem = Natural
mem, exUnitsSteps :: ExUnits -> Natural
L.exUnitsSteps = Natural
steps} =
    Proto ExUnits
forall msg. Message msg => msg
defMessage
      Proto ExUnits -> (Proto ExUnits -> Proto ExUnits) -> Proto ExUnits
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ExUnits) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "memory" a) =>
LensLike' f s a
U5c.memory LensLike' Identity (Proto ExUnits) Word64
-> Word64 -> Proto ExUnits -> Proto ExUnits
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
mem
      Proto ExUnits -> (Proto ExUnits -> Proto ExUnits) -> Proto ExUnits
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ExUnits) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "steps" a) =>
LensLike' f s a
U5c.steps LensLike' Identity (Proto ExUnits) Word64
-> Word64 -> Proto ExUnits -> Proto ExUnits
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
steps

-- | Note that conversion is not total in the other direction
instance Inject TxIn (Proto U5c.TxoRef) where
  inject :: TxIn -> Proto TxoRef
inject (TxIn TxId
txId' (TxIx Word
txIx)) =
    Proto TxoRef
forall msg. Message msg => msg
defMessage
      Proto TxoRef -> (Proto TxoRef -> Proto TxoRef) -> Proto TxoRef
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxoRef) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "hash" a) =>
LensLike' f s a
U5c.hash LensLike' Identity (Proto TxoRef) ByteString
-> ByteString -> Proto TxoRef -> Proto TxoRef
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes TxId
txId'
      Proto TxoRef -> (Proto TxoRef -> Proto TxoRef) -> Proto TxoRef
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxoRef) Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "index" a) =>
LensLike' f s a
U5c.index LensLike' Identity (Proto TxoRef) Word32
-> Word32 -> Proto TxoRef -> Proto TxoRef
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
txIx

instance Message a => Default (Proto a) where
  def :: Proto a
def = Proto a
forall msg. Message msg => msg
defMessage

instance Inject Integer (Proto U5c.BigInt) where
  inject :: Integer -> Proto BigInt
inject Integer
int
    | Integer
int Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Int64)
        Bool -> Bool -> Bool
&& Integer
int Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound @Int64) =
        forall t s. Inject t s => t -> s
inject @Int64 (Int64 -> Proto BigInt) -> Int64 -> Proto BigInt
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
int
    | Integer
int Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 =
        -- https://www.rfc-editor.org/rfc/rfc8949.html#name-bignums see 3.4.3 for negative integers
        Proto BigInt
forall msg. Message msg => msg
defMessage Proto BigInt -> (Proto BigInt -> Proto BigInt) -> Proto BigInt
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto BigInt) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "bigNInt" a) =>
LensLike' f s a
U5c.bigNInt LensLike' Identity (Proto BigInt) ByteString
-> ByteString -> Proto BigInt -> Proto BigInt
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes (forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @Natural (-Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
int))
    | Bool
otherwise =
        Proto BigInt
forall msg. Message msg => msg
defMessage Proto BigInt -> (Proto BigInt -> Proto BigInt) -> Proto BigInt
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto BigInt) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "bigUInt" a) =>
LensLike' f s a
U5c.bigUInt LensLike' Identity (Proto BigInt) ByteString
-> ByteString -> Proto BigInt -> Proto BigInt
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes (forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @Natural Integer
int)

instance Inject Int64 (Proto U5c.BigInt) where
  inject :: Int64 -> Proto BigInt
inject Int64
int = Proto BigInt
forall msg. Message msg => msg
defMessage Proto BigInt -> (Proto BigInt -> Proto BigInt) -> Proto BigInt
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto BigInt) Int64
forall (f :: * -> *) s a.
(Functor f, HasField s "int" a) =>
LensLike' f s a
U5c.int LensLike' Identity (Proto BigInt) Int64
-> Int64 -> Proto BigInt -> Proto BigInt
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int64
int

instance Inject L.Coin (Proto U5c.BigInt) where
  inject :: Coin -> Proto BigInt
inject = Integer -> Proto BigInt
forall t s. Inject t s => t -> s
inject (Integer -> Proto BigInt)
-> (Coin -> Integer) -> Coin -> Proto BigInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @Integer

-----------
-- Errors
-----------

-- TODO add RIO to cardano-api and move this instance there

instance Error StringException where
  prettyError :: forall ann. StringException -> Doc ann
prettyError = StringException -> Doc ann
forall a ann. Exception a => a -> Doc ann
prettyException

instance IsString e => MonadFail (Either e) where
  fail :: forall a. HasCallStack => String -> Either e a
fail = e -> Either e a
forall a b. a -> Either a b
Left (e -> Either e a) -> (String -> e) -> String -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> e
forall a. IsString a => String -> a
fromString