{- |
Module      : Singular.Registry.Funding
Description : The fixed floor the conformance runner keeps for its scenarios
License     : Apache-2.0

The one place the conformance runner's pre-run funding check lives: what
that runner requires before the first transaction is built, the diagnostic
that names the address, what is required, what is there, and the faucet
step, and the rendering of lovelace amounts that diagnostic reads. Writes
judge the wallet on the measured outlay as client policy, not on this floor.
-}
module Singular.Registry.Funding
    ( -- * Funding
      FundingFloor (..)
    , defaultFundingFloor
    , checkFunding
    ) where

import Data.Map.Strict qualified as Map
import Lens.Micro ((^.))

import Cardano.Ledger.Address (Addr)
import Cardano.Ledger.Api.Tx.Out (valueTxOutL)
import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..))
import Control.Exception (ErrorCall (..), throwIO)
import Singular.Registry.Ledger (Coin (..))
import Singular.Registry.LedgerProvider qualified as Cage
import Singular.Registry.SessionIO qualified as Cage
import Singular.Registry.Wallet (bech32Address)

{- | What the conformance runner requires before the first transaction
is built. A floor, not a guarantee: it catches the empty and the
nearly-empty wallet at the start of a conformance run rather than inside
a balance exception halfway through one. Writes do not use it.
-}
data FundingFloor = FundingFloor
    { FundingFloor -> Integer
floorTotal :: Integer
    -- ^ Total lovelace the address must hold
    , FundingFloor -> Integer
floorCollateral :: Integer
    -- ^ Lovelace in one ada-only UTxO, to serve as collateral
    }
    deriving (FundingFloor -> FundingFloor -> Bool
(FundingFloor -> FundingFloor -> Bool)
-> (FundingFloor -> FundingFloor -> Bool) -> Eq FundingFloor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FundingFloor -> FundingFloor -> Bool
== :: FundingFloor -> FundingFloor -> Bool
$c/= :: FundingFloor -> FundingFloor -> Bool
/= :: FundingFloor -> FundingFloor -> Bool
Eq, Int -> FundingFloor -> ShowS
[FundingFloor] -> ShowS
FundingFloor -> String
(Int -> FundingFloor -> ShowS)
-> (FundingFloor -> String)
-> ([FundingFloor] -> ShowS)
-> Show FundingFloor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FundingFloor -> ShowS
showsPrec :: Int -> FundingFloor -> ShowS
$cshow :: FundingFloor -> String
show :: FundingFloor -> String
$cshowList :: [FundingFloor] -> ShowS
showList :: [FundingFloor] -> ShowS
Show)

-- | 100 ada held, with 5 ada of it in an ada-only output.
defaultFundingFloor :: FundingFloor
defaultFundingFloor :: FundingFloor
defaultFundingFloor =
    FundingFloor
        { floorTotal :: Integer
floorTotal = Integer
100_000_000
        , floorCollateral :: Integer
floorCollateral = Integer
5_000_000
        }

{- | Refuse to start when the funding wallet cannot pay, naming the
address, what is required, what is there, and the faucet step.
-}
checkFunding
    :: (Cage.Network, Cage.LedgerProvider w IO)
    -> Addr
    -> FundingFloor
    -> IO ()
checkFunding :: forall w.
(Network, LedgerProvider w IO) -> Addr -> FundingFloor -> IO ()
checkFunding (Network, LedgerProvider w IO)
prov Addr
addr FundingFloor
fl = do
    utxos <- (Network, LedgerProvider w IO)
-> (Session w IO -> IO Outputs) -> IO Outputs
forall w a.
(Network, LedgerProvider w IO) -> (Session w IO -> IO a) -> IO a
Cage.withLatest (Network, LedgerProvider w IO)
prov (Session w IO -> Addr -> IO Outputs
forall w. Session w IO -> Addr -> IO Outputs
`Cage.outputsAt` Addr
addr)
    let values = ((TxIn, TxOut ConwayEra) -> Value ConwayEra)
-> Outputs -> [Value ConwayEra]
forall a b. (a -> b) -> [a] -> [b]
map (\(TxIn
_, TxOut ConwayEra
out) -> TxOut ConwayEra
out TxOut ConwayEra
-> Getting (Value ConwayEra) (TxOut ConwayEra) (Value ConwayEra)
-> Value ConwayEra
forall s a. s -> Getting a s a -> a
^. Getting (Value ConwayEra) (TxOut ConwayEra) (Value ConwayEra)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut ConwayEra) (Value ConwayEra)
valueTxOutL) Outputs
utxos
        total = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
c | MaryValue (Coin Integer
c) MultiAsset
_ <- [MaryValue]
values]
        adaOnly = [Integer
c | MaryValue (Coin Integer
c) (MultiAsset Map PolicyID (Map AssetName Integer)
m) <- [MaryValue]
values, Map PolicyID (Map AssetName Integer) -> Bool
forall k a. Map k a -> Bool
Map.null Map PolicyID (Map AssetName Integer)
m]
        bestCollateral = if [Integer] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Integer]
adaOnly then Integer
0 else [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Integer]
adaOnly
    if total >= floorTotal fl && bestCollateral >= floorCollateral fl
        then pure ()
        else
            throwIO . ErrorCall . unlines $
                [ "the funding wallet cannot pay for this run."
                , "  address            : " <> bech32Address addr
                , "  lovelace held      : "
                    <> ada total
                    <> " across "
                    <> show (length utxos)
                    <> " UTxO(s)"
                , "  lovelace required  : " <> ada (floorTotal fl)
                , "  ada-only UTxO held : "
                    <> ada bestCollateral
                    <> " (the collateral input)"
                , "  collateral required: " <> ada (floorCollateral fl)
                , "  Fund this address, then rerun. On preprod the faucet is"
                , "    https://docs.cardano.org/cardano-testnets/tools/faucet"
                , "  It pays a single output; send one self-payment \
                  \afterwards so the"
                , "  wallet also holds an ada-only output to spend as \
                  \collateral."
                ]

-- | Lovelace as @N lovelace (X.YYYYYY ada)@.
ada :: Integer -> String
ada :: Integer -> String
ada Integer
l =
    Integer -> String
forall a. Show a => a -> String
show Integer
l
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" lovelace ("
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show (Integer
l Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1_000_000)
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
pad (Integer -> String
forall a. Show a => a -> String
show (Integer
l Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
1_000_000))
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" ada)"
  where
    pad :: ShowS
pad String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
'0' String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s