DSL.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-}

module Test.Integration.Framework.DSL
    ( Context(..)
    , MnemonicLength(..)
    , TxDescription(..)

    -- * Steps
    , request
    , rawRequest
    , unsafeRequest
    , unsafeResponse

    -- * Expectations
    , expectPathEventuallyExist
    , expectSuccess
    , expectError
    , expectErrorMessage
    , expectField
    , expectListField
    , expectListSize
    , expectListSizeSatisfy
    , expectResponseCode
    , expectValidJSON
    , expectCliField
    , expectCliListField
    , expectWalletUTxO
    , between
    , counterexample
    , (.>=)
    , (.<=)
    , (.>)
    , (.<)
    , verify
    , Headers(..)
    , Payload(..)
    , RequestException(..)

    -- * Lens
    , walletId

    -- * Constants
    , minUTxOValue
    , slotLengthValue
    , securityParameterValue
    , epochLengthValue
    , defaultTxTTL

    -- * Create wallets
    , restoreWalletFromPubKey
    , emptyRandomWallet
    , emptyRandomWalletMws
    , emptyRandomWalletWithPasswd
    , emptyIcarusWallet
    , emptyIcarusWalletMws
    , emptyByronWalletWith
    , postWallet
    , postWallet'
    , postByronWallet
    , emptyWallet
    , emptyWalletWith
    , emptyByronWalletFromXPrvWith
    , rewardWallet
    , postSharedWallet
    , deleteSharedWallet
    , getSharedWallet
    , patchSharedWallet
    , getSharedWalletKey
    , postAccountKeyShared

    -- * Wallet helpers
    , listFilteredWallets
    , listFilteredByronWallets

    -- * Helpers
    , (</>)
    , (!!)
    , isValidDerivationPath
    , isValidRandomDerivationPath
    , genMnemonics
    , genMnemonics'
    , getFromResponse
    , getFromResponseList
    , json
    , joinStakePool
    , joinStakePoolUnsigned
    , delegationFee
    , quitStakePool
    , quitStakePoolUnsigned
    , selectCoins
    , selectCoinsWith
    , listAddresses
    , getWallet
    , listTransactions
    , listAllTransactions
    , deleteAllWallets
    , fixtureRawTx
    , fixtureRandomWallet
    , fixtureRandomWalletMws
    , fixtureRandomWalletAddrs
    , fixtureRandomWalletWith
    , fixtureIcarusWallet
    , fixtureIcarusWalletMws
    , fixtureIcarusWalletAddrs
    , fixtureIcarusWalletWith
    , fixtureWallet
    , fixtureWalletWith
    , fixtureWalletWithMnemonics
    , fixtureMultiAssetWallet
    , fixtureMultiAssetRandomWallet
    , fixtureMultiAssetIcarusWallet
    , constFixtureWalletNoWait
    , faucetAmt
    , faucetUtxoAmt
    , proc'
    , postTx
    , pickAnAsset
    , mkTxPayloadMA
    , waitForServer
    , for
    , utcIso8601ToText
    , eventually
    , eventuallyUsingDelay
    , fixturePassphrase
    , fixturePassphraseEncrypted
    , waitForNextEpoch
    , waitForTxImmutability
    , waitAllTxsInLedger
    , toQueryString
    , withMethod
    , withPathParam
    , addField
    , icarusAddresses
    , randomAddresses
    , shelleyAddresses
    , pubKeyFromMnemonics
    , rootPrvKeyFromMnemonics
    , unsafeGetTransactionTime
    , getTxId
    , oneSecond
    , getTTLSlots
    , updateMetadataSource
    , bracketSettings
    , verifyMetadataSource
    , triggerMaintenanceAction
    , verifyMaintenanceAction
    , genXPubs
    , accPubKeyFromMnemonics

    -- * Delegation helpers
    , notDelegating
    , delegating
    , getSlotParams

    -- * CLI
    , commandName
    , command
    , cardanoWalletCLI
    , generateMnemonicsViaCLI
    , createWalletViaCLI
    , createWalletFromPublicKeyViaCLI
    , deleteWalletViaCLI
    , getWalletUtxoStatisticsViaCLI
    , getWalletViaCLI
    , createAddressViaCLI
    , importAddressViaCLI
    , listAddressesViaCLI
    , listStakePoolsViaCLI
    , listWalletsViaCLI
    , updateWalletNameViaCLI
    , updateWalletPassphraseViaCLI
    , postTransactionViaCLI
    , postTransactionFeeViaCLI
    , listTransactionsViaCLI
    , postExternalTransactionViaCLI
    , deleteTransactionViaCLI
    , getTransactionViaCLI

    -- utilites
    , getRetirementEpoch
     -- * Re-exports
    , runResourceT
    , ResourceT
    ) where

import Cardano.Address.Derivation
    ( XPub, xpubFromBytes )
import Cardano.CLI
    ( Port (..) )
import Cardano.Mnemonic
    ( ConsistentEntropy
    , EntropySize
    , MkSomeMnemonic (..)
    , Mnemonic
    , MnemonicWords
    , SomeMnemonic (..)
    , ValidChecksumSize
    , ValidEntropySize
    , entropyToMnemonic
    , genEntropy
    , mnemonicToText
    )
import Cardano.Wallet.Api.Types
    ( AddressAmount
    , ApiAccountKeyShared
    , ApiAddress
    , ApiBlockReference (..)
    , ApiByronWallet
    , ApiCoinSelection
    , ApiEpochInfo
    , ApiFee
    , ApiMaintenanceAction (..)
    , ApiNetworkInformation
    , ApiNetworkParameters (..)
    , ApiSharedWallet (..)
    , ApiStakePool
    , ApiT (..)
    , ApiTransaction
    , ApiTxId (ApiTxId)
    , ApiUtxoStatistics (..)
    , ApiVerificationKeyShared
    , ApiWallet
    , ApiWalletDelegation (..)
    , ApiWalletDelegationNext (..)
    , ApiWalletDelegationStatus (..)
    , DecodeAddress (..)
    , DecodeStakeAddress (..)
    , EncodeAddress (..)
    , Iso8601Time (..)
    , SettingsPutData (..)
    , WalletStyle (..)
    , insertedAt
    )
import Cardano.Wallet.Compat
    ( (^?) )
import Cardano.Wallet.Primitive.AddressDerivation
    ( Depth (..)
    , DerivationIndex (..)
    , DerivationType (..)
    , HardDerivation (..)
    , Index (..)
    , NetworkDiscriminant (..)
    , Passphrase (..)
    , PaymentAddress (..)
    , PersistPublicKey (..)
    , Role (..)
    , WalletKey (..)
    , fromHex
    , hex
    , preparePassphrase
    )
import Cardano.Wallet.Primitive.AddressDerivation.Byron
    ( ByronKey (..) )
import Cardano.Wallet.Primitive.AddressDerivation.Icarus
    ( IcarusKey )
import Cardano.Wallet.Primitive.AddressDerivation.Shelley
    ( ShelleyKey )
import Cardano.Wallet.Primitive.AddressDiscovery.Script
    ( CredentialType (..) )
import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
    ( coinTypeAda )
import Cardano.Wallet.Primitive.SyncProgress
    ( SyncProgress (..) )
import Cardano.Wallet.Primitive.Types
    ( ActiveSlotCoefficient (..)
    , EpochLength (..)
    , EpochNo
    , PoolId (..)
    , PoolMetadataGCStatus (..)
    , PoolMetadataSource
    , Settings
    , SlotLength (..)
    , SlotNo (..)
    , SlottingParameters (..)
    , SortOrder (..)
    , WalletId (..)
    )
import Cardano.Wallet.Primitive.Types.Address
    ( Address (..) )
import Cardano.Wallet.Primitive.Types.Coin
    ( Coin (..) )
import Cardano.Wallet.Primitive.Types.Hash
    ( Hash (..) )
import Cardano.Wallet.Primitive.Types.Tx
    ( TxIn (..), TxOut (..), TxStatus (..) )
import Cardano.Wallet.Primitive.Types.UTxO
    ( HistogramBar (..)
    , UTxO (..)
    , UTxOStatistics (..)
    , computeUtxoStatistics
    , log10
    )
import Control.Arrow
    ( second )
import Control.Monad
    ( forM_, join, replicateM, unless, void, (>=>) )
import Control.Monad.IO.Unlift
    ( MonadIO, MonadUnliftIO (..), liftIO )
import Control.Monad.Trans.Resource
    ( ResourceT, allocate, runResourceT )
import Control.Retry
    ( capDelay, constantDelay, retrying )
import Crypto.Hash
    ( Blake2b_160, Digest, digestFromByteString )
import Data.Aeson
    ( FromJSON, ToJSON, Value, (.=) )
import Data.Aeson.QQ
    ( aesonQQ )
import Data.ByteString
    ( ByteString )
import Data.Either.Extra
    ( eitherToMaybe )
import Data.Foldable
    ( toList )
import Data.Function
    ( (&) )
import Data.Functor.Identity
    ( Identity (..) )
import Data.Generics.Internal.VL.Lens
    ( Lens', lens, set, view, (^.) )
import Data.Generics.Internal.VL.Traversal
    ( Traversal' )
import Data.Generics.Labels
    ()
import Data.Generics.Product.Typed
    ( HasType, typed )
import Data.IORef
    ( newIORef, readIORef, writeIORef )
import Data.List
    ( isPrefixOf )
import Data.List.NonEmpty
    ( NonEmpty )
import Data.Maybe
    ( fromMaybe )
import Data.Proxy
    ( Proxy (..) )
import Data.Quantity
    ( Quantity (..) )
import Data.Set
    ( Set )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..) )
import Data.Time
    ( NominalDiffTime, UTCTime )
import Data.Time.Text
    ( iso8601ExtendedUtc, utcTimeToText )
import Data.Word
    ( Word32, Word64 )
import Language.Haskell.TH.Quote
    ( QuasiQuoter )
import Network.HTTP.Types.Method
    ( Method )
import Numeric.Natural
    ( Natural )
import Prelude
import System.Command
    ( CmdOption (..), CmdResult, Stderr, Stdout (..), command )
import System.Directory
    ( doesPathExist )
import System.Exit
    ( ExitCode (..) )
import System.IO
    ( hClose, hFlush, hPutStr )
import Test.Hspec
    ( Expectation, HasCallStack, expectationFailure )
import Test.Hspec.Expectations.Lifted
    ( shouldBe, shouldContain, shouldNotBe, shouldSatisfy )
import Test.HUnit.Lang
    ( FailureReason (..), HUnitFailure (..) )
import Test.Integration.Faucet
    ( NextWallet, nextTxBuilder, nextWallet, seqMnemonics )
import Test.Integration.Framework.Context
    ( Context (..), TxDescription (..) )
import Test.Integration.Framework.Request
    ( Headers (..)
    , Payload (..)
    , RequestException (..)
    , rawRequest
    , request
    , unsafeRequest
    )
import UnliftIO.Async
    ( async, race, wait )
import UnliftIO.Concurrent
    ( threadDelay )
import UnliftIO.Exception
    ( Exception (..), SomeException (..), catch, throwIO, throwString )
import UnliftIO.Process
    ( CreateProcess (..)
    , StdStream (..)
    , proc
    , waitForProcess
    , withCreateProcess
    )
import Web.HttpApiData
    ( ToHttpApiData (..) )

