{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 UtxoRpc

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.

instance Inject (Proto UtxoRpc.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
^. (Int64 -> Const Integer Int64)
-> Proto RationalNumber -> Const Integer (Proto RationalNumber)
#numerator ((Int64 -> Const Integer Int64)
 -> Proto RationalNumber -> Const Integer (Proto RationalNumber))
-> ((Integer -> Const Integer Integer)
    -> Int64 -> Const Integer Int64)
-> Getting Integer (Proto RationalNumber) Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> Integer) -> SimpleGetter Int64 Integer
forall s a. (s -> a) -> SimpleGetter s a
to Int64 -> 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
^. (Word64 -> Const Integer Word64)
-> Proto RationalNumber -> Const Integer (Proto RationalNumber)
#denominator ((Word64 -> Const Integer Word64)
 -> Proto RationalNumber -> Const Integer (Proto RationalNumber))
-> ((Integer -> Const Integer Integer)
    -> Word64 -> Const Integer Word64)
-> Getting Integer (Proto RationalNumber) Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Integer) -> SimpleGetter Word64 Integer
forall s a. (s -> a) -> SimpleGetter s a
to Word64 -> 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 UtxoRpc.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
& ASetter (Proto RationalNumber) (Proto RationalNumber) Int64 Int64
#numerator ASetter (Proto RationalNumber) (Proto RationalNumber) Int64 Int64
-> Int64 -> Proto RationalNumber -> Proto RationalNumber
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Int64
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
& ASetter (Proto RationalNumber) (Proto RationalNumber) Word64 Word64
#denominator ASetter (Proto RationalNumber) (Proto RationalNumber) Word64 Word64
-> Word64 -> Proto RationalNumber -> Proto RationalNumber
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r)

instance Inject (Proto UtxoRpc.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
^. (Word64 -> Const Natural Word64)
-> Proto ExUnits -> Const Natural (Proto ExUnits)
#memory ((Word64 -> Const Natural Word64)
 -> Proto ExUnits -> Const Natural (Proto ExUnits))
-> ((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
^. (Word64 -> Const Natural Word64)
-> Proto ExUnits -> Const Natural (Proto ExUnits)
#steps ((Word64 -> Const Natural Word64)
 -> Proto ExUnits -> Const Natural (Proto ExUnits))
-> ((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 UtxoRpc.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
& ASetter (Proto ExUnits) (Proto ExUnits) Word64 Word64
#memory ASetter (Proto ExUnits) (Proto ExUnits) Word64 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
& ASetter (Proto ExUnits) (Proto ExUnits) Word64 Word64
#steps ASetter (Proto ExUnits) (Proto ExUnits) Word64 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 UtxoRpc.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
& ASetter (Proto TxoRef) (Proto TxoRef) ByteString ByteString
#hash ASetter (Proto TxoRef) (Proto TxoRef) ByteString 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
& ASetter (Proto TxoRef) (Proto TxoRef) Word32 Word32
#index ASetter (Proto TxoRef) (Proto TxoRef) Word32 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

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