{-# 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.

-- x = U5c.numerator :: _

instance Inject (Proto U5c.RationalNumber) Rational where
  inject :: Proto RationalNumber -> Rational
inject Proto RationalNumber
r = Proto RationalNumber
r Proto RationalNumber
-> Getting Integer (Proto RationalNumber) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. LensLike' (Const Integer) (Proto RationalNumber) Int32
forall (f :: * -> *) s a.
(Functor f, HasField s "numerator" a) =>
LensLike' f s a
U5c.numerator LensLike' (Const Integer) (Proto RationalNumber) Int32
-> ((Integer -> Const Integer Integer)
    -> Int32 -> Const Integer Int32)
-> Getting Integer (Proto RationalNumber) Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32 -> Integer) -> SimpleGetter Int32 Integer
forall s a. (s -> a) -> SimpleGetter s a
to Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Proto RationalNumber
r Proto RationalNumber
-> Getting Integer (Proto RationalNumber) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. LensLike' (Const Integer) (Proto RationalNumber) Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "denominator" a) =>
LensLike' f s a
U5c.denominator LensLike' (Const Integer) (Proto RationalNumber) Word32
-> ((Integer -> Const Integer Integer)
    -> Word32 -> Const Integer Word32)
-> Getting Integer (Proto RationalNumber) Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Integer) -> SimpleGetter Word32 Integer
forall s a. (s -> a) -> SimpleGetter s a
to Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- NB. this clips value in Integer -> Int64/Word64 conversion here
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 b. (Integral a, Num b) => a -> b
fromIntegral (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r)
      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 b. (Integral a, Num b) => a -> b
fromIntegral (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r)

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. 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