import qualified Cardano.Wallet.Api.Link as Link
import qualified Cardano.Wallet.Primitive.AddressDerivation.Byron as Byron
import qualified Cardano.Wallet.Primitive.AddressDerivation.Icarus as Icarus
import qualified Cardano.Wallet.Primitive.AddressDerivation.Shelley as Shelley
import qualified Cardano.Wallet.Primitive.Types as W
import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
import qualified Cardano.Wallet.Primitive.Types.TokenQuantity as TokenQuantity
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Write as CBOR
import qualified Crypto.Scrypt as Scrypt
import qualified Data.Aeson as Aeson
import qualified Data.ByteArray as BA
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as TIO
import qualified Network.HTTP.Types.Status as HTTP

--
-- API response expectations
--

-- | Expect an error response, without any further assumptions.
expectError
    :: (HasCallStack, MonadIO m, Show a)
    => (s, Either RequestException a)
    -> m ()
expectError (_, res) = case res of
    Left _  -> return ()
    Right a -> wantedErrorButSuccess a

-- | Expect an error response, without any further assumptions.
expectErrorMessage
    :: (HasCallStack, MonadIO m, Show a)
    => String
    -> (s, Either RequestException a)
    -> m ()
expectErrorMessage want (_, res) = liftIO $ case res of
    Left (DecodeFailure msg)  ->
        BL8.unpack msg `shouldContain` want
    Left (ClientError _)  ->
        expectationFailure "expectErrorMessage: asserting ClientError not supported yet"
    Left (HttpException _) ->
        expectationFailure "expectErrorMessage: asserting HttpException not supported yet"
    Right a -> wantedErrorButSuccess a

-- | Expect a successful response, without any further assumptions.
expectSuccess
    :: (HasCallStack, MonadIO m)
    => (s, Either RequestException a)
    -> m ()
expectSuccess (_, res) = case res of
    Left e  -> wantedSuccessButError e
    Right _ -> return ()

-- | Expect a given response code on the response.
expectResponseCode
    :: (HasCallStack, MonadIO m, Show a)
    => HTTP.Status
    -> (HTTP.Status, a)
    -> m ()
expectResponseCode want (got, a) =
    if got == want
        then pure ()
        else liftIO $ expectationFailure $ unlines
            [ "expected: " <> show want
            , " but got: " <> show got
            , ""
            , "from the following response: " <> show a
            ]

expectField
    :: (HasCallStack, MonadIO m, Show a)
    => Traversal' s a
    -> (a -> Expectation)
    -> (HTTP.Status, Either RequestException s)
    -> m ()
expectField getter predicate (_, res) = case res of
    Left e  -> wantedSuccessButError e
    Right s -> liftIO $ case s ^? getter of
        Nothing -> expectationFailure
            "could not traverse response to test expectations"
        Just a -> predicate a

expectListField
    :: (HasCallStack, MonadIO m, Show a)
    => Int
    -> Traversal' s a
    -> (a -> Expectation)
    -> (HTTP.Status, Either RequestException [s])
    -> m ()
expectListField i getter predicate (c, res) = liftIO $ case res of
    Left e -> wantedSuccessButError e
    Right xs
        | length xs > i ->
            expectField getter predicate (c, Right (xs !! i))
        | otherwise -> expectationFailure $
            "expectListField: trying to access the #" <> show i <>
            " element from a list but there's none! "

-- | Expects data list returned by the API to be of certain length
expectListSize
    :: (HasCallStack, MonadIO m, Foldable xs)
    => Int
    -> (HTTP.Status, Either RequestException (xs a))
    -> m ()
expectListSize l (_, res) = liftIO $ case res of
    Left e   -> wantedSuccessButError e
    Right xs -> length (toList xs) `shouldBe` l

-- | Expects data list returned by the API to be of certain length
expectListSizeSatisfy
    :: (HasCallStack, MonadIO m, Foldable xs)
    => (Int -> Bool)
    -> (HTTP.Status, Either RequestException (xs a))
    -> m ()
expectListSizeSatisfy cond (_, res) = liftIO $ case res of
    Left e   -> wantedSuccessButError e
    Right xs -> length (toList xs) `shouldSatisfy` cond

-- | Expects wallet UTxO statistics from the request to be equal to
-- pre-calculated statistics.
expectWalletUTxO
    :: (HasCallStack, MonadIO m)
    => [Word64]
    -> Either RequestException ApiUtxoStatistics
    -> m ()
expectWalletUTxO coins = \case
    Left e  -> wantedSuccessButError e
    Right stats -> do
        let addr = Address "ARBITRARY"
        let constructUtxoEntry idx c =
                ( TxIn (Hash "ARBITRARY") idx
                , TxOut addr (TokenBundle.fromCoin $ Coin c)
                )
        let utxo = UTxO $ Map.fromList $ zipWith constructUtxoEntry [0..] coins
        let (UTxOStatistics hist stakes bType) =
                computeUtxoStatistics log10 utxo
        let distr = Map.fromList $ map (\(HistogramBar k v)-> (k,v)) hist
        (ApiUtxoStatistics (Quantity (fromIntegral stakes)) (ApiT bType) distr)
            `shouldBe` stats

--
-- CLI output expectations
--

-- | Expects a given string to be a valid JSON output corresponding to some
-- given data-type 'a'. Returns this type if successful.
expectValidJSON
    :: forall m a. (HasCallStack, FromJSON a, MonadIO m)
    => Proxy a
    -> String
    -> m a
expectValidJSON _ str = liftIO $
    case Aeson.eitherDecode @a (BL.fromStrict $ T.encodeUtf8 $ T.pack str) of
        Left e ->
            expectationFailure' $ "expected valid JSON but failed decoding: " <> show e
        Right a -> return a

expectCliListField
    :: (HasCallStack, MonadIO m, Show a)
    => Int
    -> Lens' s a
    -> (a -> Expectation)
    -> [s]
    -> m ()
expectCliListField i getter predicate xs
        | length xs > i = expectCliField getter predicate (xs !! i)
        | otherwise = liftIO . expectationFailure $
            "expectCliListField: trying to access the #" <> show i <>
            " element from a list but there's none! "

expectCliField
    :: (HasCallStack, MonadIO m, Show a)
    => Lens' s a
    -> (a -> Expectation)
    -> s
    -> m ()
expectCliField getter predicate out = do
    let a = (view getter out)
    liftIO $ predicate a

-- | A file is eventually created on the given location
expectPathEventuallyExist :: HasCallStack => FilePath -> IO ()
expectPathEventuallyExist filepath = do
    handle <- async doesPathExistNow
    winner <- race (threadDelay (60 * oneSecond)) (wait handle)
    case winner of
        Left _ -> expectationFailure $
            "waited more than 60s for " <> filepath <> " to be created!"
        Right _ ->
            return ()
  where
    doesPathExistNow = do
        doesPathExist filepath >>= \case
            True ->
                return ()
            False ->
                threadDelay (oneSecond `div` 2) >> doesPathExistNow

-- Lenses
--

walletId :: HasType (ApiT WalletId) s => Lens' s Text
walletId =
    lens _get _set
  where
    _get :: HasType (ApiT WalletId) s => s -> Text
    _get = T.pack . show . getWalletId . getApiT . view typed
    _set :: HasType (ApiT WalletId) s => s -> Text -> s
    _set s v = set typed (ApiT $ WalletId (unsafeCreateDigest v)) s

--
-- Constants
--

-- | Min UTxO parameter for the test cluster.
minUTxOValue :: Natural
minUTxOValue = 1_000_000

-- | Parameter in test cluster shelley genesis.
--
-- This space left blank intentionally.
slotLengthValue :: NominalDiffTime
slotLengthValue =  0.2

-- | Parameter in test cluster shelley genesis.
securityParameterValue :: Word32
securityParameterValue = 5

-- | Parameter in test cluster shelley genesis.
epochLengthValue :: Word32
epochLengthValue = 50

-- | Wallet server's chosen transaction TTL value (in seconds) when none is
-- given.
defaultTxTTL :: NominalDiffTime
defaultTxTTL = 7200

--
-- Helpers
--
isValidDerivationPath
    :: Index 'Hardened 'PurposeK
    -> NonEmpty (ApiT DerivationIndex)
    -> Bool
isValidDerivationPath purpose path =
    ( length path == 5 )
    &&
    ( [ ApiT $ DerivationIndex $ getIndex purpose
      , ApiT $ DerivationIndex $ getIndex coinTypeAda
      , ApiT $ DerivationIndex $ getIndex @'Hardened minBound
      ] `isPrefixOf` NE.toList path
    )

isValidRandomDerivationPath
    :: NonEmpty (ApiT DerivationIndex)
    -> Bool
isValidRandomDerivationPath path =
    ( length path == 2 )
    &&
    ( [ ApiT $ DerivationIndex $ getIndex @'Hardened minBound
      ] `isPrefixOf` NE.toList path
    )


pickAnAsset :: TokenMap.TokenMap -> ((Text, Text), Natural)
pickAnAsset tm = case TokenMap.toFlatList tm of
    (TokenBundle.AssetId pid an, TokenQuantity.TokenQuantity q):_ ->
        ((toText pid, toText an), q)
    _ -> error "pickAnAsset: empty TokenMap"

-- Like mkTxPayload, except that assets are included in the payment.
-- Asset amounts are specified by ((PolicyId Hex, AssetName Hex), amount).
mkTxPayloadMA
    :: forall n m.
        ( DecodeAddress n
        , DecodeStakeAddress n
        , EncodeAddress n
        , MonadUnliftIO m
        )
    => (ApiT Address, Proxy n)
    -> Natural
    -> [((Text, Text), Natural)]
    -> Text
    -> m Payload
mkTxPayloadMA destination coin val passphrase = do
    let assetJson ((pid, name), q) = [aesonQQ|{
                "policy_id": #{pid},
                "asset_name": #{name},
                "quantity": #{q}
            }|]
    return $ Json [aesonQQ|{
            "payments": [{
                "address": #{destination},
                "amount": {
                    "quantity": #{coin},
                    "unit": "lovelace"
                },
                "assets": #{map assetJson val}
            }],
            "passphrase": #{passphrase}
        }|]

postTx
    :: forall n w m.
        ( DecodeAddress n
        , DecodeStakeAddress n
        , EncodeAddress n
        , HasType (ApiT WalletId) w
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> (w, w -> (Method, Text), Text)
    -> ApiWallet
    -> Natural
    -> m (HTTP.Status, Either RequestException (ApiTransaction n))
postTx ctx (wSrc, postTxEndp, pass) wDest amt = do
    addrs <- listAddresses @n ctx wDest
    let destination = (addrs !! 1) ^. #id
    let payload = Json [aesonQQ|{
            "payments": [{
                "address": #{destination},
                "amount": {
                    "quantity": #{amt},
                    "unit": "lovelace"
                }
            }],
            "passphrase": #{pass}
        }|]
    r <- request @(ApiTransaction n) ctx (postTxEndp wSrc) Default payload
    expectResponseCode HTTP.status202 r
    return r

updateMetadataSource :: (MonadIO m, MonadUnliftIO m) => Context -> Text -> m ()
updateMetadataSource ctx t = do
    r <- request @SettingsPutData ctx Link.putSettings Default payload
    expectResponseCode HTTP.status204 r
 where
  payload = Json [aesonQQ| {
       "settings": {
           "pool_metadata_source": #{t}
            }
       } |]

bracketSettings :: (MonadIO m, MonadUnliftIO m) => Context -> m () -> m ()
bracketSettings ctx action = do
    r@(_, response) <- request @(ApiT Settings) ctx Link.getSettings Default Empty
    expectResponseCode HTTP.status200 r
    case response of
        Left e -> wantedSuccessButError e
        Right s -> do
            action
            r' <- request @SettingsPutData ctx Link.putSettings Default
                (Json $ Aeson.toJSON $ SettingsPutData s)
            expectResponseCode HTTP.status204 r'

verifyMetadataSource
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> PoolMetadataSource
    -> m ()
verifyMetadataSource ctx s = do
    r <- request @(ApiT Settings) ctx Link.getSettings Default Empty
    expectResponseCode HTTP.status200 r
    expectField (#getApiT . #poolMetadataSource) (`shouldBe` s) r

triggerMaintenanceAction :: (MonadIO m, MonadUnliftIO m) => Context -> Text -> m ()
triggerMaintenanceAction ctx a = do
    r <- request @ApiMaintenanceAction ctx Link.postPoolMaintenance Default payload
    expectResponseCode HTTP.status204 r
 where
   payload = Json [aesonQQ| { "maintenance_action": #{a} } |]

verifyMaintenanceAction
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> PoolMetadataGCStatus
    -> m ()
verifyMaintenanceAction ctx s = do
    r <- request @ApiMaintenanceAction ctx Link.getPoolMaintenance Default Empty
    expectResponseCode HTTP.status200 r
    expectField (#gcStakePools . #getApiT) (`shouldBe` s) r

data MnemonicLength = M9 | M12 | M15 | M18 | M21 | M24 deriving (Show)

genMnemonics :: MnemonicLength -> IO [Text]
genMnemonics M9 = genMnemonics' @9
genMnemonics M12 = genMnemonics' @12
genMnemonics M15 = genMnemonics' @15
genMnemonics M18 = genMnemonics' @18
genMnemonics M21 = genMnemonics' @21
genMnemonics M24 = genMnemonics' @24

genMnemonics'
   :: forall mw ent csz m.
       ( ConsistentEntropy ent mw csz
       , ValidEntropySize ent
       , ValidChecksumSize ent csz
       , ent ~ EntropySize mw
       , mw ~ MnemonicWords ent
       , MonadIO m
       )
   => m [Text]
genMnemonics' =
    liftIO $ mnemonicToText . entropyToMnemonic @mw <$> genEntropy

accPubKeyFromMnemonics
    :: SomeMnemonic
    -> Maybe SomeMnemonic
    -> Word32
    -> Passphrase "encryption"
    -> Text
accPubKeyFromMnemonics mnemonic1 mnemonic2 ix passphrase =
    T.decodeUtf8 $ serializeXPub $ publicKey $
        deriveAccountPrivateKey passphrase rootXPrv (Index $ 2147483648 + ix)
  where
    rootXPrv = Shelley.generateKeyFromSeed (mnemonic1, mnemonic2) passphrase

genXPubs :: Int -> IO [(XPub,Text)]
genXPubs num =
    replicateM num genXPub
  where
    genXPub = do
        m15txt <- genMnemonics M15
        m12txt <- genMnemonics M12
        let (Right m15) = mkSomeMnemonic @'[ 15 ] m15txt
        let (Right m12) = mkSomeMnemonic @'[ 12 ] m12txt
        let accXPubTxt = accPubKeyFromMnemonics m15 (Just m12) 10 mempty
        let (Just accXPub) = xpubFromText accXPubTxt
        return (accXPub, accXPubTxt)

    xpubFromText :: Text -> Maybe XPub
    xpubFromText = fmap eitherToMaybe fromHexText >=> xpubFromBytes

    fromHexText :: Text -> Either String ByteString
    fromHexText = fromHex . T.encodeUtf8


getTxId :: (ApiTransaction n) -> String
getTxId tx = T.unpack $ toUrlPiece $ ApiTxId (tx ^. #id)

unsafeGetTransactionTime
    :: MonadUnliftIO m
    => [ApiTransaction n]
    -> m UTCTime
unsafeGetTransactionTime txs =
    case fmap time . insertedAt <$> txs of
        (Just t):_ -> pure t
        _ -> throwString "Expected at least one transaction with a time."

waitAllTxsInLedger
    :: forall n m.
        ( DecodeAddress n
        , DecodeStakeAddress n
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ApiWallet
    -> m ()
waitAllTxsInLedger ctx w = eventually "waitAllTxsInLedger: all txs in ledger" $ do
    let ep = Link.listTransactions @'Shelley w
    r <- request @[ApiTransaction n] ctx ep Default Empty
    expectResponseCode HTTP.status200 r
    let txs = getFromResponse id r
    view (#status . #getApiT) <$> txs `shouldSatisfy` all (== InLedger)

waitForNextEpoch
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> m ()
waitForNextEpoch ctx = do
    epoch <- getFromResponse (#nodeTip . #slotId . #epochNumber) <$>
        request @ApiNetworkInformation ctx Link.getNetworkInfo Default Empty
    eventually "waitForNextEpoch: goes to next epoch" $ do
        epoch' <- getFromResponse (#nodeTip . #slotId . #epochNumber) <$>
            request @ApiNetworkInformation ctx Link.getNetworkInfo Default Empty
        unless (getApiT epoch' > getApiT epoch) $ expectationFailure "not yet"

-- Sometimes, we need to wait long-enough for transactions to become immutable.
-- What long enough is rather empirical here, but it must satisfies one important
-- criteria: it must be long-enough to assume that all transactions are no longer
-- in mempools AND, for those who've been inserted, they are now deep enough to
-- not be affected by rollbacks.
--
-- The stability windows in Praos is defined as: `3k/f` slots, thus we can consider
-- transactions immutable after:
--
--    ---> 3k / f * slot_length
--
-- (about 12s with the current parameters for the test cluster).
--
-- Beside, everything runs on the same machine and the information is propagated
-- rather fast; transactions are usually inserted within a few blocks. We'll
-- therefore consider that transactions are typically inserted within 10 blocks
-- yet still consider an extra delay of:
--
--    ---> 10 / f * slot_length
--
-- (about 4s with the current parameters for the test cluster).
waitForTxImmutability :: (MonadIO m) => Context -> m ()
waitForTxImmutability _ctx = liftIO $ do
    -- FIXME: #2226
    --
    -- (_, params) <- unsafeRequest @ApiNetworkParameters ctx Link.getNetworkParams Empty
    --
    -- let picoToMicro = (`div` 1_000_000)
    --
    -- let sl = params ^. (#slotLength . #getQuantity) & fromEnum & picoToMicro & fromIntegral
    -- let k  = params ^. (#epochStability . #getQuantity) & fromIntegral
    -- let f  = params ^. (#activeSlotCoefficient . #getQuantity) / 100
    --
    -- let stabilityDelay   = round (sl * 3 * k / f)
    -- let txInsertionDelay = round (sl * 10 / f)
    let stabilityDelay   = 12 * oneSecond
    let txInsertionDelay = 4 * oneSecond

    threadDelay $ stabilityDelay + txInsertionDelay

between :: (Ord a, Show a) => (a, a) -> a -> Expectation
between (min', max') x
    | min' <= x && x <= max'
        = return ()
    | otherwise
        = expectationFailure $ mconcat
            [ show x
            , " ∉ ["
            , show min'
            , ", "
            , show max'
            ]

(.>) :: (Ord a, Show a) => a -> a -> Expectation
x .> bound
    | x > bound
        = return ()
    | otherwise
        = expectationFailure $ mconcat
            [ show x
            , " does not satisfy (> "
            , show bound
            , ")"
            ]

(.<) :: (Ord a, Show a) => a -> a -> Expectation
x .< bound
    | x < bound
        = return ()
    | otherwise
        = expectationFailure $ mconcat
            [ show x
            , " does not satisfy (< "
            , show bound
            , ")"
            ]


(.>=) :: (Ord a, Show a) => a -> a -> Expectation
a .>= b
    | a >= b
        = return ()
    | otherwise
        = expectationFailure $ mconcat
            [ show a
            , " does not satisfy (>= "
            , show b
            , ")"
            ]

(.<=) :: (Ord a, Show a) => a -> a -> Expectation
a .<= b
    | a <= b
        = return ()
    | otherwise
        = expectationFailure $ mconcat
            [ show a
            , " does not satisfy (<= "
            , show b
            , ")"
            ]

-- | Like @expectationFailure@, but with a @IO a@ return type instead of @IO
-- ()@.
expectationFailure' :: HasCallStack => String -> IO a
expectationFailure' msg = do
    expectationFailure msg
    fail "expectationFailure': impossible"

-- Retry the given action a couple of time until it doesn't throw, or until it
-- has been retried enough.
--
-- It is like 'eventuallyUsingDelay', but with the default delay of 500 ms
-- and timeout of 90s between retries.
-- NOTE
-- This __90s__ is mostly justified by the parameters in the shelley
-- genesis. The longest action we have two wait for are about 2 epochs,
-- which corresponds to 20s with the current parameters. Using something
-- much longer than that isn't really useful (in particular, this doesn't
-- depend on the host machine running the test, because the protocol moves
-- forward at the same speed regardless...)
eventually :: MonadIO m => String -> IO a -> m a
eventually = eventuallyUsingDelay (500 * ms) 90
  where
    ms = 1000

-- Retry the given action a couple of time until it doesn't throw, or until it
-- has been retried enough.
--
-- It sleeps for a specified delay between retries and fails after timeout.
eventuallyUsingDelay
    :: MonadIO m
    => Int -- ^ Delay in microseconds
    -> Int -- ^ Timeout in seconds
    -> String -- ^ Brief description of the IO action
    -> IO a
    -> m a
eventuallyUsingDelay delay timeout desc io = liftIO $ do
    lastErrorRef <- newIORef Nothing
    winner <- race (threadDelay $ timeout * oneSecond) (trial lastErrorRef)
    case winner of
        Left () -> do
            lastError <- readIORef lastErrorRef
            let msg = "Waited longer than " ++ show timeout ++
                      "s to resolve action: " ++ show desc ++ "."
            case fromException @HUnitFailure =<< lastError of
                Just lastError' -> throwIO $ appendFailureReason msg lastError'
                Nothing ->
                    expectationFailure' $ mconcat
                        [ msg
                        , " Error condition: "
                        , show lastError
                        ]
        Right a ->
            return a
  where
    trial lastErrorRef = loop
      where
        loop = io `catch` \(e :: SomeException) -> do
            writeIORef lastErrorRef (Just e)
            threadDelay delay
            loop

utcIso8601ToText :: UTCTime -> Text
utcIso8601ToText = utcTimeToText iso8601ExtendedUtc

-- Functions for creating wallets.
--
-- Wallets are cleaned up automatically at the end of @runResourceT@ in your
-- integration test.
--
-- Do not try to POST a wallet in any other way, since you'd then need to handle
-- the cleanup manually.

-- | Restore HW Wallet from pub key
--
restoreWalletFromPubKey
    :: forall w (style :: WalletStyle) m.
        ( Link.Discriminate style
        , Link.PostWallet style
        , HasType (ApiT WalletId) w
        , HasType (ApiT SyncProgress) w
        , Show w
        , FromJSON w
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> Text
    -> Text
    -> ResourceT m w
restoreWalletFromPubKey ctx pubKey name = snd <$> allocate create destroy
  where
    create = do
        let payloadRestore = Json [aesonQQ| {
                "name": #{name},
                "account_public_key": #{pubKey}
            }|]
        r <- request @w ctx (Link.postWallet @style) Default payloadRestore
        expectResponseCode HTTP.status201 r
        let wid = getFromResponse id r
        eventually "restoreWalletFromPubKey: wallet is 100% synced " $ do
            rg <- request @w ctx (Link.getWallet @style wid) Default Empty
            expectField (typed @(ApiT SyncProgress) . #getApiT) (`shouldBe` Ready) rg
        return wid
    destroy w = void $ request @Aeson.Value ctx
      (Link.deleteWallet @style w) Default Empty

-- | Create an empty wallet
emptyRandomWallet
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m ApiByronWallet
emptyRandomWallet ctx = do
    mnemonic <- liftIO $ mnemonicToText @12 . entropyToMnemonic <$> genEntropy
    emptyByronWalletWith ctx "random"
        ("Random Wallet", mnemonic, fixturePassphrase)

emptyRandomWalletMws
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m (ApiByronWallet, Mnemonic 12)
emptyRandomWalletMws ctx = do
    mnemonic <- liftIO $ entropyToMnemonic <$> genEntropy
    (,mnemonic) <$> emptyByronWalletWith ctx "random"
        ("Random Wallet", mnemonicToText @12 mnemonic, fixturePassphrase)

emptyIcarusWallet
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m ApiByronWallet
emptyIcarusWallet ctx = do
    mnemonic <- liftIO $ mnemonicToText @15 . entropyToMnemonic <$> genEntropy
    emptyByronWalletWith ctx "icarus"
        ("Icarus Wallet", mnemonic, fixturePassphrase)

emptyIcarusWalletMws
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m (ApiByronWallet, Mnemonic 15)
emptyIcarusWalletMws ctx = do
    mnemonic <- liftIO $ entropyToMnemonic <$> genEntropy
    (,mnemonic) <$> emptyByronWalletWith ctx "icarus"
        ("Icarus Wallet",mnemonicToText @15 mnemonic, fixturePassphrase)

emptyRandomWalletWithPasswd
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> Text
    -> ResourceT m ApiByronWallet
emptyRandomWalletWithPasswd ctx rawPwd = do
    let pwd = preparePassphrase W.EncryptWithScrypt
            $ Passphrase
            $ BA.convert
            $ T.encodeUtf8 rawPwd
    seed <- liftIO $ SomeMnemonic @12 . entropyToMnemonic <$> genEntropy
    let key = T.decodeUtf8
            $ hex
            $ Byron.getKey
            $ Byron.generateKeyFromSeed seed pwd
    pwdH <- liftIO $ T.decodeUtf8 . hex <$> encryptPasswordWithScrypt pwd
    emptyByronWalletFromXPrvWith ctx "random" ("Random Wallet", key, pwdH)
  where
    encryptPasswordWithScrypt =
        fmap Scrypt.getEncryptedPass
        . Scrypt.encryptPassIO Scrypt.defaultParams
        . Scrypt.Pass
        . CBOR.toStrictByteString
        . CBOR.encodeBytes
        . BA.convert


postWallet'
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> Headers
    -> Payload
    -> ResourceT m (HTTP.Status, Either RequestException ApiWallet)
postWallet' ctx headers payload = snd <$> allocate create (free . snd)
  where
    create =
        request @ApiWallet ctx (Link.postWallet @'Shelley) headers payload

    free (Right w) = void $ request @Aeson.Value ctx
        (Link.deleteWallet @'Shelley w) Default Empty
    free (Left _) = return ()

postWallet
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> Payload
    -> ResourceT m (HTTP.Status, Either RequestException ApiWallet)
postWallet ctx = postWallet' ctx Default


postByronWallet
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> Payload
    -> ResourceT m (HTTP.Status, Either RequestException ApiByronWallet)
postByronWallet ctx payload = snd <$> allocate create (free . snd)
  where
    create =
        request @ApiByronWallet ctx (Link.postWallet @'Byron) Default payload

    free (Right w) = void $ request @Aeson.Value ctx
        (Link.deleteWallet @'Byron w) Default Empty
    free (Left _) = return ()

emptyByronWalletWith
    :: forall m. (MonadIO m, MonadUnliftIO m)
    => Context
    -> String
    -> (Text, [Text], Text)
    -> ResourceT m ApiByronWallet
emptyByronWalletWith ctx style (name, mnemonic, pass) = do
    let payload = Json [aesonQQ| {
            "name": #{name},
            "mnemonic_sentence": #{mnemonic},
            "passphrase": #{pass},
            "style": #{style}
        }|]
    r <- postByronWallet ctx payload
    expectResponseCode HTTP.status201 r
    return (getFromResponse id r)

emptyByronWalletFromXPrvWith
    :: forall m. (MonadIO m, MonadUnliftIO m)
    => Context
    -> String
    -> (Text, Text, Text)
    -> ResourceT m ApiByronWallet
emptyByronWalletFromXPrvWith ctx style (name, key, passHash) = do
    let payload = Json [aesonQQ| {
            "name": #{name},
            "encrypted_root_private_key": #{key},
            "passphrase_hash": #{passHash},
            "style": #{style}
        }|]
    r <- postByronWallet ctx payload
    expectResponseCode HTTP.status201 r
    return (getFromResponse id r)

-- | Create an empty wallet
emptyWallet
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m ApiWallet
emptyWallet ctx = do
    mnemonic <- liftIO $ (mnemonicToText . entropyToMnemonic) <$> genEntropy @160
    let payload = Json [aesonQQ| {
            "name": "Empty Wallet",
            "mnemonic_sentence": #{mnemonic},
            "passphrase": #{fixturePassphrase}
        }|]
    r <- postWallet ctx payload
    expectResponseCode HTTP.status201 r
    return (getFromResponse id r)

-- | Create an empty wallet
emptyWalletWith
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> (Text, Text, Int)
    -> ResourceT m ApiWallet
emptyWalletWith ctx (name, passphrase, addrPoolGap) = do
    mnemonic <- liftIO $ (mnemonicToText . entropyToMnemonic) <$> genEntropy @160
    let payload = Json [aesonQQ| {
            "name": #{name},
            "mnemonic_sentence": #{mnemonic},
            "passphrase": #{passphrase},
            "address_pool_gap" : #{addrPoolGap}
        }|]
    r <- postWallet ctx payload
    expectResponseCode HTTP.status201 r
    return (getFromResponse id r)

rewardWallet
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m (ApiWallet, Mnemonic 24)
rewardWallet ctx = do
    mw <- liftIO $ nextWallet @"reward" (_faucet ctx)
    let mnemonic = mnemonicToText mw
    let payload = Json [aesonQQ|{
            "name": "MIR Wallet",
            "mnemonic_sentence": #{mnemonic},
            "passphrase": #{fixturePassphrase}
        }|]
    r <- postWallet ctx payload
    expectResponseCode HTTP.status201 r
    let w = getFromResponse id r
    waitForNextEpoch ctx
    eventually "MIR wallet: wallet is 100% synced " $ do
        rg <- request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty
        verify rg
            [ expectField (#balance . #available . #getQuantity) (.> 0)
            , expectField (#balance . #reward . #getQuantity) (.> 0)
            ]
        pure (getFromResponse id rg, mw)

fixtureMultiAssetWallet
    :: MonadIO m
    => Context
    -> ResourceT m ApiWallet
fixtureMultiAssetWallet = fmap fst . fixtureWalletWithMnemonics (Proxy @"ma")

fixtureMultiAssetRandomWallet
    :: forall n m.
        ( DecodeAddress n
        , DecodeStakeAddress n
        , EncodeAddress n
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ResourceT m ApiByronWallet
fixtureMultiAssetRandomWallet ctx = do
    wMA <- fixtureMultiAssetWallet ctx
    wB <- fixtureRandomWallet ctx

    -- create Byron address
    let p = Json [aesonQQ| { "passphrase": #{fixturePassphrase} }|]
    r <- request @(ApiAddress n) ctx (Link.postRandomAddress wB) Default p
    expectSuccess r

    -- pick out assets to send
    let assetsSrc = wMA ^. #assets . #total . #getApiT
    assetsSrc `shouldNotBe` mempty
    let val = minUTxOValue <$ pickAnAsset assetsSrc

    rL <- request @[ApiAddress n] ctx (Link.listAddresses @'Byron wB) Default Empty
    let addrs = getFromResponse id rL
    let destination = (addrs !! 1) ^. #id
    payload <- mkTxPayloadMA @n destination 0 [val] fixturePassphrase

    -- send assets to Byron wallet
    rtx <- request @(ApiTransaction n) ctx
        (Link.createTransaction @'Shelley wMA) Default payload
    expectResponseCode HTTP.status202 rtx

    eventually "Byron wallet has assets" $ do
        rb <- request @ApiByronWallet ctx
            (Link.getWallet @'Byron wB) Default Empty
        verify rb
            [ expectField (#assets . #available . #getApiT)
                (`shouldNotBe` TokenMap.empty)
            , expectField (#assets . #total . #getApiT)
                (`shouldNotBe` TokenMap.empty)
            , expectField (#state . #getApiT) (`shouldBe` Ready)
            ]
        return (getFromResponse id rb)

fixtureMultiAssetIcarusWallet
    :: forall n m.
        ( DecodeAddress n
        , DecodeStakeAddress n
        , EncodeAddress n
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ResourceT m ApiByronWallet
fixtureMultiAssetIcarusWallet ctx = do
    wMA <- fixtureMultiAssetWallet ctx
    wB <- fixtureIcarusWallet ctx

    -- pick out assets to send
    let assetsSrc = wMA ^. #assets . #total . #getApiT
    assetsSrc `shouldNotBe` mempty
    let val = minUTxOValue <$ pickAnAsset assetsSrc

    rL <- request @[ApiAddress n] ctx (Link.listAddresses @'Byron wB) Default Empty
    let addrs = getFromResponse id rL
    let destination = (addrs !! 1) ^. #id
    payload <- mkTxPayloadMA @n destination 0 [val] fixturePassphrase

    -- send assets to Icarus wallet
    rtx <- request @(ApiTransaction n) ctx
        (Link.createTransaction @'Shelley wMA) Default payload
    expectResponseCode HTTP.status202 rtx

    eventually "Icarus wallet has assets" $ do
        rb <- request @ApiByronWallet ctx
            (Link.getWallet @'Byron wB) Default Empty
        verify rb
            [ expectField (#assets . #available . #getApiT)
                (`shouldNotBe` TokenMap.empty)
            , expectField (#assets . #total . #getApiT)
                (`shouldNotBe` TokenMap.empty)
            ]
        return (getFromResponse id rb)

postSharedWallet
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> Headers
    -> Payload
    -> ResourceT m (HTTP.Status, Either RequestException ApiSharedWallet)
postSharedWallet ctx headers payload = snd <$> allocate create (free . snd)
  where
    create =
        request @ApiSharedWallet ctx Link.postSharedWallet headers payload

    free (Right (ApiSharedWallet (Left w))) = void $ request @Aeson.Value ctx
        (Link.deleteSharedWallet w) Default Empty
    free (Right (ApiSharedWallet (Right w))) = void $ request @Aeson.Value ctx
        (Link.deleteSharedWallet w) Default Empty
    free (Left _) = return ()

deleteSharedWallet
    :: forall m.
        ( MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ApiSharedWallet
    -> m (HTTP.Status, Either RequestException Value)
deleteSharedWallet ctx (ApiSharedWallet (Left w)) =
    request @Aeson.Value ctx
        (Link.deleteSharedWallet w) Default Empty
deleteSharedWallet ctx (ApiSharedWallet (Right w)) =
    request @Aeson.Value ctx
        (Link.deleteSharedWallet w) Default Empty

getSharedWallet
    :: forall m.
        ( MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ApiSharedWallet
    -> m (HTTP.Status, Either RequestException ApiSharedWallet)
getSharedWallet ctx (ApiSharedWallet (Left w)) = do
    let link = Link.getSharedWallet w
    request @ApiSharedWallet ctx link Default Empty
getSharedWallet ctx (ApiSharedWallet (Right w)) = do
    let link = Link.getSharedWallet w
    request @ApiSharedWallet ctx link Default Empty

getSharedWalletKey
    :: forall m.
        ( MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ApiSharedWallet
    -> Role
    -> DerivationIndex
    -> m (HTTP.Status, Either RequestException ApiVerificationKeyShared)
getSharedWalletKey ctx (ApiSharedWallet (Left w)) role ix = do
    let link = Link.getSharedWalletKey w role ix
    request @ApiVerificationKeyShared ctx link Default Empty
getSharedWalletKey ctx (ApiSharedWallet (Right w)) role ix = do
    let link = Link.getSharedWalletKey w role ix
    request @ApiVerificationKeyShared ctx link Default Empty

postAccountKeyShared
    :: forall m.
        ( MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ApiSharedWallet
    -> DerivationIndex
    -> Headers
    -> Payload
    -> m (HTTP.Status, Either RequestException ApiAccountKeyShared)
postAccountKeyShared ctx (ApiSharedWallet (Left w)) ix headers payload = do
    let link = Link.postAccountKeyShared w ix
    request @ApiAccountKeyShared ctx link headers payload
postAccountKeyShared ctx (ApiSharedWallet (Right w)) ix headers payload = do
    let link = Link.postAccountKeyShared w ix
    request @ApiAccountKeyShared ctx link headers payload

patchEndpointEnding :: CredentialType -> Text
patchEndpointEnding = \case
    Payment -> "payment-script-template"
    Delegation -> "delegation-script-template"

patchSharedWallet
    :: forall m.
        ( MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ApiSharedWallet
    -> CredentialType
    -> Payload
    -> m (HTTP.Status, Either RequestException ApiSharedWallet)
patchSharedWallet ctx (ApiSharedWallet (Left w)) cred payload  = do
    let endpoint = "v2/shared-wallets" </> w ^. walletId </> patchEndpointEnding cred
    request @ApiSharedWallet ctx ("PATCH", endpoint) Default payload
patchSharedWallet ctx (ApiSharedWallet (Right w)) cred payload  = do
    let endpoint = "v2/shared-wallets" </> w ^. walletId </> patchEndpointEnding cred
    request @ApiSharedWallet ctx ("PATCH", endpoint) Default payload

fixtureRawTx
    :: Context
    -> (Address, Natural)
    -> IO BL.ByteString
fixtureRawTx ctx (addr, amt) =
    nextTxBuilder (_faucet ctx) >>= \build ->
        BL.fromStrict <$> build (addr, Coin $ fromIntegral amt)

-- | Default passphrase used for fixture wallets
fixturePassphrase :: Text
fixturePassphrase =
    "cardano-wallet"

-- | fixturePassphrase encrypted by Scrypt function
fixturePassphraseEncrypted :: Text
fixturePassphraseEncrypted =
    "31347c387c317c2b6a6f747446495a6a566d586f43374c6c54425a576c\
    \597a425834515177666475467578436b4d485569733d7c78324d646738\
    \49554a3232507235676531393575445a76583646552b7757395a6a6a2f\
    \51303054356c654751794279732f7662753367526d726c316c657a7150\
    \43676d364e6758476d4d2f4b6438343265304b4945773d3d"


-- | Restore a faucet and wait until funds are available.
--
-- Note: @ResourceT@ is used to allow automatic garbage collection of unused
-- wallets through small blocks of @runResourceT@ (e.g. once per test). It
-- doesn't return @ReleaseKey@ since manual releasing is not needed.
fixtureWallet
    :: MonadIO m
    => Context
    -> ResourceT m ApiWallet
fixtureWallet = fmap fst . fixtureWalletWithMnemonics (Proxy @"shelley")

fixtureWalletWithMnemonics
    :: forall m scheme. (MonadIO m, NextWallet scheme)
    => Proxy scheme
    -> Context
    -> ResourceT m (ApiWallet, [Text])
fixtureWalletWithMnemonics _ ctx = snd <$> allocate create (free . fst)
  where
    create = do
        mnemonics <- mnemonicToText <$> nextWallet @scheme (_faucet ctx)
        let payload = Json [aesonQQ| {
                "name": "Faucet Wallet",
                "mnemonic_sentence": #{mnemonics},
                "passphrase": #{fixturePassphrase}
                } |]
        r <- request @ApiWallet ctx
            (Link.postWallet @'Shelley) Default payload
        expectResponseCode HTTP.status201 r
        let w = getFromResponse id r
        race (threadDelay sixtySeconds) (checkBalance w) >>= \case
            Left _ -> expectationFailure'
                "fixtureWallet: waited too long for initial transaction"
            Right a -> return (a, mnemonics)

    free w = void $ request @Aeson.Value ctx
        (Link.deleteWallet @'Shelley w) Default Empty
    sixtySeconds = 60*oneSecond
    checkBalance w = do
        r <- request @ApiWallet ctx
            (Link.getWallet @'Shelley w) Default Empty
        if getFromResponse (#balance . #available) r > Quantity 0
            then return (getFromResponse id r)
            else threadDelay oneSecond *> checkBalance w

-- | Restore a faucet Random wallet and wait until funds are available.
fixtureRandomWalletMws
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m (ApiByronWallet, Mnemonic 12)
fixtureRandomWalletMws ctx = do
    mnemonics <- liftIO $ nextWallet @"random" (_faucet ctx)
    (,mnemonics) <$> fixtureLegacyWallet ctx "random" (mnemonicToText mnemonics)

fixtureRandomWallet
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m ApiByronWallet
fixtureRandomWallet = fmap fst . fixtureRandomWalletMws

fixtureRandomWalletAddrs
    :: forall (n :: NetworkDiscriminant) m.
        ( PaymentAddress n ByronKey
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ResourceT m (ApiByronWallet, [Address])
fixtureRandomWalletAddrs =
    fmap (second (randomAddresses @n)) . fixtureRandomWalletMws

-- | Restore a wallet with the given UTxO distribution. Note that there's a
-- limitation to what can be done here. We only have 10 UTxO available in each
-- faucet and they "only" have 'faucetUtxoAmt = 100_000 Ada' in each.
--
-- This function makes no attempt at ensuring the request is valid, so be
-- careful.
--
-- TODO: Remove duplication between Shelley / Byron fixtures.
fixtureRandomWalletWith
    :: forall (n :: NetworkDiscriminant) m.
        ( EncodeAddress n
        , DecodeAddress n
        , DecodeStakeAddress n
        , PaymentAddress n ByronKey
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> [Natural]
    -> ResourceT m ApiByronWallet
fixtureRandomWalletWith ctx coins0 = do
    src  <- fixtureRandomWallet ctx
    mws  <- liftIO $ entropyToMnemonic <$> genEntropy
    dest <- emptyByronWalletWith ctx "random"
        ("Random Wallet", mnemonicToText @12 mws, fixturePassphrase)
    let addrs = randomAddresses @n mws
    liftIO $ mapM_ (moveByronCoins @n ctx src (dest, addrs)) (groupsOf 10 coins0)
    void $ request @() ctx
        (Link.deleteWallet @'Byron src) Default Empty
    r <- request @ApiByronWallet ctx
        (Link.getWallet @'Byron dest) Default Empty
    expectResponseCode HTTP.status200 r
    pure (getFromResponse id r)

-- | Restore a faucet Icarus wallet and wait until funds are available.
fixtureIcarusWalletMws
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m (ApiByronWallet, Mnemonic 15)
fixtureIcarusWalletMws ctx = do
    mnemonics <- liftIO $ nextWallet @"icarus" (_faucet ctx)
    (,mnemonics) <$> fixtureLegacyWallet ctx "icarus" (mnemonicToText mnemonics)

fixtureIcarusWallet
    :: (MonadIO m, MonadUnliftIO m)
    => Context
    -> ResourceT m ApiByronWallet
fixtureIcarusWallet = fmap fst . fixtureIcarusWalletMws

fixtureIcarusWalletAddrs
    :: forall (n :: NetworkDiscriminant) m.
        ( PaymentAddress n IcarusKey
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ResourceT m (ApiByronWallet, [Address])
fixtureIcarusWalletAddrs =
    fmap (second (icarusAddresses @n)) . fixtureIcarusWalletMws

-- | Restore a wallet with the given UTxO distribution. Note that there's a
-- limitation to what can be done here. We only have 10 UTxO available in each
-- faucet and they "only" have 'faucetUtxoAmt = 100_000 Ada' in each.
--
-- This function makes no attempt at ensuring the request is valid, so be
-- careful.
--
-- TODO: Remove duplication between Shelley / Byron fixtures.
fixtureIcarusWalletWith
    :: forall (n :: NetworkDiscriminant) m.
        ( EncodeAddress n
        , DecodeAddress n
        , DecodeStakeAddress n
        , PaymentAddress n IcarusKey
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> [Natural]
    -> ResourceT m ApiByronWallet
fixtureIcarusWalletWith ctx coins0 = do
    src  <- fixtureIcarusWallet ctx
    mws  <- liftIO $ entropyToMnemonic <$> genEntropy
    dest <- emptyByronWalletWith ctx "icarus"
        ("Icarus Wallet", mnemonicToText @15 mws, fixturePassphrase)
    let addrs = icarusAddresses @n mws
    liftIO $ mapM_ (moveByronCoins @n ctx src (dest, addrs)) (groupsOf 10 coins0)
    void $ request @() ctx
        (Link.deleteWallet @'Byron src) Default Empty
    r <- request @ApiByronWallet ctx
        (Link.getWallet @'Byron dest) Default Empty
    expectResponseCode HTTP.status200 r
    pure (getFromResponse id r)


-- | Restore a legacy wallet (Byron or Icarus)
fixtureLegacyWallet
    :: forall m. (MonadIO m, MonadUnliftIO m)
    => Context
    -> String
    -> [Text]
    -> ResourceT m ApiByronWallet
fixtureLegacyWallet ctx style mnemonics = snd <$> allocate create free
  where
    create = do
        let payload = Json [aesonQQ| {
                "name": "Faucet Byron Wallet",
                "mnemonic_sentence": #{mnemonics},
                "passphrase": #{fixturePassphrase},
                "style": #{style}
                } |]
        r <- request @ApiByronWallet ctx (Link.postWallet @'Byron) Default payload
        expectResponseCode HTTP.status201 r
        let w = getFromResponse id r
        liftIO $ race (threadDelay sixtySeconds) (checkBalance w) >>= \case
            Left _ ->
                expectationFailure'
                    "fixtureByronWallet: waited too long for initial transaction"
            Right a ->
                return a
    free w = do
        void $ request @() ctx
            (Link.deleteWallet @'Byron w) Default Empty

    sixtySeconds = 60*oneSecond
    checkBalance w = do
        r <- request @ApiByronWallet ctx
            (Link.getWallet @'Byron w) Default Empty
        if getFromResponse (#balance . #available) r > Quantity 0
            then return (getFromResponse id r)
            else threadDelay oneSecond *> checkBalance w

-- | Restore a wallet with the given UTxO distribution. Note that there's a
-- limitation to what can be done here. We only have 10 UTxO available in each
-- faucet and they "only" have 'faucetUtxoAmt = 100_000 Ada' in each.
--
-- This function makes no attempt at ensuring the request is valid, so be
-- careful.
fixtureWalletWith
    :: forall n m.
        ( EncodeAddress n
        , DecodeAddress n
        , DecodeStakeAddress n
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> [Natural]
    -> ResourceT m ApiWallet
fixtureWalletWith ctx coins0 = do
    src <- fixtureWallet ctx
    dest <- emptyWallet ctx
    liftIO $ mapM_ (moveCoins src dest) (groupsOf 10 coins0)
    liftIO $ void $ request @() ctx
        (Link.deleteWallet @'Shelley src) Default Empty

    waitForTxImmutability ctx

    r <- request @ApiWallet ctx
        (Link.getWallet @'Shelley dest) Default Empty
    expectResponseCode HTTP.status200 r
    pure (getFromResponse id r)
  where
    -- | Move coins from a wallet to another
    moveCoins
        :: ApiWallet
            -- ^ Source Wallet
        -> ApiWallet
            -- ^ Destination wallet
        -> [Natural]
            -- ^ Coins to move
        -> IO ()
    moveCoins src dest coins = do
        balance <- getFromResponse (#balance . #available . #getQuantity)
            <$> request @ApiWallet ctx
                    (Link.getWallet @'Shelley dest) Default Empty
        addrs <- fmap (view #id) . getFromResponse id
            <$> request @[ApiAddress n] ctx
                    (Link.listAddresses @'Shelley dest) Default Empty
        let payments = for (zip coins addrs) $ \(amt, addr) -> [aesonQQ|{
                "address": #{addr},
                "amount": {
                    "quantity": #{amt},
                    "unit": "lovelace"
                }
            }|]
        let payload = Json [aesonQQ|{
                "payments": #{payments :: [Value]},
                "passphrase": #{fixturePassphrase}
            }|]
        request @(ApiTransaction n) ctx
            (Link.createTransaction @'Shelley src) Default payload
            >>= expectResponseCode HTTP.status202
        eventually "balance available = balance total" $ do
            rb <- request @ApiWallet ctx
                (Link.getWallet @'Shelley dest) Default Empty
            expectField
                (#balance . #available)
                (`shouldBe` Quantity (sum (balance:coins))) rb
            ra <- request @ApiWallet ctx
                (Link.getWallet @'Shelley src) Default Empty

            getFromResponse (#balance . #available) ra
                `shouldBe`
                    getFromResponse (#balance . #total) ra

-- | Create a fixture from the same mnemonic every time.
-- Don't wait for it to restore before returning.
constFixtureWalletNoWait :: MonadIO m => Context -> ResourceT m ApiWallet
constFixtureWalletNoWait ctx = snd <$> allocate create free
  where
    payload = Json [aesonQQ| {
            "name": "Fixed empty spec wallet",
            "mnemonic_sentence": #{mnemonicToText (head seqMnemonics)},
            "passphrase": #{fixturePassphrase}
        } |]
    create = do
        r <- request @ApiWallet ctx (Link.postWallet @'Shelley) Default payload
        expectResponseCode HTTP.status201 r
        pure $ getFromResponse id r
    free w = void $ request @Aeson.Value ctx
        (Link.deleteWallet @'Shelley w) Default Empty

-- | Move coins from a wallet to another
moveByronCoins
    :: forall (n :: NetworkDiscriminant).
        ( EncodeAddress n
        , DecodeAddress n
        , DecodeStakeAddress n
        )
    => Context
        -- ^ Api context
    -> ApiByronWallet
        -- ^ Source Wallet
    -> (ApiByronWallet, [Address])
        -- ^ Destination wallet
    -> [Natural]
        -- ^ Coins to move
    -> IO ()
moveByronCoins ctx src (dest, addrs) coins = do
    balance <- getFromResponse (#balance . #available . #getQuantity)
        <$> request @ApiByronWallet ctx (Link.getWallet @'Byron dest) Default Empty
    let payments = for (zip coins addrs) $ \(amt, addr) ->
            let addrStr = encodeAddress @n addr
            in [aesonQQ|{
                "address": #{addrStr},
                "amount": {
                    "quantity": #{amt},
                    "unit": "lovelace"
                }
            }|]
    let payload = Json [aesonQQ|{
            "payments": #{payments :: [Value]},
            "passphrase": #{fixturePassphrase}
        }|]
    request @(ApiTransaction n) ctx
        (Link.createTransaction @'Byron src) Default payload
        >>= expectResponseCode HTTP.status202
    eventually "balance available = balance total" $ do
        rb <- request @ApiByronWallet ctx
            (Link.getWallet @'Byron dest) Default Empty
        expectField (#balance . #available)
            (`shouldBe` Quantity (sum (balance:coins))) rb
        ra <- request @ApiByronWallet ctx
            (Link.getWallet @'Byron src) Default Empty
        getFromResponse (#balance . #available) ra
            `shouldBe` getFromResponse (#balance . #total) ra


-- | Total amount on each faucet wallet
faucetAmt :: Natural
faucetAmt = 10 * faucetUtxoAmt

-- | Each faucet wallet is composed of 10 times a single faucet UTxO of 100_000
-- Ada.
faucetUtxoAmt :: Natural
faucetUtxoAmt = ada 100_000
  where
    ada = (*) (1_000_000)

getFromResponse
    :: Lens' s a
    -> (HTTP.Status, Either RequestException s)
    -> a
getFromResponse getter (_, res) = case res of
    Left _  -> error "getFromResponse failed to get item"
    Right s -> view getter s

getFromResponseList
    :: Int
    -> Lens' s a
    -> (HTTP.Status, Either RequestException [s])
    -> a
getFromResponseList i getter (_, res) = case res of
    Left _ -> error "getFromResponseList failed to get item"
    Right xs
        | length xs > i -> view getter (xs !! i)
        | otherwise -> error $
            "getFromResponseList: trying to access the #" <> show i <>
            " element from a list but there's none! "

json :: QuasiQuoter
json = aesonQQ

joinStakePool
    :: forall n w m.
        ( HasType (ApiT WalletId) w
        , DecodeAddress n
        , DecodeStakeAddress n
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> ApiT PoolId
    -> (w, Text)
    -> m (HTTP.Status, Either RequestException (ApiTransaction n))
joinStakePool ctx p (w, pass) = do
    let payload = Json [aesonQQ| {
            "passphrase": #{pass}
            } |]
    request @(ApiTransaction n) ctx
        (Link.joinStakePool (Identity p) w) Default payload

joinStakePoolUnsigned
    :: forall n style w.
        ( HasType (ApiT WalletId) w
        , DecodeAddress n
        , EncodeAddress n
        , DecodeStakeAddress n
        , Link.Discriminate style
        )
    => Context
    -> w
    -> ApiT PoolId
    -> IO (HTTP.Status, Either RequestException (ApiCoinSelection n))
joinStakePoolUnsigned ctx w pid = do
    let payload = Json [aesonQQ| {
            "delegation_action": { "action": "join", "pool": #{pid} }
        } |]
    request @(ApiCoinSelection n) ctx
        (Link.selectCoins @style w) Default payload

quitStakePool
    :: forall n w m.
        ( HasType (ApiT WalletId) w
        , DecodeAddress n
        , DecodeStakeAddress n
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> (w, Text)
    -> m (HTTP.Status, Either RequestException (ApiTransaction n))
quitStakePool ctx (w, pass) = do
    let payload = Json [aesonQQ| {
            "passphrase": #{pass}
            } |]
    request @(ApiTransaction n) ctx
        (Link.quitStakePool w) Default payload

quitStakePoolUnsigned
    :: forall n style w m.
        ( HasType (ApiT WalletId) w
        , DecodeAddress n
        , DecodeStakeAddress n
        , EncodeAddress n
        , MonadIO m
        , Link.Discriminate style
        )
    => Context
    -> w
    -> m (HTTP.Status, Either RequestException (ApiCoinSelection n))
quitStakePoolUnsigned ctx w = liftIO $ do
    let payload = Json [aesonQQ| {
            "delegation_action": { "action": "quit" }
        } |]
    request @(ApiCoinSelection n) ctx
        (Link.selectCoins @style w) Default payload

selectCoins
    :: forall n style w m.
        ( HasType (ApiT WalletId) w
        , DecodeAddress n
        , DecodeStakeAddress n
        , EncodeAddress n
        , Link.Discriminate style
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> w
    -> NonEmpty (AddressAmount (ApiT Address, Proxy n))
    -> m (HTTP.Status, Either RequestException (ApiCoinSelection n))
selectCoins ctx w payments =
    selectCoinsWith @n @style @w ctx w payments id

selectCoinsWith
    :: forall n style w m.
        ( HasType (ApiT WalletId) w
        , DecodeAddress n
        , DecodeStakeAddress n
        , EncodeAddress n
        , Link.Discriminate style
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> w
    -> NonEmpty (AddressAmount (ApiT Address, Proxy n))
    -> (Payload -> Payload)
    -> m (HTTP.Status, Either RequestException (ApiCoinSelection n))
selectCoinsWith ctx w payments transform = do
    let payload = Json [aesonQQ| {
            "payments": #{payments}
        } |]
    request @(ApiCoinSelection n) ctx
        (Link.selectCoins @style w) Default (transform payload)

delegationFee
    :: forall w m. (HasType (ApiT WalletId) w, MonadIO m, MonadUnliftIO m)
    => Context
    -> w
    -> m (HTTP.Status, Either RequestException ApiFee)
delegationFee ctx w = do
    request @ApiFee ctx (Link.getDelegationFee w) Default Empty

-- | Generate an infinite list of addresses for random wallets.
--
-- To be typically used as:
--
-- >>> take 1 (randomAddresses @n)
-- [addr]
randomAddresses
    :: forall (n :: NetworkDiscriminant). (PaymentAddress n ByronKey)
    => Mnemonic 12
    -> [Address]
randomAddresses mw =
    let
        (seed, pwd) =
            (SomeMnemonic mw, mempty)
        rootXPrv =
            Byron.generateKeyFromSeed seed pwd
        accXPrv =
            Byron.deriveAccountPrivateKey pwd rootXPrv minBound
        addrXPrv =
            Byron.deriveAddressPrivateKey pwd accXPrv
    in
        [ paymentAddress @n (publicKey $ addrXPrv ix)
        | ix <- [minBound..maxBound]
        ]

-- | Generate an infinite list of addresses for icarus wallets
--
-- To be typically used as:
--
-- >>> take 1 (icarusAddresses @n)
-- [addr]
icarusAddresses
    :: forall (n :: NetworkDiscriminant). (PaymentAddress n IcarusKey)
    => Mnemonic 15
    -> [Address]
icarusAddresses mw =
    let
        (seed, pwd) =
            (SomeMnemonic mw, mempty)
        rootXPrv =
            Icarus.generateKeyFromSeed seed pwd
        accXPrv =
            deriveAccountPrivateKey pwd rootXPrv minBound
        addrXPrv =
            deriveAddressPrivateKey pwd accXPrv UtxoExternal
    in
        [ paymentAddress @n (publicKey $ addrXPrv ix)
        | ix <- [minBound..maxBound]
        ]

-- | Generate an infinite list of addresses for shelley wallets.
--
-- To be typically used as:
--
-- >>> take 1 (shelleyAddresses @n)
-- [addr]
shelleyAddresses
    :: forall (n :: NetworkDiscriminant). (PaymentAddress n ShelleyKey)
    => Mnemonic 15
    -> [Address]
shelleyAddresses mw =
    let
        (seed, pwd) =
            (SomeMnemonic mw, mempty)
        rootXPrv =
            Shelley.generateKeyFromSeed (seed, Nothing) pwd
        accXPrv =
            deriveAccountPrivateKey pwd rootXPrv minBound
        addrXPrv =
            deriveAddressPrivateKey pwd accXPrv UtxoExternal
    in
        [ paymentAddress @n (publicKey $ addrXPrv ix)
        | ix <- [minBound..maxBound]
        ]

listAddresses
    :: forall n m. (MonadIO m, MonadUnliftIO m, DecodeAddress n)
    => Context
    -> ApiWallet
    -> m [ApiAddress n]
listAddresses ctx w = do
    let link = Link.listAddresses @'Shelley w
    r <- request @[ApiAddress n] ctx link Default Empty
    expectResponseCode HTTP.status200 r
    return (getFromResponse id r)

getWallet
    :: forall w m.
        ( MonadIO m
        , MonadUnliftIO m
        , HasType (ApiT WalletId) w
        )
    => Context
    -> w
    -> m ApiWallet
getWallet ctx w = do
    let link = Link.getWallet @'Shelley w
    r <- request @ApiWallet ctx link Default Empty
    expectResponseCode HTTP.status200 r
    return (getFromResponse id r)

listAllTransactions
    :: forall n w m.
        ( DecodeAddress n
        , DecodeStakeAddress n
        , HasType (ApiT WalletId) w
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> w
    -> m [ApiTransaction n]
listAllTransactions ctx w =
    listTransactions ctx w Nothing Nothing (Just Descending)

listTransactions
    :: forall n w m.
        ( DecodeAddress n
        , DecodeStakeAddress n
        , HasType (ApiT WalletId) w
        , MonadIO m
        , MonadUnliftIO m
        )
    => Context
    -> w
    -> Maybe UTCTime
    -> Maybe UTCTime
    -> Maybe SortOrder
    -> m [ApiTransaction n]
listTransactions ctx w mStart mEnd mOrder = do
    r <- request @[ApiTransaction n] ctx path Default Empty
    expectResponseCode HTTP.status200 r
    let txs = getFromResponse id r
    return txs
  where
    path = Link.listTransactions' @'Shelley w
        Nothing
        (Iso8601Time <$> mStart)
        (Iso8601Time <$> mEnd)
        mOrder

-- | Delete all wallets
deleteAllWallets :: Context -> IO ()
deleteAllWallets ctx = do
    resp <- request @[ApiWallet] ctx ("GET", "v2/wallets") Default Empty
    forM_ (wallets (snd resp)) $ \wal -> do
        let endpoint = "v2/wallets" </> wal ^. walletId
        d <- request @Value ctx ("DELETE", endpoint) None Empty
        expectResponseCode HTTP.status204 d
    respByron <-
        request @[ApiByronWallet] ctx ("GET", "v2/byron-wallets") Default Empty
    forM_ (wallets (snd respByron)) $ \wal -> do
        let endpoint = "v2/byron-wallets" </> wal ^. walletId
        d <- request @Value ctx ("DELETE", endpoint) None Empty
        expectResponseCode HTTP.status204 d
 where
     wallets :: forall w . Either RequestException [w] -> [w]
     wallets c = case c of
         Left e -> error $ "deleteAllWallets: Cannot return wallets: " <> show e
         Right s -> s

-- | Calls 'GET /wallets' and filters the response. This allows tests to be
-- written for a parallel setting.
listFilteredWallets
    :: (MonadIO m, MonadUnliftIO m)
    => Set Text -- ^ Set of walletIds to include
    -> Context
    -> m (HTTP.Status, Either RequestException [ApiWallet])
listFilteredWallets include ctx = do
    (s, mwallets) <- request @[ApiWallet] ctx
        (Link.listWallets @'Shelley) Default Empty
    return (s, filter (\w -> (w ^. walletId) `Set.member` include) <$> mwallets)

-- | Calls 'GET /byron-wallets' and filters the response. This allows tests to
-- be written for a parallel setting.
listFilteredByronWallets
    :: (MonadIO m, MonadUnliftIO m)
    => Set Text -- ^ Set of walletIds to include
    -> Context
    -> m (HTTP.Status, Either RequestException [ApiByronWallet])
listFilteredByronWallets include ctx = do
    (s, mwallets) <- request @[ApiByronWallet] ctx
        (Link.listWallets @'Byron) Default Empty
    return (s, filter (\w -> (w ^. walletId) `Set.member` include) <$> mwallets)

-- | Wait for a booting wallet server to start. Wait up to 30s or fail.
waitForServer
    :: forall ctx m. (HasType (Port "wallet") ctx, MonadIO m)
    => ctx
    -> m ()
waitForServer ctx = liftIO $ void $ retrying
    (capDelay (30*oneSecond) $ constantDelay oneSecond)
    -- NOTE
    -- We still bind the output and error streams to some custom handles because
    -- if we don't, the library defaults to `stdout` and `stderr` which can get
    -- quite noisy.
    (\_ (e, _ :: Stderr, _ :: Stdout) -> pure $ e == ExitFailure 1)
    (const $ listWalletsViaCLI ctx)

unsafeCreateDigest :: Text -> Digest Blake2b_160
unsafeCreateDigest s = fromMaybe
    (error $ "unsafeCreateDigest failed to create digest from: " <> show s)
    (digestFromByteString $ B8.pack $ T.unpack s)

wantedSuccessButError
    :: (MonadIO m, Show e)
    => e
    -> m ()
wantedSuccessButError = liftIO
    . expectationFailure
    . ("expected a successful response but got an error: " <>)
    . show

wantedErrorButSuccess
    :: (MonadIO m, Show a)
    => a
    -> m ()
wantedErrorButSuccess = liftIO
    .  expectationFailure
    . ("expected an error but got a successful response: " <>)
    . show

-- | Apply 'a' to all actions in sequence
verify :: (Show a, MonadIO m, MonadUnliftIO m) => a -> [a -> m ()] -> m ()
verify a = counterexample msg . mapM_ (a &)
  where
    msg = "While verifying " ++ show a

-- | Can be used to add context to a @HUnitFailure@.
--
-- >>> counterexample (show reponse) (0 `shouldBe` 3)
-- >>>  (Status {statusCode = 200, statusMessage = "OK"},Right [])
-- >>>        expected: 3
-- >>>         but got: 0
counterexample :: (MonadIO m, MonadUnliftIO m, HasCallStack) => String -> m a -> m a
counterexample msg = (`catch` (throwIO . appendFailureReason msg))

appendFailureReason :: String -> HUnitFailure -> HUnitFailure
appendFailureReason message = wrap
  where
    wrap :: HUnitFailure -> HUnitFailure
    wrap (HUnitFailure mloc reason) =
        HUnitFailure mloc (addMessageTo reason)

    addMessageTo :: FailureReason -> FailureReason
    addMessageTo (Reason reason) = Reason $ reason ++ "\n" ++ message
    addMessageTo (ExpectedButGot preface expected actual) =
      ExpectedButGot newPreface expected actual
      where
      newPreface =
        case preface of
        Nothing -> Just message
        Just existingMessage -> Just $ existingMessage ++ "\n" ++ message

--
-- Manipulating endpoints
--

-- | Override the method of a particular endpoint, mostly to exercise invalid
-- endpoints from existing ones.
withMethod :: Method -> (Method, Text) -> (Method, Text)
withMethod method (_, path) = (method, path)

-- | Modifies the value of a path parameter at position 'n' (indexed from 0)
-- with the given update function. Throws if the given endpoint has no path
-- parameter in the given position.
--
-- >>> Link.getWallet @Shelley myWallet
-- ( "GET", "v2/wallets/2512a00e9653fe49a44a5886202e24d77eeb998f" )
--
-- >>> withPathParam 0 (<> "suffix") $ Link.getWallet @Shelley myWallet
-- ( "GET", "v2/wallets/2512a00e9653fe49a44a5886202e24d77eeb998fsuffix" )
--
-- >>> withPathParam 1 (const "suffix") $ Link.joinStakePool @Shelley myPool myWallet
-- ( "GET", "v2/stake-pools/2512a00e9653fe49a44a5886202e24d77eeb998f/wallets/patate" )
withPathParam :: Int -> (Text -> Text) -> (Method, Text) -> (Method, Text)
withPathParam n0 update (method, path) =
    case T.splitOn "/" path of
        [] -> errInvalidEndpoint

        version:q ->
            (method, T.intercalate "/" (version:findAndModify n0 q))
  where
    findAndModify 0 (k:v:q) = k : update v : q
    findAndModify n (k:v:q) = k : v : findAndModify (n - 1) q
    findAndModify _ _       = errInvalidEndpoint

    errInvalidEndpoint :: a
    errInvalidEndpoint =
        error $ "modifyPathParam: invalid endpoint: " <> show (method, path)

toQueryString :: [(Text, Text)] -> Text
toQueryString kvs = if T.null suffix then mempty else "?" <> suffix
  where
    suffix = T.intercalate "&" $ buildQueryParam <$> kvs
    buildQueryParam (k, v) = k <> "=" <> toQueryParam v

addField :: ToJSON a => Text -> a -> Payload -> Payload
addField fieldName field = \case
    Json (Aeson.Object o) ->
        Json (Aeson.Object (o <> (fieldName .= field)))
    _ ->
        error "addField called on a non-json payload"

infixr 5 </>
(</>) :: ToHttpApiData a => Text -> a -> Text
base </> thenext = mconcat [base, "/", toQueryParam thenext]

---
--- CLI
---

commandName :: String
commandName = "cardano-wallet"

-- | Run a command using the 'cardano-wallet' executable.
cardanoWalletCLI
    :: forall r m. (CmdResult r, MonadIO m)
    => [String]
    -> m r
cardanoWalletCLI = liftIO . command [EchoStderr False] commandName

generateMnemonicsViaCLI
    :: forall r m. (CmdResult r, MonadIO m)
    => [String]
    -> m r
generateMnemonicsViaCLI args = cardanoWalletCLI
    (["recovery-phrase", "generate"] ++ args)

createWalletViaCLI
    :: forall s m. (HasType (Port "wallet") s, MonadIO m)
    => s
    -> [String]
    -> String
    -> String
    -> String
    -> m (ExitCode, String, Text)
createWalletViaCLI ctx args mnemonics secondFactor passphrase = do
    let portArgs =
            [ "--port", show (ctx ^. typed @(Port "wallet")) ]
    let fullArgs =
            [ "wallet", "create", "from-recovery-phrase" ] ++ portArgs ++ args
    let process = proc' commandName fullArgs
    liftIO $ withCreateProcess process $
        \(Just stdin) (Just stdout) (Just stderr) h -> do
            hPutStr stdin mnemonics
            hPutStr stdin secondFactor
            hPutStr stdin (passphrase ++ "\n")
            hPutStr stdin (passphrase ++ "\n")
            hFlush stdin
            hClose stdin
            c <- waitForProcess h
            out <- TIO.hGetContents stdout
            err <- TIO.hGetContents stderr
            return (c, T.unpack out, err)

createWalletFromPublicKeyViaCLI
    :: forall r s m.
        ( CmdResult r
        , HasType (Port "wallet") s

        , MonadIO m
        )
    => s
    -> [String]
        -- ^ NAME, [--address-pool-gap INT], ACCOUNT_PUBLIC_KEY
    -> m r
createWalletFromPublicKeyViaCLI ctx args = cardanoWalletCLI $
    [ "wallet", "create", "from-public-key", "--port"
    , show (ctx ^. typed @(Port "wallet"))] ++ args

deleteWalletViaCLI
    :: forall r s m.
        ( CmdResult r

        , HasType (Port "wallet") s
        , MonadIO m
        )
    => s
    -> String
    -> m r
deleteWalletViaCLI ctx walId = cardanoWalletCLI
    ["wallet", "delete", "--port", show (ctx ^. typed @(Port "wallet")), walId ]

getWalletViaCLI
    :: forall r s m.
        ( CmdResult r

        , HasType (Port "wallet") s
        , MonadIO m
        )
    => s
    -> String
    -> m r
getWalletViaCLI ctx walId = cardanoWalletCLI
    ["wallet", "get", "--port", show (ctx ^. typed @(Port "wallet")) , walId ]

getWalletUtxoStatisticsViaCLI
    :: forall r s m.
        ( CmdResult r

        , HasType (Port "wallet") s
        , MonadIO m)
    => s
    -> String
    -> m r
getWalletUtxoStatisticsViaCLI ctx walId = cardanoWalletCLI
    ["wallet", "utxo", "--port", show (ctx ^. typed @(Port "wallet")) , walId ]

createAddressViaCLI
    :: forall s m. (HasType (Port "wallet") s, MonadIO m)
    => s
    -> [String]
        -- ^ Args
    -> String
        -- ^ Pass
    -> m (ExitCode, Text, Text)
        -- ^ (ExitCode, StdOut, StdErr)
createAddressViaCLI ctx args pass = do
    let execArgs =
            [ "address", "create"
            , "--port", show (ctx ^. typed @(Port "wallet"))
            ] ++ args
    let process = proc' commandName execArgs
    liftIO $ withCreateProcess process $
        \(Just stdin) (Just stdout) (Just stderr) h -> do
            hPutStr stdin (pass <> "\n")
            hFlush stdin
            hClose stdin
            c <- waitForProcess h
            out <- TIO.hGetContents stdout
            err <- TIO.hGetContents stderr
            pure (c, out, err)

importAddressViaCLI
    :: forall r s m. (CmdResult r, HasType (Port "wallet") s, MonadIO m)
    => s
    -> [String]
        -- ^ Args
    -> m r
        -- ^ (ExitCode, StdOut, StdErr)
importAddressViaCLI ctx args = cardanoWalletCLI $
    ["address", "import", "--port", show (ctx ^. typed @(Port "wallet"))] ++ args

listAddressesViaCLI
    :: forall r s m. (CmdResult r, HasType (Port "wallet") s, MonadIO m)
    => s
    -> [String]
    -> m r
listAddressesViaCLI ctx args = cardanoWalletCLI $
    ["address", "list", "--port", show (ctx ^. typed @(Port "wallet"))] ++ args

listStakePoolsViaCLI
    :: forall r s m. (CmdResult r, HasType (Port "wallet") s, MonadIO m)
    => s
    -> m r
listStakePoolsViaCLI ctx = cardanoWalletCLI
    ["stake-pool", "list", "--port", show (ctx ^. typed @(Port "wallet")) ]

listWalletsViaCLI
    :: forall r s m.
        ( CmdResult r

        , HasType (Port "wallet") s
        , MonadIO m
        )
    => s
    -> m r
listWalletsViaCLI ctx = cardanoWalletCLI
    ["wallet", "list", "--port", show (ctx ^. typed @(Port "wallet")) ]

updateWalletNameViaCLI
    :: forall r s m.
        ( CmdResult r

        , HasType (Port "wallet") s
        , MonadIO m
        )
    => s
    -> [String]
    -> m r
updateWalletNameViaCLI ctx args = cardanoWalletCLI
    (["wallet", "update", "name", "--port", walletPort] ++ args)
  where
    walletPort = show (ctx ^. typed @(Port "wallet"))

updateWalletPassphraseViaCLI
    :: forall s m. (HasType (Port "wallet") s, MonadIO m)
    => s
    -> String
        -- ^ Wallet id
    -> String
        -- ^ Old passphrase
    -> String
        -- ^ New passphrase
    -> String
        -- ^ New passphrase (repeated for confirmation)
    -> m (ExitCode, Text, Text)
updateWalletPassphraseViaCLI ctx wid ppOld ppNew ppNewConfirm = do
    let process = proc' commandName
            [ "wallet", "update", "passphrase"
            , "--port", show (ctx ^. typed @(Port "wallet"))
            , wid
            ]
    liftIO $ withCreateProcess process $
        \(Just stdin) (Just stdout) (Just stderr) h -> do
            hPutStr stdin (ppOld <> "\n")
            hPutStr stdin (ppNew <> "\n")
            hPutStr stdin (ppNewConfirm <> "\n")
            hFlush stdin
            hClose stdin
            c <- waitForProcess h
            out <- TIO.hGetContents stdout
            err <- TIO.hGetContents stderr
            pure (c, out, err)

postTransactionViaCLI
    :: forall s m. (HasType (Port "wallet") s, MonadIO m)
    => s
    -> String
    -> [String]
    -> m (ExitCode, String, Text)
postTransactionViaCLI ctx passphrase args = do
    let portArgs =
            ["--port", show (ctx ^. typed @(Port "wallet"))]
    let fullArgs =
            ["transaction", "create"] ++ portArgs ++ args
    let process = proc' commandName fullArgs
    liftIO $ withCreateProcess process $
        \(Just stdin) (Just stdout) (Just stderr) h -> do
            hPutStr stdin (passphrase ++ "\n")
            hFlush stdin
            hClose stdin
            out <- TIO.hGetContents stdout
            err <- TIO.hGetContents stderr
            -- For some reason, when
            -- - waitForProcess is called before hGetContents
            -- - os is windows
            -- - postTransactionViaCLI was called with >= 5 outputs
            -- waitForProcess blocks indefinetely. Hence we call waitForProcess
            -- last.
            c <- waitForProcess h
            return (c, T.unpack out, err)

postTransactionFeeViaCLI
    :: forall r s m. (CmdResult r, HasType (Port "wallet") s, MonadIO m)
    => s
    -> [String]
    -> m r
postTransactionFeeViaCLI ctx args = cardanoWalletCLI $ join
        [ ["transaction", "fees"]
        , ["--port", show (ctx ^. typed @(Port "wallet"))]
        , args
        ]

listTransactionsViaCLI
    :: forall r s m. (CmdResult r, HasType (Port "wallet") s, MonadIO m)
    => s
    -> [String]
    -> m r
listTransactionsViaCLI ctx args = cardanoWalletCLI $ join
    [ ["transaction", "list"]
    , ["--port", show (ctx ^. typed @(Port "wallet"))]
    , args
    ]

postExternalTransactionViaCLI
    :: forall r s m. (CmdResult r, HasType (Port "wallet") s, MonadIO m)
    => s
    -> [String]
    -> m r
postExternalTransactionViaCLI ctx args = cardanoWalletCLI $ join
    [ ["transaction", "submit"]
    , ["--port", show (ctx ^. typed @(Port "wallet"))]
    , args
    ]

deleteTransactionViaCLI
    :: forall r s m. (CmdResult r, HasType (Port "wallet") s, MonadIO m)
    => s
    -> String
    -> String
    -> m r
deleteTransactionViaCLI ctx wid tid = cardanoWalletCLI $ join
    [ ["transaction", "forget"]
    , ["--port", show (ctx ^. typed @(Port "wallet")), wid, tid]
    ]

getTransactionViaCLI
    :: forall r s m. (CmdResult r, HasType (Port "wallet") s, MonadIO m)
    => s
    -> String
    -> String
    -> m r
getTransactionViaCLI ctx wid tid = cardanoWalletCLI $ join
    [ ["transaction", "get"]
    , ["--port", show (ctx ^. typed @(Port "wallet")), wid, tid]
    ]

proc' :: FilePath -> [String] -> CreateProcess
proc' cmd args = (proc cmd args)
    { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }

oneSecond :: Int
oneSecond = 1_000 * oneMillisecond

oneMillisecond :: Int
oneMillisecond = 1_000

-- | Creates group of at most `n` elements. Last group may be smaller if
-- it's not properly divisible.
groupsOf :: Int -> [a] -> [[a]]
groupsOf _ [] = []
groupsOf n xs = take n xs : groupsOf n (drop n xs)

-- | 'map' flipped.
for :: [a] -> (a -> b) -> [b]
for = flip map

--
-- Helper for random wallets from Xprv
--
rootPrvKeyFromMnemonics :: [Text] -> Text -> Text
rootPrvKeyFromMnemonics mnemonics pass =
    T.decodeUtf8 $ hex $ getKey $ Byron.generateKeyFromSeed seed
        (preparePassphrase W.EncryptWithScrypt rawPassd)
 where
     (Right seed) = mkSomeMnemonic @'[12] mnemonics
     rawPassd = Passphrase $ BA.convert $ T.encodeUtf8 pass

--
-- Helper for HWWallets, getting pubKey from mnemonic sentence
--
pubKeyFromMnemonics :: [Text] -> Text
pubKeyFromMnemonics mnemonics =
    T.decodeUtf8 $ serializeXPub $ publicKey
       $ deriveAccountPrivateKey mempty rootXPrv minBound
 where
     seed = either (error . show) id $ mkSomeMnemonic @'[15,24] mnemonics
     rootXPrv = Shelley.generateKeyFromSeed (seed, Nothing) mempty

--
-- Helper for delegation statuses
--
getSlotParams
    :: MonadIO m
    => Context
    -> m (EpochNo, SlottingParameters)
getSlotParams ctx = do
    r1 <- liftIO $ request @ApiNetworkInformation ctx
          Link.getNetworkInfo Default Empty
    let ApiT currentEpoch =
             view (#slotId . #epochNumber)
            $ fromMaybe (error "getSlotParams: tip is Nothing")
            $ getFromResponse #networkTip r1

    let endpoint = ( "GET", "v2/network/parameters" )
    r2 <- liftIO $ request @ApiNetworkParameters ctx endpoint Default Empty
    let (Quantity slotL) = getFromResponse #slotLength r2
    let (Quantity epochL) = getFromResponse #epochLength r2
    let (Quantity coeff) = getFromResponse #activeSlotCoefficient r2
    let (Quantity k) = getFromResponse #securityParameter r2
    let sp = SlottingParameters
            (SlotLength slotL)
            (EpochLength epochL)
            (ActiveSlotCoefficient coeff)
            (Quantity k)

    return (currentEpoch, sp)

-- | Converts a transaction TTL in seconds into a number of slots, using the
-- slot length.
getTTLSlots
    :: MonadIO m
    => Context
    -> NominalDiffTime
    -> m SlotNo
getTTLSlots ctx dt = liftIO $ do
    _slotLenWrong <- unSlotLength . getSlotLength . snd <$> getSlotParams ctx
    let slotLen = 0.2 -- fixme: this is the value from byron genesis
    pure $ SlotNo $ ceiling $ dt / slotLen

-- | Wallet not delegating and not about to join any stake pool.
notDelegating
    :: [(Maybe (ApiT PoolId), ApiEpochInfo)]
    -- ^ Pools to be joined & epoch at which the new delegation will become active
    -> ApiWalletDelegation
notDelegating nexts = ApiWalletDelegation
    { active = ApiWalletDelegationNext NotDelegating Nothing Nothing
    , next = flip map nexts $ \(mpid, epochInfo) -> case mpid of
        Nothing ->
            ApiWalletDelegationNext NotDelegating Nothing (Just epochInfo)
        Just pid ->
            ApiWalletDelegationNext Delegating (Just pid) (Just epochInfo)
    }

delegating
    :: ApiT PoolId
    -- ^ Pool joined
    -> [(Maybe (ApiT PoolId), ApiEpochInfo)]
    -- ^ Pools to be joined & epoch at which the new delegation will become active
    -> ApiWalletDelegation
delegating pidActive nexts = (notDelegating nexts)
    { active = ApiWalletDelegationNext Delegating (Just pidActive) Nothing
    }


getRetirementEpoch :: ApiStakePool -> Maybe EpochNo
getRetirementEpoch = fmap (view (#epochNumber . #getApiT)) .  view #retirement

unsafeResponse :: (HTTP.Status, Either RequestException a) -> a
unsafeResponse = either (error . show) id . snd