diff --git a/components/blockfrost/Effectful/Zoo/Blockfrost.hs b/components/blockfrost/Effectful/Zoo/Blockfrost.hs new file mode 100644 --- /dev/null +++ b/components/blockfrost/Effectful/Zoo/Blockfrost.hs @@ -0,0 +1,177 @@ +module Effectful.Zoo.Blockfrost + ( Blockfrost, + BlockfrostError, + Project, + runBlockfrost, + + -- * Client + getRoot, + getHealth, + getClock, + getMetrics, + getMetricsEndpoints, + + -- * Client.NutLink + nutlinkListAddress, + nutlinkListAddressTickers', + nutlinkListAddressTickers, + nutlinkAddressTickers', + nutlinkAddressTickers, + nutlinkTickers', + nutlinkTickers, + + -- * Client.IPFS + ipfsGateway, + ipfsPin, + ipfsListPins', + ipfsListPins, + ipfsGetPin, + ipfsRemovePin, + + -- * Client.Cardano.Blocks + getLatestBlock, + getLatestBlockTxs', + getLatestBlockTxs, + getBlock, + getBlockSlot, + getBlockEpochSlot, + getNextBlocks', + getNextBlocks, + getPreviousBlocks', + getPreviousBlocks, + getBlockTxs', + getBlockTxs, + getBlockAffectedAddresses', + getBlockAffectedAddresses, + + -- * Client.Cardano.Network + getNetworkInfo, + getNetworkEras, + + -- * Client.Cardano.Addresses + getAddressInfo, + getAddressInfoExtended, + getAddressDetails, + getAddressUtxos', + getAddressUtxos, + getAddressUtxosAsset', + getAddressUtxosAsset, + getAddressTransactions', + getAddressTransactions, + + -- * Client.Cardano.Assets + getAssets', + getAssets, + getAssetDetails, + getAssetHistory', + getAssetHistory, + getAssetTransactions', + getAssetTransactions, + getAssetAddresses', + getAssetAddresses, + getAssetsByPolicy', + getAssetsByPolicy, + + -- * Client.Cardano.Scripts + listScripts', + listScripts, + getScript, + getScriptRedeemers', + getScriptRedeemers, + getScriptDatum, + getScriptDatumCBOR, + getScriptJSON, + getScriptCBOR, + + -- * Client.Cardano.Epochs + getLatestEpoch, + getLatestEpochProtocolParams, + getEpoch, + getNextEpochs', + getNextEpochs, + getPreviousEpochs', + getPreviousEpochs, + getEpochStake', + getEpochStake, + getEpochStakeByPool', + getEpochStakeByPool, + getEpochBlocks', + getEpochBlocks, + getEpochBlocksByPool', + getEpochBlocksByPool, + getEpochProtocolParams, + + -- * Client.Cardano.Transactions + getTx, + getTxUtxos, + getTxRedeemers, + getTxStakes, + getTxDelegations, + getTxWithdrawals, + getTxMirs, + getTxPoolUpdates, + getTxPoolRetiring, + getTxMetadataJSON, + getTxMetadataCBOR, + submitTx, + + -- * Client.Cardano.Ledger + getLedgerGenesis, + + -- * Client.Cardano.Accounts + getAccount, + getAccountRewards', + getAccountRewards, + getAccountHistory', + getAccountHistory, + getAccountDelegations', + getAccountDelegations, + getAccountRegistrations', + getAccountRegistrations, + getAccountWithdrawals', + getAccountWithdrawals, + getAccountMirs', + getAccountMirs, + getAccountAssociatedAddresses', + getAccountAssociatedAddresses, + getAccountAssociatedAddressesTotal, + getAccountAssociatedAssets', + getAccountAssociatedAssets, + + -- * Client.Cardano.Pools + listPools', + listPools, + listPoolsExtended', + listPoolsExtended, + listRetiredPools', + listRetiredPools, + listRetiringPools', + listRetiringPools, + getPool, + getPoolHistory', + getPoolHistory, + getPoolMetadata, + getPoolRelays, + getPoolDelegators', + getPoolDelegators, + getPoolBlocks', + getPoolBlocks, + getPoolUpdates', + getPoolUpdates, + + -- * Client.Cardano.Metadata + getTxMetadataLabels', + getTxMetadataLabels, + getTxMetadataByLabelJSON', + getTxMetadataByLabelJSON, + getTxMetadataByLabelCBOR', + getTxMetadataByLabelCBOR, + + -- * Pagination + allPages, + + ) where + +import Effectful.Zoo.Blockfrost.Api + +import Blockfrost.Client (allPages) diff --git a/components/blockfrost/Effectful/Zoo/Blockfrost/Api.hs b/components/blockfrost/Effectful/Zoo/Blockfrost/Api.hs new file mode 100644 --- /dev/null +++ b/components/blockfrost/Effectful/Zoo/Blockfrost/Api.hs @@ -0,0 +1,681 @@ +module Effectful.Zoo.Blockfrost.Api + ( Blockfrost, + + AccountDelegation(..), + AccountHistory(..), + AccountInfo(..), + AccountMir(..), + AccountRegistration(..), + AccountRegistrationAction(..), + AccountReward(..), + AccountWithdrawal(..), + Address(..), + AddressAssociated(..), + AddressAssociatedTotal(..), + AddressDetails(..), + AddressInfo(..), + AddressInfoExtended(..), + AddressTransaction(..), + AddressType(..), + AddressUtxo(..), + Amount(..), + AssetAction(..), + AssetAddress(..), + AssetDetails(..), + AssetHistory(..), + AssetId(..), + AssetInfo(..), + AssetMetadata(..), + AssetOnChainMetadata(..), + AssetTransaction(..), + Block(..), + BlockfrostError(..), + BlockHash(..), + CBORString(..), + CostModels(..), + DatumHash(..), + DerivedAddress(..), + Epoch(..), + EpochInfo(..), + EpochLength(..), + Genesis(..), + Healthy(..), + InlineDatum(..), + IPFSAdd(..), + IPFSData(..), + IPFSPin(..), + IPFSPinChange(..), + Lovelaces, + MetadataMediaFile(..), + Metric(..), + Network(..), + NetworkEraBound(..), + NetworkEraParameters(..), + NetworkEraSummary(..), + NetworkStake(..), + NetworkSupply(..), + NutlinkAddress(..), + NutlinkAddressTicker(..), + NutlinkTicker(..), + Paged(..), + PinState(..), + PolicyId, + Pool(..), + PoolDelegator(..), + PoolEpoch(..), + PoolHistory(..), + PoolId(..), + PoolInfo(..), + PoolMetadata(..), + PoolRegistrationAction(..), + PoolRelay(..), + PoolStakeDistribution(..), + PoolUpdate(..), + PoolUpdateMetadata(..), + POSIXMillis, + Pot(..), + Project(..), + ProtocolParams(..), + Quantity(..), + RewardType(..), + Script(..), + ScriptCBOR(..), + ScriptDatum(..), + ScriptDatumCBOR(..), + ScriptHash(..), + ScriptHashList(..), + ScriptJSON(..), + ScriptRedeemer(..), + ScriptType (..), + ServerTime(..), + Slot(..), + SortOrder(..), + StakeDistribution(..), + ToLower, + Transaction(..), + TransactionDelegation(..), + TransactionMetaCBOR(..), + TransactionMetaJSON(..), + TransactionMir(..), + TransactionPoolRetiring(..), + TransactionPoolUpdate(..), + TransactionRedeemer(..), + TransactionStake(..), + TransactionUtxos(..), + TransactionWithdrawal(..), + TxEval(..), + TxEvalBudget(..), + TxEvalInput(..), + TxHash(..), + TxMeta, + TxMetaCBOR(..), + TxMetaJSON(..), + URLVersion(..), + UtxoInput(..), + UtxoOutput(..), + ValidationPurpose(..), + + mkAddress, + unAddress, + mkAssetId, + unAssetId, + mkBlockHash, + unBlockHash, + unEpoch, + unEpochLength, + mkPolicyId, + unPolicyId, + mkPoolId, + unPoolId, + millisecondsToPosix, + posixToMilliseconds, + unQuantity, + unSlot, + + runBlockfrost, + + -- Client + getRoot , + getHealth , + getClock , + getMetrics , + getMetricsEndpoints , + + -- Client.NutLink + nutlinkListAddress , + nutlinkListAddressTickers' , + nutlinkListAddressTickers , + nutlinkAddressTickers' , + nutlinkAddressTickers , + nutlinkTickers' , + nutlinkTickers , + + -- Client.IPFS + ipfsGateway , + ipfsPin , + ipfsListPins' , + ipfsListPins , + ipfsGetPin , + ipfsRemovePin , + + -- Client.Cardano.Blocks + getLatestBlock , + getLatestBlockTxs' , + getLatestBlockTxs , + getBlock , + getBlockSlot , + getBlockEpochSlot , + getNextBlocks' , + getNextBlocks , + getPreviousBlocks' , + getPreviousBlocks , + getBlockTxs' , + getBlockTxs , + getBlockAffectedAddresses' , + getBlockAffectedAddresses , + + -- Client.Cardano.Network + getNetworkInfo , + getNetworkEras , + + -- Client.Cardano.Addresses + getAddressInfo , + getAddressInfoExtended , + getAddressDetails , + getAddressUtxos' , + getAddressUtxos , + getAddressUtxosAsset' , + getAddressUtxosAsset , + getAddressTransactions' , + getAddressTransactions , + + -- Client.Cardano.Assets + getAssets' , + getAssets , + getAssetDetails , + getAssetHistory' , + getAssetHistory , + getAssetTransactions' , + getAssetTransactions , + getAssetAddresses' , + getAssetAddresses , + getAssetsByPolicy' , + getAssetsByPolicy , + + -- Client.Cardano.Scripts + listScripts' , + listScripts , + getScript , + getScriptRedeemers' , + getScriptRedeemers , + getScriptDatum , + getScriptDatumCBOR , + getScriptJSON , + getScriptCBOR , + + -- Client.Cardano.Epochs + getLatestEpoch , + getLatestEpochProtocolParams , + getEpoch , + getNextEpochs' , + getNextEpochs , + getPreviousEpochs' , + getPreviousEpochs , + getEpochStake' , + getEpochStake , + getEpochStakeByPool' , + getEpochStakeByPool , + getEpochBlocks' , + getEpochBlocks , + getEpochBlocksByPool' , + getEpochBlocksByPool , + getEpochProtocolParams , + + -- Client.Cardano.Transactions + getTx , + getTxUtxos , + getTxRedeemers , + getTxStakes , + getTxDelegations , + getTxWithdrawals , + getTxMirs , + getTxPoolUpdates , + getTxPoolRetiring , + getTxMetadataJSON , + getTxMetadataCBOR , + submitTx , + + -- Client.Cardano.Ledger + getLedgerGenesis , + + -- Client.Cardano.Accounts + getAccount , + getAccountRewards' , + getAccountRewards , + getAccountHistory' , + getAccountHistory , + getAccountDelegations' , + getAccountDelegations , + getAccountRegistrations' , + getAccountRegistrations , + getAccountWithdrawals' , + getAccountWithdrawals , + getAccountMirs' , + getAccountMirs , + getAccountAssociatedAddresses' , + getAccountAssociatedAddresses , + getAccountAssociatedAddressesTotal , + getAccountAssociatedAssets' , + getAccountAssociatedAssets , + + -- Client.Cardano.Pools + listPools' , + listPools , + listPoolsExtended' , + listPoolsExtended , + listRetiredPools' , + listRetiredPools , + listRetiringPools' , + listRetiringPools , + getPool , + getPoolHistory' , + getPoolHistory , + getPoolMetadata , + getPoolRelays , + getPoolDelegators' , + getPoolDelegators , + getPoolBlocks' , + getPoolBlocks , + getPoolUpdates' , + getPoolUpdates , + + -- Client.Cardano.Metadata + getTxMetadataLabels' , + getTxMetadataLabels , + getTxMetadataByLabelJSON' , + getTxMetadataByLabelJSON , + getTxMetadataByLabelCBOR' , + getTxMetadataByLabelCBOR , + + ) where + +import Blockfrost.Client (BlockfrostError (..), Paged (..), Project (..), SortOrder (..)) +import Blockfrost.Types.Cardano.Accounts +import Blockfrost.Types.Cardano.Addresses +import Blockfrost.Types.Cardano.Assets +import Blockfrost.Types.Cardano.Blocks +import Blockfrost.Types.Cardano.Epochs +import Blockfrost.Types.Cardano.Genesis +import Blockfrost.Types.Cardano.Metadata +import Blockfrost.Types.Cardano.Network +import Blockfrost.Types.Cardano.Pools +import Blockfrost.Types.Cardano.Scripts +import Blockfrost.Types.Cardano.Transactions +import Blockfrost.Types.Cardano.Utils +import Blockfrost.Types.Common +import Blockfrost.Types.IPFS +import Blockfrost.Types.NutLink +import Blockfrost.Types.Shared.Ada +import Blockfrost.Types.Shared.Address +import Blockfrost.Types.Shared.Amount +import Blockfrost.Types.Shared.AssetId +import Blockfrost.Types.Shared.BlockHash +import Blockfrost.Types.Shared.BlockIndex +import Blockfrost.Types.Shared.CBOR +import Blockfrost.Types.Shared.DatumHash +import Blockfrost.Types.Shared.Epoch +import Blockfrost.Types.Shared.Opts +import Blockfrost.Types.Shared.PolicyId +import Blockfrost.Types.Shared.PoolId +import Blockfrost.Types.Shared.POSIXMillis +import Blockfrost.Types.Shared.Quantity +import Blockfrost.Types.Shared.ScriptHash +import Blockfrost.Types.Shared.Slot +import Blockfrost.Types.Shared.TxHash +import Blockfrost.Types.Shared.ValidationPurpose +import Control.Monad +import Data.Either +import Data.Maybe +import Data.Text +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Error.Static +import Effectful.Zoo.Blockfrost.Dynamic (Blockfrost, runBlockfrost) +import Effectful.Zoo.Blockfrost.Dynamic qualified as BF +import Effectful.Zoo.Core +import HaskellWorks.Prelude + +-- Client +getRoot :: r <: Blockfrost => r <: Error BlockfrostError => Eff r URLVersion +getHealth :: r <: Blockfrost => r <: Error BlockfrostError => Eff r Healthy +getClock :: r <: Blockfrost => r <: Error BlockfrostError => Eff r ServerTime +getMetrics :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [Metric] +getMetricsEndpoints :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [(Text, Metric)] + +-- Client.NutLink +nutlinkListAddress :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r NutlinkAddress +nutlinkListAddressTickers' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [NutlinkAddressTicker] +nutlinkListAddressTickers :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [NutlinkAddressTicker] +nutlinkAddressTickers' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Text -> Paged -> SortOrder -> Eff r [NutlinkTicker] +nutlinkAddressTickers :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Text -> Eff r [NutlinkTicker] +nutlinkTickers' :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Paged -> SortOrder -> Eff r [(Address, NutlinkTicker)] +nutlinkTickers :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Eff r [(Address, NutlinkTicker)] + +-- Client.IPFS +ipfsGateway :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Eff r IPFSData +ipfsPin :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Eff r IPFSPinChange +ipfsListPins' :: r <: Blockfrost => r <: Error BlockfrostError => Paged -> SortOrder -> Eff r [IPFSPin] +ipfsListPins :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [IPFSPin] +ipfsGetPin :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Eff r IPFSPin +ipfsRemovePin :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Eff r IPFSPinChange + +-- Client.Cardano.Blocks +getLatestBlock :: r <: Blockfrost => r <: Error BlockfrostError => Eff r Block +getLatestBlockTxs' :: r <: Blockfrost => r <: Error BlockfrostError => Paged -> SortOrder -> Eff r [TxHash] +getLatestBlockTxs :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [TxHash] +getBlock :: r <: Blockfrost => r <: Error BlockfrostError => Either Integer BlockHash -> Eff r Block +getBlockSlot :: r <: Blockfrost => r <: Error BlockfrostError => Slot -> Eff r Block +getBlockEpochSlot :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Slot -> Eff r Block +getNextBlocks' :: r <: Blockfrost => r <: Error BlockfrostError => Either Integer BlockHash -> Paged -> Eff r [Block] +getNextBlocks :: r <: Blockfrost => r <: Error BlockfrostError => Either Integer BlockHash -> Eff r [Block] +getPreviousBlocks' :: r <: Blockfrost => r <: Error BlockfrostError => Either Integer BlockHash -> Paged -> Eff r [Block] +getPreviousBlocks :: r <: Blockfrost => r <: Error BlockfrostError => Either Integer BlockHash -> Eff r [Block] +getBlockTxs' :: r <: Blockfrost => r <: Error BlockfrostError => Either Integer BlockHash -> Paged -> SortOrder -> Eff r [TxHash] +getBlockTxs :: r <: Blockfrost => r <: Error BlockfrostError => Either Integer BlockHash -> Eff r [TxHash] +getBlockAffectedAddresses' :: r <: Blockfrost => r <: Error BlockfrostError => Either Integer BlockHash -> Paged -> Eff r [(Address, [TxHash])] +getBlockAffectedAddresses :: r <: Blockfrost => r <: Error BlockfrostError => Either Integer BlockHash -> Eff r [(Address, [TxHash])] + +-- Client.Cardano.Network +getNetworkInfo :: r <: Blockfrost => r <: Error BlockfrostError => Eff r Network +getNetworkEras :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [NetworkEraSummary] + +-- Client.Cardano.Addresses +getAddressInfo :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r AddressInfo +getAddressInfoExtended :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r AddressInfoExtended +getAddressDetails :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r AddressDetails +getAddressUtxos' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [AddressUtxo] +getAddressUtxos :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [AddressUtxo] +getAddressUtxosAsset' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> AssetId-> Paged -> SortOrder -> Eff r [AddressUtxo] +getAddressUtxosAsset :: r <: Blockfrost => r <: Error BlockfrostError => Address -> AssetId -> Eff r [AddressUtxo] +getAddressTransactions' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Maybe BlockIndex -> Maybe BlockIndex -> Eff r [AddressTransaction] +getAddressTransactions :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [AddressTransaction] + +-- Client.Cardano.Assets +getAssets' :: r <: Blockfrost => r <: Error BlockfrostError => Paged -> SortOrder -> Eff r [AssetInfo] +getAssets :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [AssetInfo] +getAssetDetails :: r <: Blockfrost => r <: Error BlockfrostError => AssetId -> Eff r AssetDetails +getAssetHistory' :: r <: Blockfrost => r <: Error BlockfrostError => AssetId -> Paged -> SortOrder -> Eff r [AssetHistory] +getAssetHistory :: r <: Blockfrost => r <: Error BlockfrostError => AssetId -> Eff r [AssetHistory] +getAssetTransactions' :: r <: Blockfrost => r <: Error BlockfrostError => AssetId -> Paged -> SortOrder -> Eff r [AssetTransaction] +getAssetTransactions :: r <: Blockfrost => r <: Error BlockfrostError => AssetId -> Eff r [AssetTransaction] +getAssetAddresses' :: r <: Blockfrost => r <: Error BlockfrostError => AssetId -> Paged -> SortOrder -> Eff r [AssetAddress] +getAssetAddresses :: r <: Blockfrost => r <: Error BlockfrostError => AssetId -> Eff r [AssetAddress] +getAssetsByPolicy' :: r <: Blockfrost => r <: Error BlockfrostError => PolicyId -> Paged -> SortOrder -> Eff r [AssetInfo] +getAssetsByPolicy :: r <: Blockfrost => r <: Error BlockfrostError => PolicyId -> Eff r [AssetInfo] + +-- Client.Cardano.Scripts +listScripts' :: r <: Blockfrost => r <: Error BlockfrostError => Paged -> SortOrder -> Eff r ScriptHashList +listScripts :: r <: Blockfrost => r <: Error BlockfrostError => Eff r ScriptHashList +getScript :: r <: Blockfrost => r <: Error BlockfrostError => ScriptHash -> Eff r Script +getScriptRedeemers' :: r <: Blockfrost => r <: Error BlockfrostError => ScriptHash -> Paged -> SortOrder -> Eff r [ScriptRedeemer] +getScriptRedeemers :: r <: Blockfrost => r <: Error BlockfrostError => ScriptHash -> Eff r [ScriptRedeemer] +getScriptDatum :: r <: Blockfrost => r <: Error BlockfrostError => DatumHash -> Eff r ScriptDatum +getScriptDatumCBOR :: r <: Blockfrost => r <: Error BlockfrostError => DatumHash -> Eff r ScriptDatumCBOR +getScriptJSON :: r <: Blockfrost => r <: Error BlockfrostError => ScriptHash -> Eff r ScriptJSON +getScriptCBOR :: r <: Blockfrost => r <: Error BlockfrostError => ScriptHash -> Eff r ScriptCBOR + +-- Client.Cardano.Epochs +getLatestEpoch :: r <: Blockfrost => r <: Error BlockfrostError => Eff r EpochInfo +getLatestEpochProtocolParams :: r <: Blockfrost => r <: Error BlockfrostError => Eff r ProtocolParams +getEpoch :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Eff r EpochInfo +getNextEpochs' :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Paged -> Eff r [EpochInfo] +getNextEpochs :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Eff r [EpochInfo] +getPreviousEpochs' :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Paged -> Eff r [EpochInfo] +getPreviousEpochs :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Eff r [EpochInfo] +getEpochStake' :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Paged -> Eff r [StakeDistribution] +getEpochStake :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Eff r [StakeDistribution] +getEpochStakeByPool' :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> PoolId -> Paged -> Eff r [PoolStakeDistribution] +getEpochStakeByPool :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> PoolId -> Eff r [PoolStakeDistribution] +getEpochBlocks' :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Paged -> SortOrder -> Eff r [BlockHash] +getEpochBlocks :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Eff r [BlockHash] +getEpochBlocksByPool' :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> PoolId -> Paged -> SortOrder -> Eff r [BlockHash] +getEpochBlocksByPool :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> PoolId -> Eff r [BlockHash] +getEpochProtocolParams :: r <: Blockfrost => r <: Error BlockfrostError => Epoch -> Eff r ProtocolParams + +-- Client.Cardano.Transactions +getTx :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r Transaction +getTxUtxos :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r TransactionUtxos +getTxRedeemers :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r [TransactionRedeemer] +getTxStakes :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r [TransactionStake] +getTxDelegations :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r [TransactionDelegation] +getTxWithdrawals :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r [TransactionWithdrawal] +getTxMirs :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r [TransactionMir] +getTxPoolUpdates :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r [TransactionPoolUpdate] +getTxPoolRetiring :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r [TransactionPoolRetiring] +getTxMetadataJSON :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r [TransactionMetaJSON] +getTxMetadataCBOR :: r <: Blockfrost => r <: Error BlockfrostError => TxHash -> Eff r [TransactionMetaCBOR] +submitTx :: r <: Blockfrost => r <: Error BlockfrostError => CBORString -> Eff r TxHash + +-- Client.Cardano.Ledger +getLedgerGenesis :: r <: Blockfrost => r <: Error BlockfrostError => Eff r Genesis + +-- Client.Cardano.Accounts +getAccount :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r AccountInfo +getAccountRewards' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [AccountReward] +getAccountRewards :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [AccountReward] +getAccountHistory' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [AccountHistory] +getAccountHistory :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [AccountHistory] +getAccountDelegations' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [AccountDelegation] +getAccountDelegations :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [AccountDelegation] +getAccountRegistrations' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [AccountRegistration] +getAccountRegistrations :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [AccountRegistration] +getAccountWithdrawals' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [AccountWithdrawal] +getAccountWithdrawals :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [AccountWithdrawal] +getAccountMirs' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [AccountMir] +getAccountMirs :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [AccountMir] +getAccountAssociatedAddresses' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [AddressAssociated] +getAccountAssociatedAddresses :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [AddressAssociated] +getAccountAssociatedAddressesTotal :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r AddressAssociatedTotal +getAccountAssociatedAssets' :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Paged -> SortOrder -> Eff r [Amount] +getAccountAssociatedAssets :: r <: Blockfrost => r <: Error BlockfrostError => Address -> Eff r [Amount] + +-- Client.Cardano.Pools +listPools' :: r <: Blockfrost => r <: Error BlockfrostError => Paged -> SortOrder -> Eff r [PoolId] +listPools :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [PoolId] +listPoolsExtended' :: r <: Blockfrost => r <: Error BlockfrostError => Paged -> SortOrder -> Eff r [Pool] +listPoolsExtended :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [Pool] +listRetiredPools' :: r <: Blockfrost => r <: Error BlockfrostError => Paged -> SortOrder -> Eff r [PoolEpoch] +listRetiredPools :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [PoolEpoch] +listRetiringPools' :: r <: Blockfrost => r <: Error BlockfrostError => Paged -> SortOrder -> Eff r [PoolEpoch] +listRetiringPools :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [PoolEpoch] +getPool :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Eff r PoolInfo +getPoolHistory' :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Paged -> SortOrder -> Eff r [PoolHistory] +getPoolHistory :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Eff r [PoolHistory] +getPoolMetadata :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Eff r (Maybe PoolMetadata) +getPoolRelays :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Eff r [PoolRelay] +getPoolDelegators' :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Paged -> SortOrder -> Eff r [PoolDelegator] +getPoolDelegators :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Eff r [PoolDelegator] +getPoolBlocks' :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Paged -> SortOrder -> Eff r [BlockHash] +getPoolBlocks :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Eff r [BlockHash] +getPoolUpdates' :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Paged -> SortOrder -> Eff r [PoolUpdate] +getPoolUpdates :: r <: Blockfrost => r <: Error BlockfrostError => PoolId -> Eff r [PoolUpdate] + +-- Client.Cardano.Metadata +getTxMetadataLabels' :: r <: Blockfrost => r <: Error BlockfrostError => Paged -> SortOrder -> Eff r [TxMeta] +getTxMetadataLabels :: r <: Blockfrost => r <: Error BlockfrostError => Eff r [TxMeta] +getTxMetadataByLabelJSON' :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Paged -> SortOrder -> Eff r [TxMetaJSON] +getTxMetadataByLabelJSON :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Eff r [TxMetaJSON] +getTxMetadataByLabelCBOR' :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Paged -> SortOrder -> Eff r [TxMetaCBOR] +getTxMetadataByLabelCBOR :: r <: Blockfrost => r <: Error BlockfrostError => Text -> Eff r [TxMetaCBOR] + + +fromEither :: forall e a r. () + => Show e + => r <: Error e + => Either e a + -> Eff r a +fromEither = + either throwError pure + +-- Client +getRoot = fromEither =<< send do BF.GetRoot +getHealth = fromEither =<< send do BF.GetHealth +getClock = fromEither =<< send do BF.GetClock +getMetrics = fromEither =<< send do BF.GetMetrics +getMetricsEndpoints = fromEither =<< send do BF.GetMetricsEndpoints + +-- Client.NutLink +nutlinkListAddress a = fromEither =<< send do BF.NutlinkListAddress a +nutlinkListAddressTickers' a b c = fromEither =<< send do BF.NutlinkListAddressTickers' a b c +nutlinkListAddressTickers a = fromEither =<< send do BF.NutlinkListAddressTickers a +nutlinkAddressTickers' a b c d = fromEither =<< send do BF.NutlinkAddressTickers' a b c d +nutlinkAddressTickers a b = fromEither =<< send do BF.NutlinkAddressTickers a b +nutlinkTickers' a b c = fromEither =<< send do BF.NutlinkTickers' a b c +nutlinkTickers a = fromEither =<< send do BF.NutlinkTickers a + +-- -- Client.IPFS +ipfsGateway a = fromEither =<< send do BF.IpfsGateway a +ipfsPin a = fromEither =<< send do BF.IpfsPin a +ipfsListPins' a b = fromEither =<< send do BF.IpfsListPins' a b +ipfsListPins = fromEither =<< send do BF.IpfsListPins +ipfsGetPin a = fromEither =<< send do BF.IpfsGetPin a +ipfsRemovePin a = fromEither =<< send do BF.IpfsRemovePin a + +-- Client.Cardano.Blocks +getLatestBlock = fromEither =<< send do BF.GetLatestBlock +getLatestBlockTxs' a b = fromEither =<< send do BF.GetLatestBlockTxs' a b +getLatestBlockTxs = fromEither =<< send do BF.GetLatestBlockTxs +getBlock a = fromEither =<< send do BF.GetBlock a +getBlockSlot a = fromEither =<< send do BF.GetBlockSlot a +getBlockEpochSlot a b = fromEither =<< send do BF.GetBlockEpochSlot a b +getNextBlocks' a b = fromEither =<< send do BF.GetNextBlocks' a b +getNextBlocks a = fromEither =<< send do BF.GetNextBlocks a +getPreviousBlocks' a b = fromEither =<< send do BF.GetPreviousBlocks' a b +getPreviousBlocks a = fromEither =<< send do BF.GetPreviousBlocks a +getBlockTxs' a b c = fromEither =<< send do BF.GetBlockTxs' a b c +getBlockTxs a = fromEither =<< send do BF.GetBlockTxs a +getBlockAffectedAddresses' a b = fromEither =<< send do BF.GetBlockAffectedAddresses' a b +getBlockAffectedAddresses a = fromEither =<< send do BF.GetBlockAffectedAddresses a + +-- -- Client.Cardano.Network +getNetworkInfo = fromEither =<< send do BF.GetNetworkInfo +getNetworkEras = fromEither =<< send do BF.GetNetworkEras + +-- Client.Cardano.Addresses +getAddressInfo a = fromEither =<< send do BF.GetAddressInfo a +getAddressInfoExtended a = fromEither =<< send do BF.GetAddressInfoExtended a +getAddressDetails a = fromEither =<< send do BF.GetAddressDetails a +getAddressUtxos' a b c = fromEither =<< send do BF.GetAddressUtxos' a b c +getAddressUtxos a = fromEither =<< send do BF.GetAddressUtxos a +getAddressUtxosAsset' a b c d = fromEither =<< send do BF.GetAddressUtxosAsset' a b c d +getAddressUtxosAsset a b = fromEither =<< send do BF.GetAddressUtxosAsset a b +getAddressTransactions a = fromEither =<< send do BF.GetAddressTransactions a +getAddressTransactions' a b c d e = fromEither =<< send do BF.GetAddressTransactions' a b c d e + +-- Client.Cardano.Assets +getAssets' a b = fromEither =<< send do BF.GetAssets' a b +getAssets = fromEither =<< send do BF.GetAssets +getAssetDetails a = fromEither =<< send do BF.GetAssetDetails a +getAssetHistory' a b c = fromEither =<< send do BF.GetAssetHistory' a b c +getAssetHistory a = fromEither =<< send do BF.GetAssetHistory a +getAssetTransactions' a b c = fromEither =<< send do BF.GetAssetTransactions' a b c +getAssetTransactions a = fromEither =<< send do BF.GetAssetTransactions a +getAssetAddresses' a b c = fromEither =<< send do BF.GetAssetAddresses' a b c +getAssetAddresses a = fromEither =<< send do BF.GetAssetAddresses a +getAssetsByPolicy' a b c = fromEither =<< send do BF.GetAssetsByPolicy' a b c +getAssetsByPolicy a = fromEither =<< send do BF.GetAssetsByPolicy a + +-- Client.Cardano.Scripts +listScripts' a b = fromEither =<< send do BF.ListScripts' a b +listScripts = fromEither =<< send do BF.ListScripts +getScript a = fromEither =<< send do BF.GetScript a +getScriptRedeemers' a b c = fromEither =<< send do BF.GetScriptRedeemers' a b c +getScriptRedeemers a = fromEither =<< send do BF.GetScriptRedeemers a +getScriptDatum a = fromEither =<< send do BF.GetScriptDatum a +getScriptDatumCBOR a = fromEither =<< send do BF.GetScriptDatumCBOR a +getScriptJSON a = fromEither =<< send do BF.GetScriptJSON a +getScriptCBOR a = fromEither =<< send do BF.GetScriptCBOR a + +-- Client.Cardano.Epochs +getLatestEpoch = fromEither =<< send do BF.GetLatestEpoch +getLatestEpochProtocolParams = fromEither =<< send do BF.GetLatestEpochProtocolParams +getEpoch a = fromEither =<< send do BF.GetEpoch a +getNextEpochs' a b = fromEither =<< send do BF.GetNextEpochs' a b +getNextEpochs a = fromEither =<< send do BF.GetNextEpochs a +getPreviousEpochs' a b = fromEither =<< send do BF.GetPreviousEpochs' a b +getPreviousEpochs a = fromEither =<< send do BF.GetPreviousEpochs a +getEpochStake' a b = fromEither =<< send do BF.GetEpochStake' a b +getEpochStake a = fromEither =<< send do BF.GetEpochStake a +getEpochStakeByPool' a b c = fromEither =<< send do BF.GetEpochStakeByPool' a b c +getEpochStakeByPool a b = fromEither =<< send do BF.GetEpochStakeByPool a b +getEpochBlocks' a b c = fromEither =<< send do BF.GetEpochBlocks' a b c +getEpochBlocks a = fromEither =<< send do BF.GetEpochBlocks a +getEpochBlocksByPool' a b c d = fromEither =<< send do BF.GetEpochBlocksByPool' a b c d +getEpochBlocksByPool a b = fromEither =<< send do BF.GetEpochBlocksByPool a b +getEpochProtocolParams a = fromEither =<< send do BF.GetEpochProtocolParams a + +-- Client.Cardano.Transactions +getTx a = fromEither =<< send do BF.GetTx a +getTxUtxos a = fromEither =<< send do BF.GetTxUtxos a +getTxRedeemers a = fromEither =<< send do BF.GetTxRedeemers a +getTxStakes a = fromEither =<< send do BF.GetTxStakes a +getTxDelegations a = fromEither =<< send do BF.GetTxDelegations a +getTxWithdrawals a = fromEither =<< send do BF.GetTxWithdrawals a +getTxMirs a = fromEither =<< send do BF.GetTxMirs a +getTxPoolUpdates a = fromEither =<< send do BF.GetTxPoolUpdates a +getTxPoolRetiring a = fromEither =<< send do BF.GetTxPoolRetiring a +getTxMetadataJSON a = fromEither =<< send do BF.GetTxMetadataJSON a +getTxMetadataCBOR a = fromEither =<< send do BF.GetTxMetadataCBOR a +submitTx a = fromEither =<< send do BF.SubmitTx a + +-- Client.Cardano.Ledger +getLedgerGenesis = fromEither =<< send do BF.GetLedgerGenesis + +-- Client.Cardano.Accounts +getAccount a = fromEither =<< send do BF.GetAccount a +getAccountRewards' a b c = fromEither =<< send do BF.GetAccountRewards' a b c +getAccountRewards a = fromEither =<< send do BF.GetAccountRewards a +getAccountHistory' a b c = fromEither =<< send do BF.GetAccountHistory' a b c +getAccountHistory a = fromEither =<< send do BF.GetAccountHistory a +getAccountDelegations' a b c = fromEither =<< send do BF.GetAccountDelegations' a b c +getAccountDelegations a = fromEither =<< send do BF.GetAccountDelegations a +getAccountRegistrations' a b c = fromEither =<< send do BF.GetAccountRegistrations' a b c +getAccountRegistrations a = fromEither =<< send do BF.GetAccountRegistrations a +getAccountWithdrawals' a b c = fromEither =<< send do BF.GetAccountWithdrawals' a b c +getAccountWithdrawals a = fromEither =<< send do BF.GetAccountWithdrawals a +getAccountMirs' a b c = fromEither =<< send do BF.GetAccountMirs' a b c +getAccountMirs a = fromEither =<< send do BF.GetAccountMirs a +getAccountAssociatedAddresses' a b c = fromEither =<< send do BF.GetAccountAssociatedAddresses' a b c +getAccountAssociatedAddresses a = fromEither =<< send do BF.GetAccountAssociatedAddresses a +getAccountAssociatedAddressesTotal a = fromEither =<< send do BF.GetAccountAssociatedAddressesTotal a +getAccountAssociatedAssets' a b c = fromEither =<< send do BF.GetAccountAssociatedAssets' a b c +getAccountAssociatedAssets a = fromEither =<< send do BF.GetAccountAssociatedAssets a + +-- Client.Cardano.Pools +listPools' a b = fromEither =<< send do BF.ListPools' a b +listPools = fromEither =<< send do BF.ListPools +listPoolsExtended' a b = fromEither =<< send do BF.ListPoolsExtended' a b +listPoolsExtended = fromEither =<< send do BF.ListPoolsExtended +listRetiredPools' a b = fromEither =<< send do BF.ListRetiredPools' a b +listRetiredPools = fromEither =<< send do BF.ListRetiredPools +listRetiringPools' a b = fromEither =<< send do BF.ListRetiringPools' a b +listRetiringPools = fromEither =<< send do BF.ListRetiringPools +getPool a = fromEither =<< send do BF.GetPool a +getPoolHistory' a b c = fromEither =<< send do BF.GetPoolHistory' a b c +getPoolHistory a = fromEither =<< send do BF.GetPoolHistory a +getPoolMetadata a = fromEither =<< send do BF.GetPoolMetadata a +getPoolRelays a = fromEither =<< send do BF.GetPoolRelays a +getPoolDelegators' a b c = fromEither =<< send do BF.GetPoolDelegators' a b c +getPoolDelegators a = fromEither =<< send do BF.GetPoolDelegators a +getPoolBlocks' a b c = fromEither =<< send do BF.GetPoolBlocks' a b c +getPoolBlocks a = fromEither =<< send do BF.GetPoolBlocks a +getPoolUpdates' a b c = fromEither =<< send do BF.GetPoolUpdates' a b c +getPoolUpdates a = fromEither =<< send do BF.GetPoolUpdates a + +-- Client.Cardano.Metadata +getTxMetadataLabels' a b = fromEither =<< send do BF.GetTxMetadataLabels' a b +getTxMetadataLabels = fromEither =<< send do BF.GetTxMetadataLabels +getTxMetadataByLabelJSON' a b c = fromEither =<< send do BF.GetTxMetadataByLabelJSON' a b c +getTxMetadataByLabelJSON a = fromEither =<< send do BF.GetTxMetadataByLabelJSON a +getTxMetadataByLabelCBOR' a b c = fromEither =<< send do BF.GetTxMetadataByLabelCBOR' a b c +getTxMetadataByLabelCBOR a = fromEither =<< send do BF.GetTxMetadataByLabelCBOR a diff --git a/components/blockfrost/Effectful/Zoo/Blockfrost/Dynamic.hs b/components/blockfrost/Effectful/Zoo/Blockfrost/Dynamic.hs new file mode 100644 --- /dev/null +++ b/components/blockfrost/Effectful/Zoo/Blockfrost/Dynamic.hs @@ -0,0 +1,364 @@ +{- HLINT ignore "Redundant $" -} + +module Effectful.Zoo.Blockfrost.Dynamic where + +import Blockfrost.Client (BlockfrostError, Project) +import Blockfrost.Client qualified as BF +import Blockfrost.Types +import Blockfrost.Util.Pagination +import Blockfrost.Util.Sorting +import Data.Either +import Data.Maybe +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Reader.Dynamic +import Effectful.Zoo.Core +import HaskellWorks.Prelude + +data Blockfrost :: Effect where + + -- Client + GetRoot :: Blockfrost m (Either BlockfrostError URLVersion) + GetHealth :: Blockfrost m (Either BlockfrostError Healthy) + GetClock :: Blockfrost m (Either BlockfrostError ServerTime) + GetMetrics :: Blockfrost m (Either BlockfrostError [Metric]) + GetMetricsEndpoints :: Blockfrost m (Either BlockfrostError [(Text, Metric)]) + + -- Client.NutLink + NutlinkListAddress :: Address -> Blockfrost m (Either BlockfrostError NutlinkAddress) + NutlinkListAddressTickers' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [NutlinkAddressTicker]) + NutlinkListAddressTickers :: Address -> Blockfrost m (Either BlockfrostError [NutlinkAddressTicker]) + NutlinkAddressTickers' :: Address -> Text -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [NutlinkTicker]) + NutlinkAddressTickers :: Address -> Text -> Blockfrost m (Either BlockfrostError [NutlinkTicker]) + NutlinkTickers' :: Text -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [(Address, NutlinkTicker)]) + NutlinkTickers :: Text -> Blockfrost m (Either BlockfrostError [(Address, NutlinkTicker)]) + + -- Client.IPFS + IpfsGateway :: Text -> Blockfrost m (Either BlockfrostError IPFSData) + IpfsPin :: Text -> Blockfrost m (Either BlockfrostError IPFSPinChange) + IpfsListPins' :: Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [IPFSPin]) + IpfsListPins :: Blockfrost m (Either BlockfrostError [IPFSPin]) + IpfsGetPin :: Text -> Blockfrost m (Either BlockfrostError IPFSPin) + IpfsRemovePin :: Text -> Blockfrost m (Either BlockfrostError IPFSPinChange) + + -- Client.Cardano.Blocks + GetLatestBlock :: Blockfrost m (Either BlockfrostError Block) + GetLatestBlockTxs' :: Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [TxHash]) + GetLatestBlockTxs :: Blockfrost m (Either BlockfrostError [TxHash]) + GetBlock :: Either Integer BlockHash -> Blockfrost m (Either BlockfrostError Block) + GetBlockSlot :: Slot -> Blockfrost m (Either BlockfrostError Block) + GetBlockEpochSlot :: Epoch -> Slot -> Blockfrost m (Either BlockfrostError Block) + GetNextBlocks' :: Either Integer BlockHash -> Paged -> Blockfrost m (Either BlockfrostError [Block]) + GetNextBlocks :: Either Integer BlockHash -> Blockfrost m (Either BlockfrostError [Block]) + GetPreviousBlocks' :: Either Integer BlockHash -> Paged -> Blockfrost m (Either BlockfrostError [Block]) + GetPreviousBlocks :: Either Integer BlockHash -> Blockfrost m (Either BlockfrostError [Block]) + GetBlockTxs' :: Either Integer BlockHash -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [TxHash]) + GetBlockTxs :: Either Integer BlockHash -> Blockfrost m (Either BlockfrostError [TxHash]) + GetBlockAffectedAddresses' :: Either Integer BlockHash -> Paged -> Blockfrost m (Either BlockfrostError [(Address, [TxHash])]) + GetBlockAffectedAddresses :: Either Integer BlockHash -> Blockfrost m (Either BlockfrostError [(Address, [TxHash])]) + + -- Client.Cardano.Network + GetNetworkInfo :: Blockfrost m (Either BlockfrostError Network) + GetNetworkEras :: Blockfrost m (Either BlockfrostError [NetworkEraSummary]) + + -- Client.Cardano.Addresses + GetAddressInfo :: Address -> Blockfrost m (Either BlockfrostError AddressInfo) + GetAddressInfoExtended :: Address -> Blockfrost m (Either BlockfrostError AddressInfoExtended) + GetAddressDetails :: Address -> Blockfrost m (Either BlockfrostError AddressDetails) + GetAddressUtxos' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AddressUtxo]) + GetAddressUtxos :: Address -> Blockfrost m (Either BlockfrostError [AddressUtxo]) + GetAddressUtxosAsset' :: Address -> AssetId-> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AddressUtxo]) + GetAddressUtxosAsset :: Address -> AssetId -> Blockfrost m (Either BlockfrostError [AddressUtxo]) + GetAddressTransactions' :: Address -> Paged -> SortOrder -> Maybe BlockIndex -> Maybe BlockIndex -> Blockfrost m (Either BlockfrostError [AddressTransaction]) + GetAddressTransactions :: Address -> Blockfrost m (Either BlockfrostError [AddressTransaction]) + + -- Client.Cardano.Assets + GetAssets' :: Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AssetInfo]) + GetAssets :: Blockfrost m (Either BlockfrostError [AssetInfo]) + GetAssetDetails :: AssetId -> Blockfrost m (Either BlockfrostError AssetDetails) + GetAssetHistory' :: AssetId -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AssetHistory]) + GetAssetHistory :: AssetId -> Blockfrost m (Either BlockfrostError [AssetHistory]) + GetAssetTransactions' :: AssetId -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AssetTransaction]) + GetAssetTransactions :: AssetId -> Blockfrost m (Either BlockfrostError [AssetTransaction]) + GetAssetAddresses' :: AssetId -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AssetAddress]) + GetAssetAddresses :: AssetId -> Blockfrost m (Either BlockfrostError [AssetAddress]) + GetAssetsByPolicy' :: PolicyId -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AssetInfo]) + GetAssetsByPolicy :: PolicyId -> Blockfrost m (Either BlockfrostError [AssetInfo]) + + -- Client.Cardano.Scripts + ListScripts' :: Paged -> SortOrder -> Blockfrost m (Either BlockfrostError ScriptHashList) + ListScripts :: Blockfrost m (Either BlockfrostError ScriptHashList) + GetScript :: ScriptHash -> Blockfrost m (Either BlockfrostError Script) + GetScriptRedeemers' :: ScriptHash -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [ScriptRedeemer]) + GetScriptRedeemers :: ScriptHash -> Blockfrost m (Either BlockfrostError [ScriptRedeemer]) + GetScriptDatum :: DatumHash -> Blockfrost m (Either BlockfrostError ScriptDatum) + GetScriptDatumCBOR :: DatumHash -> Blockfrost m (Either BlockfrostError ScriptDatumCBOR) + GetScriptJSON :: ScriptHash -> Blockfrost m (Either BlockfrostError ScriptJSON) + GetScriptCBOR :: ScriptHash -> Blockfrost m (Either BlockfrostError ScriptCBOR) + + -- Client.Cardano.Epochs + GetLatestEpoch :: Blockfrost m (Either BlockfrostError EpochInfo) + GetLatestEpochProtocolParams :: Blockfrost m (Either BlockfrostError ProtocolParams) + GetEpoch :: Epoch -> Blockfrost m (Either BlockfrostError EpochInfo) + GetNextEpochs' :: Epoch -> Paged -> Blockfrost m (Either BlockfrostError [EpochInfo]) + GetNextEpochs :: Epoch -> Blockfrost m (Either BlockfrostError [EpochInfo]) + GetPreviousEpochs' :: Epoch -> Paged -> Blockfrost m (Either BlockfrostError [EpochInfo]) + GetPreviousEpochs :: Epoch -> Blockfrost m (Either BlockfrostError [EpochInfo]) + GetEpochStake' :: Epoch -> Paged -> Blockfrost m (Either BlockfrostError [StakeDistribution]) + GetEpochStake :: Epoch -> Blockfrost m (Either BlockfrostError [StakeDistribution]) + GetEpochStakeByPool' :: Epoch -> PoolId -> Paged -> Blockfrost m (Either BlockfrostError [PoolStakeDistribution]) + GetEpochStakeByPool :: Epoch -> PoolId -> Blockfrost m (Either BlockfrostError [PoolStakeDistribution]) + GetEpochBlocks' :: Epoch -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [BlockHash]) + GetEpochBlocks :: Epoch -> Blockfrost m (Either BlockfrostError [BlockHash]) + GetEpochBlocksByPool' :: Epoch -> PoolId -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [BlockHash]) + GetEpochBlocksByPool :: Epoch -> PoolId -> Blockfrost m (Either BlockfrostError [BlockHash]) + GetEpochProtocolParams :: Epoch -> Blockfrost m (Either BlockfrostError ProtocolParams) + + -- Client.Cardano.Transactions + GetTx :: TxHash -> Blockfrost m (Either BlockfrostError Transaction) + GetTxUtxos :: TxHash -> Blockfrost m (Either BlockfrostError TransactionUtxos) + GetTxRedeemers :: TxHash -> Blockfrost m (Either BlockfrostError [TransactionRedeemer]) + GetTxStakes :: TxHash -> Blockfrost m (Either BlockfrostError [TransactionStake]) + GetTxDelegations :: TxHash -> Blockfrost m (Either BlockfrostError [TransactionDelegation]) + GetTxWithdrawals :: TxHash -> Blockfrost m (Either BlockfrostError [TransactionWithdrawal]) + GetTxMirs :: TxHash -> Blockfrost m (Either BlockfrostError [TransactionMir]) + GetTxPoolUpdates :: TxHash -> Blockfrost m (Either BlockfrostError [TransactionPoolUpdate]) + GetTxPoolRetiring :: TxHash -> Blockfrost m (Either BlockfrostError [TransactionPoolRetiring]) + GetTxMetadataJSON :: TxHash -> Blockfrost m (Either BlockfrostError [TransactionMetaJSON]) + GetTxMetadataCBOR :: TxHash -> Blockfrost m (Either BlockfrostError [TransactionMetaCBOR]) + SubmitTx :: CBORString -> Blockfrost m (Either BlockfrostError TxHash) + + -- Client.Cardano.Ledger + GetLedgerGenesis :: Blockfrost m (Either BlockfrostError Genesis) + + -- Client.Cardano.Accounts + GetAccount :: Address -> Blockfrost m (Either BlockfrostError AccountInfo) + GetAccountRewards' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AccountReward]) + GetAccountRewards :: Address -> Blockfrost m (Either BlockfrostError [AccountReward]) + GetAccountHistory' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AccountHistory]) + GetAccountHistory :: Address -> Blockfrost m (Either BlockfrostError [AccountHistory]) + GetAccountDelegations' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AccountDelegation]) + GetAccountDelegations :: Address -> Blockfrost m (Either BlockfrostError [AccountDelegation]) + GetAccountRegistrations' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AccountRegistration]) + GetAccountRegistrations :: Address -> Blockfrost m (Either BlockfrostError [AccountRegistration]) + GetAccountWithdrawals' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AccountWithdrawal]) + GetAccountWithdrawals :: Address -> Blockfrost m (Either BlockfrostError [AccountWithdrawal]) + GetAccountMirs' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AccountMir]) + GetAccountMirs :: Address -> Blockfrost m (Either BlockfrostError [AccountMir]) + GetAccountAssociatedAddresses' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [AddressAssociated]) + GetAccountAssociatedAddresses :: Address -> Blockfrost m (Either BlockfrostError [AddressAssociated]) + GetAccountAssociatedAddressesTotal :: Address -> Blockfrost m (Either BlockfrostError AddressAssociatedTotal) + GetAccountAssociatedAssets' :: Address -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [Amount]) + GetAccountAssociatedAssets :: Address -> Blockfrost m (Either BlockfrostError [Amount]) + + -- Client.Cardano.Pools + ListPools' :: Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [PoolId]) + ListPools :: Blockfrost m (Either BlockfrostError [PoolId]) + ListPoolsExtended' :: Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [Pool]) + ListPoolsExtended :: Blockfrost m (Either BlockfrostError [Pool]) + ListRetiredPools' :: Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [PoolEpoch]) + ListRetiredPools :: Blockfrost m (Either BlockfrostError [PoolEpoch]) + ListRetiringPools' :: Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [PoolEpoch]) + ListRetiringPools :: Blockfrost m (Either BlockfrostError [PoolEpoch]) + GetPool :: PoolId -> Blockfrost m (Either BlockfrostError PoolInfo) + GetPoolHistory' :: PoolId -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [PoolHistory]) + GetPoolHistory :: PoolId -> Blockfrost m (Either BlockfrostError [PoolHistory]) + GetPoolMetadata :: PoolId -> Blockfrost m (Either BlockfrostError (Maybe PoolMetadata)) + GetPoolRelays :: PoolId -> Blockfrost m (Either BlockfrostError [PoolRelay]) + GetPoolDelegators' :: PoolId -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [PoolDelegator]) + GetPoolDelegators :: PoolId -> Blockfrost m (Either BlockfrostError [PoolDelegator]) + GetPoolBlocks' :: PoolId -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [BlockHash]) + GetPoolBlocks :: PoolId -> Blockfrost m (Either BlockfrostError [BlockHash]) + GetPoolUpdates' :: PoolId -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [PoolUpdate]) + GetPoolUpdates :: PoolId -> Blockfrost m (Either BlockfrostError [PoolUpdate]) + + -- Client.Cardano.Metadata + GetTxMetadataLabels' :: Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [TxMeta]) + GetTxMetadataLabels :: Blockfrost m (Either BlockfrostError [TxMeta]) + GetTxMetadataByLabelJSON' :: Text -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [TxMetaJSON]) + GetTxMetadataByLabelJSON :: Text -> Blockfrost m (Either BlockfrostError [TxMetaJSON]) + GetTxMetadataByLabelCBOR' :: Text -> Paged -> SortOrder -> Blockfrost m (Either BlockfrostError [TxMetaCBOR]) + GetTxMetadataByLabelCBOR :: Text -> Blockfrost m (Either BlockfrostError [TxMetaCBOR]) + +type instance DispatchOf (Blockfrost) = Dynamic + +callBlockfrost :: () + => r <: Reader Project + => r <: IOE + => BF.BlockfrostClientT IO b + -> Eff r (Either BlockfrostError b) +callBlockfrost f = do + project <- ask @Project + liftIO (BF.runBlockfrost project f) + +runBlockfrost :: () + => r <: IOE + => r <: Reader Project + => Eff (Blockfrost ': r) a + -> Eff r a +runBlockfrost h = + interpret + do \_ -> \case + -- Client + GetRoot -> callBlockfrost $ BF.getRoot + GetHealth -> callBlockfrost $ BF.getHealth + GetClock -> callBlockfrost $ BF.getClock + GetMetrics -> callBlockfrost $ BF.getMetrics + GetMetricsEndpoints -> callBlockfrost $ BF.getMetricsEndpoints + + -- Client.NutLink + NutlinkListAddress a -> callBlockfrost $ BF.nutlinkListAddress a + NutlinkListAddressTickers' a b c -> callBlockfrost $ BF.nutlinkListAddressTickers' a b c + NutlinkListAddressTickers a -> callBlockfrost $ BF.nutlinkListAddressTickers a + NutlinkAddressTickers' a b c d -> callBlockfrost $ BF.nutlinkAddressTickers' a b c d + NutlinkAddressTickers a b -> callBlockfrost $ BF.nutlinkAddressTickers a b + NutlinkTickers' a b c -> callBlockfrost $ BF.nutlinkTickers' a b c + NutlinkTickers a -> callBlockfrost $ BF.nutlinkTickers a + + -- -- Client.IPFS + IpfsGateway a -> callBlockfrost $ BF.ipfsGateway a + IpfsPin a -> callBlockfrost $ BF.ipfsPin a + IpfsListPins' a b -> callBlockfrost $ BF.ipfsListPins' a b + IpfsListPins -> callBlockfrost $ BF.ipfsListPins + IpfsGetPin a -> callBlockfrost $ BF.ipfsGetPin a + IpfsRemovePin a -> callBlockfrost $ BF.ipfsRemovePin a + + -- Client.Cardano.Blocks + GetLatestBlock -> callBlockfrost $ BF.getLatestBlock + GetLatestBlockTxs' a b -> callBlockfrost $ BF.getLatestBlockTxs' a b + GetLatestBlockTxs -> callBlockfrost $ BF.getLatestBlockTxs + GetBlock a -> callBlockfrost $ BF.getBlock a + GetBlockSlot a -> callBlockfrost $ BF.getBlockSlot a + GetBlockEpochSlot a b -> callBlockfrost $ BF.getBlockEpochSlot a b + GetNextBlocks' a b -> callBlockfrost $ BF.getNextBlocks' a b + GetNextBlocks a -> callBlockfrost $ BF.getNextBlocks a + GetPreviousBlocks' a b -> callBlockfrost $ BF.getPreviousBlocks' a b + GetPreviousBlocks a -> callBlockfrost $ BF.getPreviousBlocks a + GetBlockTxs' a b c -> callBlockfrost $ BF.getBlockTxs' a b c + GetBlockTxs a -> callBlockfrost $ BF.getBlockTxs a + GetBlockAffectedAddresses' a b -> callBlockfrost $ BF.getBlockAffectedAddresses' a b + GetBlockAffectedAddresses a -> callBlockfrost $ BF.getBlockAffectedAddresses a + + -- -- Client.Cardano.Network + GetNetworkInfo -> callBlockfrost $ BF.getNetworkInfo + GetNetworkEras -> callBlockfrost $ BF.getNetworkEras + + -- Client.Cardano.Addresses + GetAddressInfo a -> callBlockfrost $ BF.getAddressInfo a + GetAddressInfoExtended a -> callBlockfrost $ BF.getAddressInfoExtended a + GetAddressDetails a -> callBlockfrost $ BF.getAddressDetails a + GetAddressUtxos' a b c -> callBlockfrost $ BF.getAddressUtxos' a b c + GetAddressUtxos a -> callBlockfrost $ BF.getAddressUtxos a + GetAddressUtxosAsset' a b c d -> callBlockfrost $ BF.getAddressUtxosAsset' a b c d + GetAddressUtxosAsset a b -> callBlockfrost $ BF.getAddressUtxosAsset a b + GetAddressTransactions a -> callBlockfrost $ BF.getAddressTransactions a + GetAddressTransactions' a b c d e -> callBlockfrost $ BF.getAddressTransactions' a b c d e + + -- Client.Cardano.Assets + GetAssets' a b -> callBlockfrost $ BF.getAssets' a b + GetAssets -> callBlockfrost $ BF.getAssets + GetAssetDetails a -> callBlockfrost $ BF.getAssetDetails a + GetAssetHistory' a b c -> callBlockfrost $ BF.getAssetHistory' a b c + GetAssetHistory a -> callBlockfrost $ BF.getAssetHistory a + GetAssetTransactions' a b c -> callBlockfrost $ BF.getAssetTransactions' a b c + GetAssetTransactions a -> callBlockfrost $ BF.getAssetTransactions a + GetAssetAddresses' a b c -> callBlockfrost $ BF.getAssetAddresses' a b c + GetAssetAddresses a -> callBlockfrost $ BF.getAssetAddresses a + GetAssetsByPolicy' a b c -> callBlockfrost $ BF.getAssetsByPolicy' a b c + GetAssetsByPolicy a -> callBlockfrost $ BF.getAssetsByPolicy a + + -- Client.Cardano.Scripts + ListScripts' a b -> callBlockfrost $ BF.listScripts' a b + ListScripts -> callBlockfrost $ BF.listScripts + GetScript a -> callBlockfrost $ BF.getScript a + GetScriptRedeemers' a b c -> callBlockfrost $ BF.getScriptRedeemers' a b c + GetScriptRedeemers a -> callBlockfrost $ BF.getScriptRedeemers a + GetScriptDatum a -> callBlockfrost $ BF.getScriptDatum a + GetScriptDatumCBOR a -> callBlockfrost $ BF.getScriptDatumCBOR a + GetScriptJSON a -> callBlockfrost $ BF.getScriptJSON a + GetScriptCBOR a -> callBlockfrost $ BF.getScriptCBOR a + + -- Client.Cardano.Epochs + GetLatestEpoch -> callBlockfrost $ BF.getLatestEpoch + GetLatestEpochProtocolParams -> callBlockfrost $ BF.getLatestEpochProtocolParams + GetEpoch a -> callBlockfrost $ BF.getEpoch a + GetNextEpochs' a b -> callBlockfrost $ BF.getNextEpochs' a b + GetNextEpochs a -> callBlockfrost $ BF.getNextEpochs a + GetPreviousEpochs' a b -> callBlockfrost $ BF.getPreviousEpochs' a b + GetPreviousEpochs a -> callBlockfrost $ BF.getPreviousEpochs a + GetEpochStake' a b -> callBlockfrost $ BF.getEpochStake' a b + GetEpochStake a -> callBlockfrost $ BF.getEpochStake a + GetEpochStakeByPool' a b c -> callBlockfrost $ BF.getEpochStakeByPool' a b c + GetEpochStakeByPool a b -> callBlockfrost $ BF.getEpochStakeByPool a b + GetEpochBlocks' a b c -> callBlockfrost $ BF.getEpochBlocks' a b c + GetEpochBlocks a -> callBlockfrost $ BF.getEpochBlocks a + GetEpochBlocksByPool' a b c d -> callBlockfrost $ BF.getEpochBlocksByPool' a b c d + GetEpochBlocksByPool a b -> callBlockfrost $ BF.getEpochBlocksByPool a b + GetEpochProtocolParams a -> callBlockfrost $ BF.getEpochProtocolParams a + + -- Client.Cardano.Transactions + GetTx a -> callBlockfrost $ BF.getTx a + GetTxUtxos a -> callBlockfrost $ BF.getTxUtxos a + GetTxRedeemers a -> callBlockfrost $ BF.getTxRedeemers a + GetTxStakes a -> callBlockfrost $ BF.getTxStakes a + GetTxDelegations a -> callBlockfrost $ BF.getTxDelegations a + GetTxWithdrawals a -> callBlockfrost $ BF.getTxWithdrawals a + GetTxMirs a -> callBlockfrost $ BF.getTxMirs a + GetTxPoolUpdates a -> callBlockfrost $ BF.getTxPoolUpdates a + GetTxPoolRetiring a -> callBlockfrost $ BF.getTxPoolRetiring a + GetTxMetadataJSON a -> callBlockfrost $ BF.getTxMetadataJSON a + GetTxMetadataCBOR a -> callBlockfrost $ BF.getTxMetadataCBOR a + SubmitTx a -> callBlockfrost $ BF.submitTx a + + -- Client.Cardano.Ledger + GetLedgerGenesis -> callBlockfrost $ BF.getLedgerGenesis + + -- Client.Cardano.Accounts + GetAccount a -> callBlockfrost $ BF.getAccount a + GetAccountRewards' a b c -> callBlockfrost $ BF.getAccountRewards' a b c + GetAccountRewards a -> callBlockfrost $ BF.getAccountRewards a + GetAccountHistory' a b c -> callBlockfrost $ BF.getAccountHistory' a b c + GetAccountHistory a -> callBlockfrost $ BF.getAccountHistory a + GetAccountDelegations' a b c -> callBlockfrost $ BF.getAccountDelegations' a b c + GetAccountDelegations a -> callBlockfrost $ BF.getAccountDelegations a + GetAccountRegistrations' a b c -> callBlockfrost $ BF.getAccountRegistrations' a b c + GetAccountRegistrations a -> callBlockfrost $ BF.getAccountRegistrations a + GetAccountWithdrawals' a b c -> callBlockfrost $ BF.getAccountWithdrawals' a b c + GetAccountWithdrawals a -> callBlockfrost $ BF.getAccountWithdrawals a + GetAccountMirs' a b c -> callBlockfrost $ BF.getAccountMirs' a b c + GetAccountMirs a -> callBlockfrost $ BF.getAccountMirs a + GetAccountAssociatedAddresses' a b c -> callBlockfrost $ BF.getAccountAssociatedAddresses' a b c + GetAccountAssociatedAddresses a -> callBlockfrost $ BF.getAccountAssociatedAddresses a + GetAccountAssociatedAddressesTotal a -> callBlockfrost $ BF.getAccountAssociatedAddressesTotal a + GetAccountAssociatedAssets' a b c -> callBlockfrost $ BF.getAccountAssociatedAssets' a b c + GetAccountAssociatedAssets a -> callBlockfrost $ BF.getAccountAssociatedAssets a + + -- Client.Cardano.Pools + ListPools' a b -> callBlockfrost $ BF.listPools' a b + ListPools -> callBlockfrost $ BF.listPools + ListPoolsExtended' a b -> callBlockfrost $ BF.listPoolsExtended' a b + ListPoolsExtended -> callBlockfrost $ BF.listPoolsExtended + ListRetiredPools' a b -> callBlockfrost $ BF.listRetiredPools' a b + ListRetiredPools -> callBlockfrost $ BF.listRetiredPools + ListRetiringPools' a b -> callBlockfrost $ BF.listRetiringPools' a b + ListRetiringPools -> callBlockfrost $ BF.listRetiringPools + GetPool a -> callBlockfrost $ BF.getPool a + GetPoolHistory' a b c -> callBlockfrost $ BF.getPoolHistory' a b c + GetPoolHistory a -> callBlockfrost $ BF.getPoolHistory a + GetPoolMetadata a -> callBlockfrost $ BF.getPoolMetadata a + GetPoolRelays a -> callBlockfrost $ BF.getPoolRelays a + GetPoolDelegators' a b c -> callBlockfrost $ BF.getPoolDelegators' a b c + GetPoolDelegators a -> callBlockfrost $ BF.getPoolDelegators a + GetPoolBlocks' a b c -> callBlockfrost $ BF.getPoolBlocks' a b c + GetPoolBlocks a -> callBlockfrost $ BF.getPoolBlocks a + GetPoolUpdates' a b c -> callBlockfrost $ BF.getPoolUpdates' a b c + GetPoolUpdates a -> callBlockfrost $ BF.getPoolUpdates a + + -- Client.Cardano.Metadata + GetTxMetadataLabels' a b -> callBlockfrost $ BF.getTxMetadataLabels' a b + GetTxMetadataLabels -> callBlockfrost $ BF.getTxMetadataLabels + GetTxMetadataByLabelJSON' a b c -> callBlockfrost $ BF.getTxMetadataByLabelJSON' a b c + GetTxMetadataByLabelJSON a -> callBlockfrost $ BF.getTxMetadataByLabelJSON a + GetTxMetadataByLabelCBOR' a b c -> callBlockfrost $ BF.getTxMetadataByLabelCBOR' a b c + GetTxMetadataByLabelCBOR a -> callBlockfrost $ BF.getTxMetadataByLabelCBOR a + do h diff --git a/components/blockfrost/Effectful/Zoo/Blockfrost/Types.hs b/components/blockfrost/Effectful/Zoo/Blockfrost/Types.hs new file mode 100644 --- /dev/null +++ b/components/blockfrost/Effectful/Zoo/Blockfrost/Types.hs @@ -0,0 +1,121 @@ +module Effectful.Zoo.Blockfrost.Types + ( Blockfrost(..), + + AccountDelegation(AccountDelegation), + AccountHistory(AccountHistory), + AccountInfo(AccountInfo), + AccountMir(AccountMir), + AccountRegistration(AccountRegistration), + AccountRegistrationAction(..), + AccountReward(AccountReward), + AccountWithdrawal(AccountWithdrawal), + Address(Address), + AddressAssociated(AddressAssociated), + AddressAssociatedTotal(AddressAssociatedTotal), + AddressDetails(AddressDetails), + AddressInfo(AddressInfo), + AddressInfoExtended(AddressInfoExtended), + AddressTransaction(AddressTransaction), + AddressType(..), + AddressUtxo(AddressUtxo), + Amount(..), + AssetAction(..), + AssetAddress(AssetAddress), + AssetDetails(AssetDetails), + AssetHistory(AssetHistory), + AssetId(AssetId), + AssetInfo(AssetInfo), + AssetMetadata(AssetMetadata), + AssetOnChainMetadata(AssetOnChainMetadata), + AssetTransaction(AssetTransaction), + Block(Block), + BlockfrostError(..), + BlockHash(BlockHash), + CBORString(CBORString), + CostModels(CostModels), + DatumHash(DatumHash), + DerivedAddress(DerivedAddress), + Epoch(Epoch), + EpochInfo(EpochInfo), + EpochLength(EpochLength), + Genesis(Genesis), + Healthy(Healthy), + InlineDatum(InlineDatum), + IPFSAdd(IPFSAdd), + IPFSData(IPFSData), + IPFSPin(IPFSPin), + IPFSPinChange(IPFSPinChange), + Lovelaces, + MetadataMediaFile(MetadataMediaFile), + Metric(Metric), + Network(Network), + NetworkEraBound(NetworkEraBound), + NetworkEraParameters(NetworkEraParameters), + NetworkEraSummary(NetworkEraSummary), + NetworkStake(NetworkStake), + NetworkSupply(NetworkSupply), + NutlinkAddress(NutlinkAddress), + NutlinkAddressTicker(NutlinkAddressTicker), + NutlinkTicker(NutlinkTicker), + Paged(Paged), + PinState(..), + PolicyId(PolicyId), + Pool(Pool), + PoolDelegator(PoolDelegator), + PoolEpoch(PoolEpoch), + PoolHistory(PoolHistory), + PoolId(PoolId), + PoolInfo(PoolInfo), + PoolMetadata(PoolMetadata), + PoolRegistrationAction(..), + PoolRelay(PoolRelay), + PoolStakeDistribution(PoolStakeDistribution), + PoolUpdate(PoolUpdate), + PoolUpdateMetadata(PoolUpdateMetadata), + POSIXMillis, + Pot(..), + Project(Project), + ProtocolParams(ProtocolParams), + Quantity(Quantity), + RewardType(..), + Script(Script), + ScriptCBOR(ScriptCBOR), + ScriptDatum(ScriptDatum), + ScriptDatumCBOR(ScriptDatumCBOR), + ScriptHash(ScriptHash), + ScriptHashList(ScriptHashList), + ScriptJSON(ScriptJSON), + ScriptRedeemer(ScriptRedeemer), + ScriptType(..) , + ServerTime(ServerTime), + Slot(Slot), + SortOrder(..), + StakeDistribution(StakeDistribution), + ToLower, + Transaction(Transaction), + TransactionDelegation(TransactionDelegation), + TransactionMetaCBOR(TransactionMetaCBOR), + TransactionMetaJSON(TransactionMetaJSON), + TransactionMir(TransactionMir), + TransactionPoolRetiring(TransactionPoolRetiring), + TransactionPoolUpdate(TransactionPoolUpdate), + TransactionRedeemer(TransactionRedeemer), + TransactionStake(TransactionStake), + TransactionUtxos(TransactionUtxos), + TransactionWithdrawal(TransactionWithdrawal), + TxEval(TxEval), + TxEvalBudget(TxEvalBudget), + TxEvalInput(TxEvalInput), + TxHash(TxHash), + TxMeta(TxMeta), + TxMetaCBOR(TxMetaCBOR), + TxMetaJSON(TxMetaJSON), + URLVersion(URLVersion), + UtxoInput(UtxoInput), + UtxoOutput(UtxoOutput), + ValidationPurpose(..), + ) where + +import Blockfrost.Client + +import Effectful.Zoo.Blockfrost.Dynamic diff --git a/components/console/Effectful/Zoo/Console/Data/Writer.hs b/components/console/Effectful/Zoo/Console/Data/Writer.hs deleted file mode 100644 --- a/components/console/Effectful/Zoo/Console/Data/Writer.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Effectful.Zoo.Console.Data.Writer - ( Writer(..), - mkWriter, - ) where - -import Effectful -import Effectful.Zoo.Core -import HaskellWorks.Prelude - -newtype Writer i = Writer - { run :: i -> IO () - } deriving stock Generic - -instance Contravariant Writer where - contramap f (Writer g) = Writer (g . f) - -mkWriter :: () - => r <: IOE - => UnliftStrategy - -> (i -> Eff r ()) - -> Eff r (Writer i) -mkWriter strategy run = - withEffToIO strategy $ \effToIO -> - pure $ Writer $ effToIO . run diff --git a/components/console/Effectful/Zoo/Console/Dynamic.hs b/components/console/Effectful/Zoo/Console/Dynamic.hs deleted file mode 100644 --- a/components/console/Effectful/Zoo/Console/Dynamic.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Effectful.Zoo.Console.Dynamic - ( Console (..), - - runConsole, - runConsoleBrackedToConsole, - runConsoleAtomic, - - print, - ) where - -import Effectful.Zoo.Console.Dynamic.Api -import Effectful.Zoo.Console.Dynamic.Run diff --git a/components/console/Effectful/Zoo/Console/Dynamic/Api.hs b/components/console/Effectful/Zoo/Console/Dynamic/Api.hs deleted file mode 100644 --- a/components/console/Effectful/Zoo/Console/Dynamic/Api.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Effectful.Zoo.Console.Dynamic.Api - ( Console (..), - print, - ) where - -import Effectful -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.Console.Dynamic.Effect -import Effectful.Zoo.Core -import HaskellWorks.Prelude - -print :: () - => HasCallStack - => r <: Console i - => i - -> Eff r () -print i = - send $ Print i diff --git a/components/console/Effectful/Zoo/Console/Dynamic/Effect.hs b/components/console/Effectful/Zoo/Console/Dynamic/Effect.hs deleted file mode 100644 --- a/components/console/Effectful/Zoo/Console/Dynamic/Effect.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Effectful.Zoo.Console.Dynamic.Effect - ( Console (..), - ) where - -import Effectful - -data Console a :: Effect where - Print - :: a - -> Console a m () - - Local - :: (a -> a) - -> m b - -> Console a m b - -type instance DispatchOf (Console a) = Dynamic diff --git a/components/console/Effectful/Zoo/Console/Dynamic/Run.hs b/components/console/Effectful/Zoo/Console/Dynamic/Run.hs deleted file mode 100644 --- a/components/console/Effectful/Zoo/Console/Dynamic/Run.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Effectful.Zoo.Console.Dynamic.Run - ( Console (..), - runConsole, - runConsoleBrackedToConsole, - runConsoleAtomic, - ) where - -import Effectful -import Effectful.Exception -import Effectful.Concurrent.QSem -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.Console.Dynamic.Effect -import Effectful.Zoo.Core -import Effectful.Zoo.Console.Static qualified as S -import HaskellWorks.Prelude - -runConsole :: () - => HasCallStack - => r <: IOE - => UnliftStrategy - -> (HasCallStack => i -> Eff r ()) - -> Eff (Console i : r) a - -> Eff r a -runConsole s run = - reinterpret (S.runConsole s run) $ \env -> \case - Print i -> S.print i - Local f m -> localSeqUnlift env $ \unlift -> S.local f (unlift m) - -runConsoleBrackedToConsole :: () - => HasCallStack - => r <: Console i - => Eff r b - -> Eff r c - -> Eff (Console i : r) a - -> Eff r a -runConsoleBrackedToConsole before after = - interpret $ \env -> \case - Print i -> - bracket_ before after $ - send $ Print i - Local f m -> - bracket_ before after $ - localSeqUnlift env $ \unlift -> send $ Local f (unlift m) - -runConsoleAtomic :: () - => HasCallStack - => r <: Concurrent - => r <: Console i - => Eff (Console i : r) a - -> Eff r a -runConsoleAtomic f = do - qsem <- newQSem 1 - runConsoleBrackedToConsole (waitQSem qsem) (signalQSem qsem) f diff --git a/components/console/Effectful/Zoo/Console/Effect.hs b/components/console/Effectful/Zoo/Console/Effect.hs deleted file mode 100644 --- a/components/console/Effectful/Zoo/Console/Effect.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Effectful.Zoo.Console.Effect - ( Console, - ) where - -import Effectful.Console.ByteString diff --git a/components/console/Effectful/Zoo/Console/Static.hs b/components/console/Effectful/Zoo/Console/Static.hs deleted file mode 100644 --- a/components/console/Effectful/Zoo/Console/Static.hs +++ /dev/null @@ -1,103 +0,0 @@ -module Effectful.Zoo.Console.Static - ( Console, - runConsole, - runConsoleTextToHandle, - runConsoleTextToStdout, - runConsoleTextToStderr, - withConsole, - print, - local, - ) where - -import Data.Text.IO qualified as T -import Data.Kind -import Effectful -import Effectful.Zoo.Console.Data.Writer -import Effectful.Zoo.Core -import Effectful.Dispatch.Static -import HaskellWorks.Prelude -import System.IO qualified as IO - -data Console (i :: Type) :: Effect - -type instance DispatchOf (Console i) = Static NoSideEffects - -newtype instance StaticRep (Console i) = Console (Writer i) - -runConsole :: () - => r <: IOE - => HasCallStack - => UnliftStrategy - -> (HasCallStack => i -> Eff r ()) - -> Eff (Console i : r) a - -> Eff r a -runConsole strategy run f = do - s <- mkWriter strategy run - evalStaticRep (Console s) f - -runConsoleTextToHandle :: () - => HasCallStack - => Handle - -> Eff (Console Text : r) a - -> Eff r a -runConsoleTextToHandle h = - evalStaticRep $ Console $ Writer $ T.hPutStrLn h - -runConsoleTextToStdout :: () - => HasCallStack - => Eff (Console Text : r) a - -> Eff r a -runConsoleTextToStdout = - runConsoleTextToHandle IO.stdout - -runConsoleTextToStderr :: () - => HasCallStack - => Eff (Console Text : r) a - -> Eff r a -runConsoleTextToStderr = - runConsoleTextToHandle IO.stderr - -withConsoleSerialiser :: () - => HasCallStack - => (Writer i -> Writer o) - -> Eff (Console o : r) a - -> Eff (Console i : r) a -withConsoleSerialiser f m = do - writer <- getWriter - let _ = writer - raise $ evalStaticRep (Console (f writer)) m - -withConsole :: () - => HasCallStack - => (o -> i) - -> Eff (Console o : r) a - -> Eff (Console i : r) a -withConsole = - withConsoleSerialiser . contramap - -getWriter :: () - => HasCallStack - => r <: Console i - => Eff r (Writer i) -getWriter = do - Console i <- getStaticRep - pure i - -print :: () - => HasCallStack - => r <: Console i - => r <: IOE - => i - -> Eff r () -print i = do - writer <- getWriter - liftIO $ writer.run i - -local :: () - => HasCallStack - => r <: Console i - => (i -> i) - -> Eff r a - -> Eff r a -local f = - localStaticRep $ \(Console s) -> Console (contramap f s) diff --git a/components/core/Effectful/Zoo/Console/Data/Writer.hs b/components/core/Effectful/Zoo/Console/Data/Writer.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Console/Data/Writer.hs @@ -0,0 +1,24 @@ +module Effectful.Zoo.Console.Data.Writer + ( Writer(..), + mkWriter, + ) where + +import Effectful +import Effectful.Zoo.Core +import HaskellWorks.Prelude + +newtype Writer i = Writer + { run :: i -> IO () + } deriving stock Generic + +instance Contravariant Writer where + contramap f (Writer g) = Writer (g . f) + +mkWriter :: () + => r <: IOE + => UnliftStrategy + -> (i -> Eff r ()) + -> Eff r (Writer i) +mkWriter strategy run = + withEffToIO strategy $ \effToIO -> + pure $ Writer $ effToIO . run diff --git a/components/core/Effectful/Zoo/Console/Dynamic.hs b/components/core/Effectful/Zoo/Console/Dynamic.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Console/Dynamic.hs @@ -0,0 +1,12 @@ +module Effectful.Zoo.Console.Dynamic + ( Console (..), + + runConsole, + runConsoleBrackedToConsole, + runConsoleAtomic, + + print, + ) where + +import Effectful.Zoo.Console.Dynamic.Api +import Effectful.Zoo.Console.Dynamic.Run diff --git a/components/core/Effectful/Zoo/Console/Dynamic/Api.hs b/components/core/Effectful/Zoo/Console/Dynamic/Api.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Console/Dynamic/Api.hs @@ -0,0 +1,18 @@ +module Effectful.Zoo.Console.Dynamic.Api + ( Console (..), + print, + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.Console.Dynamic.Effect +import Effectful.Zoo.Core +import HaskellWorks.Prelude + +print :: () + => HasCallStack + => r <: Console i + => i + -> Eff r () +print i = + send $ Print i diff --git a/components/core/Effectful/Zoo/Console/Dynamic/Effect.hs b/components/core/Effectful/Zoo/Console/Dynamic/Effect.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Console/Dynamic/Effect.hs @@ -0,0 +1,17 @@ +module Effectful.Zoo.Console.Dynamic.Effect + ( Console (..), + ) where + +import Effectful + +data Console a :: Effect where + Print + :: a + -> Console a m () + + Local + :: (a -> a) + -> m b + -> Console a m b + +type instance DispatchOf (Console a) = Dynamic diff --git a/components/core/Effectful/Zoo/Console/Dynamic/Run.hs b/components/core/Effectful/Zoo/Console/Dynamic/Run.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Console/Dynamic/Run.hs @@ -0,0 +1,53 @@ +module Effectful.Zoo.Console.Dynamic.Run + ( Console (..), + runConsole, + runConsoleBrackedToConsole, + runConsoleAtomic, + ) where + +import Effectful +import Effectful.Exception +import Effectful.Concurrent.QSem +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.Console.Dynamic.Effect +import Effectful.Zoo.Core +import Effectful.Zoo.Console.Static qualified as S +import HaskellWorks.Prelude + +runConsole :: () + => HasCallStack + => r <: IOE + => UnliftStrategy + -> (HasCallStack => i -> Eff r ()) + -> Eff (Console i : r) a + -> Eff r a +runConsole s run = + reinterpret (S.runConsole s run) $ \env -> \case + Print i -> S.print i + Local f m -> localSeqUnlift env $ \unlift -> S.local f (unlift m) + +runConsoleBrackedToConsole :: () + => HasCallStack + => r <: Console i + => Eff r b + -> Eff r c + -> Eff (Console i : r) a + -> Eff r a +runConsoleBrackedToConsole before after = + interpret $ \env -> \case + Print i -> + bracket_ before after $ + send $ Print i + Local f m -> + bracket_ before after $ + localSeqUnlift env $ \unlift -> send $ Local f (unlift m) + +runConsoleAtomic :: () + => HasCallStack + => r <: Concurrent + => r <: Console i + => Eff (Console i : r) a + -> Eff r a +runConsoleAtomic f = do + qsem <- newQSem 1 + runConsoleBrackedToConsole (waitQSem qsem) (signalQSem qsem) f diff --git a/components/core/Effectful/Zoo/Console/Effect.hs b/components/core/Effectful/Zoo/Console/Effect.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Console/Effect.hs @@ -0,0 +1,5 @@ +module Effectful.Zoo.Console.Effect + ( Console, + ) where + +import Effectful.Console.ByteString diff --git a/components/core/Effectful/Zoo/Console/Static.hs b/components/core/Effectful/Zoo/Console/Static.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Console/Static.hs @@ -0,0 +1,103 @@ +module Effectful.Zoo.Console.Static + ( Console, + runConsole, + runConsoleTextToHandle, + runConsoleTextToStdout, + runConsoleTextToStderr, + withConsole, + print, + local, + ) where + +import Data.Text.IO qualified as T +import Data.Kind +import Effectful +import Effectful.Zoo.Console.Data.Writer +import Effectful.Zoo.Core +import Effectful.Dispatch.Static +import HaskellWorks.Prelude +import System.IO qualified as IO + +data Console (i :: Type) :: Effect + +type instance DispatchOf (Console i) = Static NoSideEffects + +newtype instance StaticRep (Console i) = Console (Writer i) + +runConsole :: () + => r <: IOE + => HasCallStack + => UnliftStrategy + -> (HasCallStack => i -> Eff r ()) + -> Eff (Console i : r) a + -> Eff r a +runConsole strategy run f = do + s <- mkWriter strategy run + evalStaticRep (Console s) f + +runConsoleTextToHandle :: () + => HasCallStack + => Handle + -> Eff (Console Text : r) a + -> Eff r a +runConsoleTextToHandle h = + evalStaticRep $ Console $ Writer $ T.hPutStrLn h + +runConsoleTextToStdout :: () + => HasCallStack + => Eff (Console Text : r) a + -> Eff r a +runConsoleTextToStdout = + runConsoleTextToHandle IO.stdout + +runConsoleTextToStderr :: () + => HasCallStack + => Eff (Console Text : r) a + -> Eff r a +runConsoleTextToStderr = + runConsoleTextToHandle IO.stderr + +withConsoleSerialiser :: () + => HasCallStack + => (Writer i -> Writer o) + -> Eff (Console o : r) a + -> Eff (Console i : r) a +withConsoleSerialiser f m = do + writer <- getWriter + let _ = writer + raise $ evalStaticRep (Console (f writer)) m + +withConsole :: () + => HasCallStack + => (o -> i) + -> Eff (Console o : r) a + -> Eff (Console i : r) a +withConsole = + withConsoleSerialiser . contramap + +getWriter :: () + => HasCallStack + => r <: Console i + => Eff r (Writer i) +getWriter = do + Console i <- getStaticRep + pure i + +print :: () + => HasCallStack + => r <: Console i + => r <: IOE + => i + -> Eff r () +print i = do + writer <- getWriter + liftIO $ writer.run i + +local :: () + => HasCallStack + => r <: Console i + => (i -> i) + -> Eff r a + -> Eff r a +local f = + localStaticRep $ \(Console s) -> Console (contramap f s) diff --git a/components/core/Effectful/Zoo/DataLog/Api.hs b/components/core/Effectful/Zoo/DataLog/Api.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/DataLog/Api.hs @@ -0,0 +1,18 @@ +module Effectful.Zoo.DataLog.Api + ( dataLog, + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.Core +import Effectful.Zoo.DataLog.Dynamic +import HaskellWorks.Prelude + +dataLog :: () + => HasCallStack + => r <: DataLog i + => i + -> Eff r () +dataLog i = + withFrozenCallStack do + send $ DataLog i diff --git a/components/core/Effectful/Zoo/DataLog/Data/DataLogger.hs b/components/core/Effectful/Zoo/DataLog/Data/DataLogger.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/DataLog/Data/DataLogger.hs @@ -0,0 +1,22 @@ +module Effectful.Zoo.DataLog.Data.DataLogger + ( DataLogger(..), + mkDataLogger, + ) where + +import Effectful +import Effectful.Dispatch.Static +import HaskellWorks.Prelude + +newtype DataLogger i = DataLogger + { run :: i -> IO () + } deriving stock Generic + +instance Contravariant DataLogger where + contramap f (DataLogger g) = DataLogger (g . f) + +mkDataLogger :: () + => (i -> Eff r ()) + -> Eff r (DataLogger i) +mkDataLogger run = + unsafeConcUnliftIO Persistent Unlimited $ \effToIO -> + pure $ DataLogger $ effToIO . run diff --git a/components/core/Effectful/Zoo/DataLog/Data/LogEntry.hs b/components/core/Effectful/Zoo/DataLog/Data/LogEntry.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/DataLog/Data/LogEntry.hs @@ -0,0 +1,27 @@ +module Effectful.Zoo.DataLog.Data.LogEntry + ( LogEntry(..), + annotate, + ) where + +import Data.Time (UTCTime) +import Data.Time.Clock qualified as IO +import Effectful +import Effectful.Zoo.Core +import GHC.Stack qualified as GHC +import HaskellWorks.Prelude + +data LogEntry a = LogEntry + { message :: !a + , time :: !UTCTime + , source :: !CallStack + } + deriving stock (Generic, Show) + +annotate :: () + => HasCallStack + => r <: IOE + => a + -> Eff r (LogEntry a) +annotate msg = do + time <- liftIO IO.getCurrentTime + pure (LogEntry msg time GHC.callStack) diff --git a/components/core/Effectful/Zoo/DataLog/Dynamic.hs b/components/core/Effectful/Zoo/DataLog/Dynamic.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/DataLog/Dynamic.hs @@ -0,0 +1,31 @@ +module Effectful.Zoo.DataLog.Dynamic + ( DataLog (..), + runDataLog, + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.DataLog.Static qualified as S +import HaskellWorks.Prelude + +data DataLog a :: Effect where + DataLog + :: a + -> DataLog a m () + + Local + :: (a -> a) + -> m b + -> DataLog a m b + +type instance DispatchOf (DataLog a) = Dynamic + +runDataLog :: () + => HasCallStack + => (HasCallStack => i -> Eff r ()) + -> Eff (DataLog i : r) a + -> Eff r a +runDataLog run = + reinterpret (S.runDataLog run) $ \env -> \case + DataLog i -> S.log i + Local f m -> localSeqUnlift env $ \unlift -> S.local f (unlift m) diff --git a/components/core/Effectful/Zoo/DataLog/Static.hs b/components/core/Effectful/Zoo/DataLog/Static.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/DataLog/Static.hs @@ -0,0 +1,100 @@ +module Effectful.Zoo.DataLog.Static + ( DataLog, + runDataLog, + runDataLogTextToHandle, + runDataLogTextToStdout, + runDataLogTextToStderr, + withDataLog, + log, + local, + ) where + +import Data.Text.IO qualified as T +import Data.Kind +import Effectful +import Effectful.Zoo.Core +import Effectful.Dispatch.Static +import Effectful.Zoo.DataLog.Data.DataLogger +import HaskellWorks.Prelude +import System.IO qualified as IO + +data DataLog (i :: Type) :: Effect + +type instance DispatchOf (DataLog i) = Static NoSideEffects + +newtype instance StaticRep (DataLog i) = DataLog (DataLogger i) + +runDataLog :: forall i a r. () + => HasCallStack + => (HasCallStack => i -> Eff r ()) + -> Eff (DataLog i : r) a + -> Eff r a +runDataLog run f = do + s <- mkDataLogger run + evalStaticRep (DataLog s) f + +runDataLogTextToHandle :: () + => HasCallStack + => Handle + -> Eff (DataLog Text : r) a + -> Eff r a +runDataLogTextToHandle h = + evalStaticRep $ DataLog $ DataLogger $ T.hPutStrLn h + +runDataLogTextToStdout :: () + => HasCallStack + => Eff (DataLog Text : r) a + -> Eff r a +runDataLogTextToStdout = + runDataLogTextToHandle IO.stdout + +runDataLogTextToStderr :: () + => HasCallStack + => Eff (DataLog Text : r) a + -> Eff r a +runDataLogTextToStderr = + runDataLogTextToHandle IO.stderr + +withDataLogSerialiser :: () + => HasCallStack + => (DataLogger i -> DataLogger o) + -> Eff (DataLog o : r) a + -> Eff (DataLog i : r) a +withDataLogSerialiser f m = do + logger <- getDataLogger + let _ = logger + raise $ evalStaticRep (DataLog (f logger)) m + +withDataLog :: () + => HasCallStack + => (o -> i) + -> Eff (DataLog o : r) a + -> Eff (DataLog i : r) a +withDataLog = + withDataLogSerialiser . contramap + +getDataLogger :: () + => HasCallStack + => r <: DataLog i + => Eff r (DataLogger i) +getDataLogger = do + DataLog i <- getStaticRep + pure i + +log :: () + => HasCallStack + => r <: DataLog i + => i + -> Eff r () +log i = do + dataLogger <- getDataLogger + unsafeEff_ $ dataLogger.run i + +local :: () + => HasCallStack + => r <: DataLog i + => (i -> i) + -> Eff r a + -> Eff r a +local f = + localStaticRep $ \(DataLog s) -> DataLog (contramap f s) diff --git a/components/core/Effectful/Zoo/FileSystem.hs b/components/core/Effectful/Zoo/FileSystem.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/FileSystem.hs @@ -0,0 +1,84 @@ +module Effectful.Zoo.FileSystem + ( FileSystem, + JsonDecodeError(..), + YamlDecodeError(..), + readByteStringFile, + readLazyByteStringFile, + readJsonFile, + readYamlFile, + ) where + +import Data.Aeson (FromJSON) +import Data.Aeson qualified as J +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Yaml qualified as Y +import Effectful +import Effectful.Dispatch.Static +import Effectful.FileSystem +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.Core.Exception +import Effectful.Zoo.Log.Api.Text +import Effectful.Zoo.Log.Dynamic +import Effectful.Zoo.Unsafe +import HaskellWorks.Error.Types.JsonDecodeError +import HaskellWorks.Error.Types.YamlDecodeError +import HaskellWorks.Prelude + +readLazyByteStringFile :: () + => HasCallStack + => r <: Error IOException + => r <: FileSystem + => r <: Log Text + => FilePath + -> Eff r LBS.ByteString +readLazyByteStringFile filePath = withFrozenCallStack $ do + info $ "Reading bytestring from file: " <> T.pack filePath + unsafeFileSystemEff_ (LBS.readFile filePath) + & trapIO @IOException throw + +readByteStringFile :: () + => HasCallStack + => r <: Error IOException + => r <: FileSystem + => r <: Log Text + => FilePath + -> Eff r ByteString +readByteStringFile filePath = withFrozenCallStack $ do + info $ "Reading bytestring from file: " <> T.pack filePath + unsafeFileSystemEff_ (BS.readFile filePath) + & trapIO @IOException throw + +-- | Read the 'filePath' file as JSON. Use @readJsonFile \@'Value'@ to decode into 'Value'. +readJsonFile :: forall a r. () + => FromJSON a + => HasCallStack + => r <: Error IOException + => r <: Error JsonDecodeError + => r <: FileSystem + => r <: Log Text + => FilePath + -> Eff r a +readJsonFile filePath = withFrozenCallStack $ do + info $ "Reading JSON file: " <> T.pack filePath + contents <- readLazyByteStringFile filePath + J.eitherDecode contents + & onLeft (throw . newJsonDecodeError) + +-- | Read the 'filePath' file as YAML. +readYamlFile :: forall a r. () + => FromJSON a + => HasCallStack + => r <: Error IOException + => r <: Error YamlDecodeError + => r <: FileSystem + => r <: Log Text + => FilePath + -> Eff r a +readYamlFile filePath = withFrozenCallStack $ do + info $ "Reading YAML file: " <> T.pack filePath + contents <- LBS.toStrict <$> readLazyByteStringFile filePath + Y.decodeEither' contents + & onLeft (throw . YamlDecodeError . T.pack . Y.prettyPrintParseException) diff --git a/components/core/Effectful/Zoo/Lazy/Dynamic.hs b/components/core/Effectful/Zoo/Lazy/Dynamic.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Lazy/Dynamic.hs @@ -0,0 +1,44 @@ +module Effectful.Zoo.Lazy.Dynamic + ( Lazy(..), + runLazy, + lazyAsk, + ) where + +import Effectful +import Effectful.Concurrent.MVar +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.Core +import HaskellWorks.Prelude + +data Lazy i :: Effect where + LazyAsk + :: Lazy i m i + +type instance DispatchOf (Lazy i) = Dynamic + +runLazy :: forall i a r. () + => r <: Concurrent + => Eff r i + -> Eff (Lazy i : r) a + -> Eff r a +runLazy f h = do + mvCache <- newMVar @_ @(Maybe i) Nothing + interpret + do \_ -> \case + LazyAsk -> do + resultOrRunning <- takeMVar mvCache + case resultOrRunning of + Just result -> do + putMVar mvCache (Just result) + return result + Nothing -> do + result <- f + putMVar mvCache (Just result) + return result + do h + +lazyAsk :: () + => r <: Lazy i + => Eff r i +lazyAsk = + send LazyAsk diff --git a/components/core/Effectful/Zoo/Log/Api.hs b/components/core/Effectful/Zoo/Log/Api.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Api.hs @@ -0,0 +1,13 @@ +module Effectful.Zoo.Log.Api + ( log, + trace, + debug, + info, + warn, + error, + crit, + defaultRenderLogToText, + ) where + +import Effectful.Zoo.Log.Api.Render +import Effectful.Zoo.Log.Api.Text diff --git a/components/core/Effectful/Zoo/Log/Api/Generic.hs b/components/core/Effectful/Zoo/Log/Api/Generic.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Api/Generic.hs @@ -0,0 +1,80 @@ +module Effectful.Zoo.Log.Api.Generic + ( log, + trace, + debug, + info, + warn, + error, + crit, + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.Core +import Effectful.Zoo.Log.Data.Severity +import Effectful.Zoo.Log.Dynamic +import HaskellWorks.Prelude + +log :: () + => HasCallStack + => r <: Log i + => Severity + -> i + -> Eff r () +log severity message = + withFrozenCallStack $ + send (Log severity message) + +trace :: () + => HasCallStack + => r <: Log i + => i + -> Eff r () +trace = + withFrozenCallStack $ + log Trace + +debug :: () + => HasCallStack + => r <: Log i + => i + -> Eff r () +debug = + withFrozenCallStack $ + log Debug + +info :: () + => HasCallStack + => r <: Log i + => i + -> Eff r () +info = + withFrozenCallStack $ + log Info + +warn :: () + => HasCallStack + => r <: Log i + => i + -> Eff r () +warn = + withFrozenCallStack $ + log Warn + +error :: () + => HasCallStack + => r <: Log i + => i + -> Eff r () +error = + withFrozenCallStack $ + log Error + +crit :: () + => HasCallStack + => r <: Log i + => i + -> Eff r () +crit = + withFrozenCallStack $ + log Crit diff --git a/components/core/Effectful/Zoo/Log/Api/LazyText.hs b/components/core/Effectful/Zoo/Log/Api/LazyText.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Api/LazyText.hs @@ -0,0 +1,80 @@ +module Effectful.Zoo.Log.Api.LazyText + ( log, + trace, + debug, + info, + warn, + error, + crit, + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.Core +import Effectful.Zoo.Log.Data.Severity +import Effectful.Zoo.Log.Dynamic +import HaskellWorks.Prelude + +log :: () + => HasCallStack + => r <: Log LazyText + => Severity + -> LazyText + -> Eff r () +log severity message = + withFrozenCallStack $ + send (Log severity message) + +trace :: () + => HasCallStack + => r <: Log LazyText + => LazyText + -> Eff r () +trace = + withFrozenCallStack $ + log Trace + +debug :: () + => HasCallStack + => r <: Log LazyText + => LazyText + -> Eff r () +debug = + withFrozenCallStack $ + log Debug + +info :: () + => HasCallStack + => r <: Log LazyText + => LazyText + -> Eff r () +info = + withFrozenCallStack $ + log Info + +warn :: () + => HasCallStack + => r <: Log LazyText + => LazyText + -> Eff r () +warn = + withFrozenCallStack $ + log Warn + +error :: () + => HasCallStack + => r <: Log LazyText + => LazyText + -> Eff r () +error = + withFrozenCallStack $ + log Error + +crit :: () + => HasCallStack + => r <: Log LazyText + => LazyText + -> Eff r () +crit = + withFrozenCallStack $ + log Crit diff --git a/components/core/Effectful/Zoo/Log/Api/Render.hs b/components/core/Effectful/Zoo/Log/Api/Render.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Api/Render.hs @@ -0,0 +1,11 @@ +module Effectful.Zoo.Log.Api.Render + ( defaultRenderLogToText, + ) where + +import Effectful.Zoo.Log.Data.Severity +import HaskellWorks.Prelude +import HaskellWorks.ToText + +defaultRenderLogToText :: ToText i => Severity -> i -> Text +defaultRenderLogToText severity i = + "[" <> toText severity <> "] " <> toText i diff --git a/components/core/Effectful/Zoo/Log/Api/String.hs b/components/core/Effectful/Zoo/Log/Api/String.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Api/String.hs @@ -0,0 +1,80 @@ +module Effectful.Zoo.Log.Api.String + ( log, + trace, + debug, + info, + warn, + error, + crit, + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.Core +import Effectful.Zoo.Log.Data.Severity +import Effectful.Zoo.Log.Dynamic +import HaskellWorks.Prelude + +log :: () + => HasCallStack + => r <: Log String + => Severity + -> String + -> Eff r () +log severity message = + withFrozenCallStack $ + send (Log severity message) + +trace :: () + => HasCallStack + => r <: Log String + => String + -> Eff r () +trace = + withFrozenCallStack $ + log Trace + +debug :: () + => HasCallStack + => r <: Log String + => String + -> Eff r () +debug = + withFrozenCallStack $ + log Debug + +info :: () + => HasCallStack + => r <: Log String + => String + -> Eff r () +info = + withFrozenCallStack $ + log Info + +warn :: () + => HasCallStack + => r <: Log String + => String + -> Eff r () +warn = + withFrozenCallStack $ + log Warn + +error :: () + => HasCallStack + => r <: Log String + => String + -> Eff r () +error = + withFrozenCallStack $ + log Error + +crit :: () + => HasCallStack + => r <: Log String + => String + -> Eff r () +crit = + withFrozenCallStack $ + log Crit diff --git a/components/core/Effectful/Zoo/Log/Api/Text.hs b/components/core/Effectful/Zoo/Log/Api/Text.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Api/Text.hs @@ -0,0 +1,80 @@ +module Effectful.Zoo.Log.Api.Text + ( log, + trace, + debug, + info, + warn, + error, + crit, + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.Core +import Effectful.Zoo.Log.Data.Severity +import Effectful.Zoo.Log.Dynamic +import HaskellWorks.Prelude + +log :: () + => HasCallStack + => r <: Log Text + => Severity + -> Text + -> Eff r () +log severity message = + withFrozenCallStack $ + send (Log severity message) + +trace :: () + => HasCallStack + => r <: Log Text + => Text + -> Eff r () +trace = + withFrozenCallStack $ + log Trace + +debug :: () + => HasCallStack + => r <: Log Text + => Text + -> Eff r () +debug = + withFrozenCallStack $ + log Debug + +info :: () + => HasCallStack + => r <: Log Text + => Text + -> Eff r () +info = + withFrozenCallStack $ + log Info + +warn :: () + => HasCallStack + => r <: Log Text + => Text + -> Eff r () +warn = + withFrozenCallStack $ + log Warn + +error :: () + => HasCallStack + => r <: Log Text + => Text + -> Eff r () +error = + withFrozenCallStack $ + log Error + +crit :: () + => HasCallStack + => r <: Log Text + => Text + -> Eff r () +crit = + withFrozenCallStack $ + log Crit diff --git a/components/core/Effectful/Zoo/Log/Data/LogMessage.hs b/components/core/Effectful/Zoo/Log/Data/LogMessage.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Data/LogMessage.hs @@ -0,0 +1,11 @@ +module Effectful.Zoo.Log.Data.LogMessage where + +import Effectful.Zoo.Log.Data.Severity (Severity) +import HaskellWorks.Prelude + +data LogMessage i = + LogMessage + { severity :: !Severity + , message :: i + } + deriving stock (Eq, Generic, Show) diff --git a/components/core/Effectful/Zoo/Log/Data/Logger.hs b/components/core/Effectful/Zoo/Log/Data/Logger.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Data/Logger.hs @@ -0,0 +1,25 @@ +module Effectful.Zoo.Log.Data.Logger + ( Logger(..), + mkLogger, + ) where + +import Effectful +import Effectful.Zoo.Core +import Effectful.Zoo.Log.Data.Severity +import HaskellWorks.Prelude + +newtype Logger i = Logger + { run :: CallStack -> Severity -> i -> IO () + } deriving stock Generic + +instance Contravariant Logger where + contramap f (Logger g) = Logger \cs severity -> g cs severity . f + +mkLogger :: () + => r <: IOE + => UnliftStrategy + -> (CallStack -> Severity -> i -> Eff r ()) + -> Eff r (Logger i) +mkLogger strategy run = + withEffToIO strategy $ \effToIO -> + pure $ Logger $ \cs severity i -> effToIO $ run cs severity i diff --git a/components/core/Effectful/Zoo/Log/Data/Severity.hs b/components/core/Effectful/Zoo/Log/Data/Severity.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Data/Severity.hs @@ -0,0 +1,38 @@ +module Effectful.Zoo.Log.Data.Severity + ( Severity (..), + parseSeverity, + ) where + +import GHC.Enum +import Data.Text qualified as T +import HaskellWorks.Prelude +import HaskellWorks.ToText + +data Severity = + Trace + | Debug + | Info + | Warn + | Error + | Crit + deriving stock (Enum, Eq, Generic, Ord, Show) + +parseSeverity :: Text -> Maybe Severity +parseSeverity t = + case T.toLower t of + "trace" -> Just Trace + "debug" -> Just Debug + "info" -> Just Info + "warn" -> Just Warn + "error" -> Just Error + "crit" -> Just Crit + _ -> Nothing + +instance ToText Severity where + toText = \case + Trace -> "trace" + Debug -> "debug" + Info -> "info" + Warn -> "warn" + Error -> "error" + Crit -> "crit" diff --git a/components/core/Effectful/Zoo/Log/Dynamic.hs b/components/core/Effectful/Zoo/Log/Dynamic.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Dynamic.hs @@ -0,0 +1,36 @@ +module Effectful.Zoo.Log.Dynamic + ( Log (..), + runLog, + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Zoo.Core +import Effectful.Zoo.Log.Data.Severity +import Effectful.Zoo.Log.Static qualified as S +import HaskellWorks.Prelude + +data Log i :: Effect where + Log + :: HasCallStack + => Severity + -> i + -> Log i m () + + Local + :: (i -> i) + -> m a + -> Log i m a + +type instance DispatchOf (Log a) = Dynamic + +runLog :: () + => r <: IOE + => UnliftStrategy + -> (CallStack -> Severity -> i -> Eff r ()) + -> Eff (Log i : r) a + -> Eff r a +runLog s run = + reinterpret (S.runLog s run) $ \env -> \case + Log severity i -> S.log severity i + Local f m -> localSeqUnlift env $ \unlift -> S.local f (unlift m) diff --git a/components/core/Effectful/Zoo/Log/Static.hs b/components/core/Effectful/Zoo/Log/Static.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Log/Static.hs @@ -0,0 +1,111 @@ +module Effectful.Zoo.Log.Static + ( Log, + runLog, + runLogToHandle, + runLogToStdout, + runLogToStderr, + withLog, + log, + local, + ) where + +import Data.Kind +import Data.Text.IO qualified as T +import Effectful +import Effectful.Dispatch.Static +import Effectful.Zoo.Core +import Effectful.Zoo.Log.Data.Logger +import Effectful.Zoo.Log.Data.Severity +import GHC.Stack qualified as GHC +import HaskellWorks.Prelude +import System.IO qualified as IO + +data Log (i :: Type) :: Effect + +type instance DispatchOf (Log i) = Static NoSideEffects + +newtype instance StaticRep (Log i) = Log (Logger i) + +runLog :: () + => r <: IOE + => HasCallStack + => UnliftStrategy + -> (CallStack -> Severity -> i -> Eff r ()) + -> Eff (Log i : r) a + -> Eff r a +runLog strategy run f = do + s <- mkLogger strategy run + evalStaticRep (Log s) f + +runLogToHandle :: () + => HasCallStack + => Handle + -> (Severity -> a -> Text) + -> Eff (Log a : r) a + -> Eff r a +runLogToHandle h f = + evalStaticRep $ Log $ Logger $ \_ severity i -> + T.hPutStrLn h $ f severity i + +runLogToStdout :: () + => HasCallStack + => (Severity -> a -> Text) + -> Eff (Log a : r) a + -> Eff r a +runLogToStdout = + runLogToHandle IO.stdout + +runLogToStderr :: () + => HasCallStack + => (Severity -> a -> Text) + -> Eff (Log a : r) a + -> Eff r a +runLogToStderr = + runLogToHandle IO.stderr + +withDataLogSerialiser :: () + => HasCallStack + => (Logger i -> Logger o) + -> Eff (Log o : r) a + -> Eff (Log i : r) a +withDataLogSerialiser f m = do + logger <- getDataLogger + let _ = logger + raise $ evalStaticRep (Log (f logger)) m + +withLog :: () + => HasCallStack + => (o -> i) + -> Eff (Log o : r) a + -> Eff (Log i : r) a +withLog = + withDataLogSerialiser . contramap + +getDataLogger :: () + => HasCallStack + => r <: Log i + => Eff r (Logger i) +getDataLogger = do + Log i <- getStaticRep + pure i + +log :: () + => HasCallStack + => r <: Log i + => r <: IOE + => Severity + -> i + -> Eff r () +log severity i = + withFrozenCallStack do + dataLogger <- getDataLogger + liftIO $ dataLogger.run GHC.callStack severity i + +local :: () + => HasCallStack + => r <: Log i + => (i -> i) + -> Eff r a + -> Eff r a +local f = + localStaticRep $ \(Log s) -> Log (contramap f s) diff --git a/components/core/Effectful/Zoo/Unsafe.hs b/components/core/Effectful/Zoo/Unsafe.hs new file mode 100644 --- /dev/null +++ b/components/core/Effectful/Zoo/Unsafe.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Effectful.Zoo.Unsafe + ( unsafeFileSystemEff_ + ) where + +import Effectful +import Effectful.Dispatch.Static +import Effectful.FileSystem +import Effectful.Zoo.Core +import HaskellWorks.Prelude + +unsafeFileSystemEff_ :: () + => r <: FileSystem + => IO a + -> Eff r a +unsafeFileSystemEff_ = + unsafeEff_ diff --git a/components/datalog/Effectful/Zoo/DataLog/Api.hs b/components/datalog/Effectful/Zoo/DataLog/Api.hs deleted file mode 100644 --- a/components/datalog/Effectful/Zoo/DataLog/Api.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Effectful.Zoo.DataLog.Api - ( dataLog, - ) where - -import Effectful -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.Core -import Effectful.Zoo.DataLog.Dynamic -import HaskellWorks.Prelude - -dataLog :: () - => HasCallStack - => r <: DataLog i - => i - -> Eff r () -dataLog i = - withFrozenCallStack do - send $ DataLog i diff --git a/components/datalog/Effectful/Zoo/DataLog/Data/DataLogger.hs b/components/datalog/Effectful/Zoo/DataLog/Data/DataLogger.hs deleted file mode 100644 --- a/components/datalog/Effectful/Zoo/DataLog/Data/DataLogger.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Effectful.Zoo.DataLog.Data.DataLogger - ( DataLogger(..), - mkDataLogger, - ) where - -import Effectful -import Effectful.Dispatch.Static -import HaskellWorks.Prelude - -newtype DataLogger i = DataLogger - { run :: i -> IO () - } deriving stock Generic - -instance Contravariant DataLogger where - contramap f (DataLogger g) = DataLogger (g . f) - -mkDataLogger :: () - => (i -> Eff r ()) - -> Eff r (DataLogger i) -mkDataLogger run = - unsafeConcUnliftIO Persistent Unlimited $ \effToIO -> - pure $ DataLogger $ effToIO . run diff --git a/components/datalog/Effectful/Zoo/DataLog/Data/LogEntry.hs b/components/datalog/Effectful/Zoo/DataLog/Data/LogEntry.hs deleted file mode 100644 --- a/components/datalog/Effectful/Zoo/DataLog/Data/LogEntry.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Effectful.Zoo.DataLog.Data.LogEntry - ( LogEntry(..), - annotate, - ) where - -import Data.Time (UTCTime) -import Data.Time.Clock qualified as IO -import Effectful -import Effectful.Zoo.Core -import GHC.Stack qualified as GHC -import HaskellWorks.Prelude - -data LogEntry a = LogEntry - { message :: !a - , time :: !UTCTime - , source :: !CallStack - } - deriving stock (Generic, Show) - -annotate :: () - => HasCallStack - => r <: IOE - => a - -> Eff r (LogEntry a) -annotate msg = do - time <- liftIO IO.getCurrentTime - pure (LogEntry msg time GHC.callStack) diff --git a/components/datalog/Effectful/Zoo/DataLog/Dynamic.hs b/components/datalog/Effectful/Zoo/DataLog/Dynamic.hs deleted file mode 100644 --- a/components/datalog/Effectful/Zoo/DataLog/Dynamic.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Effectful.Zoo.DataLog.Dynamic - ( DataLog (..), - runDataLog, - ) where - -import Effectful -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.DataLog.Static qualified as S -import HaskellWorks.Prelude - -data DataLog a :: Effect where - DataLog - :: a - -> DataLog a m () - - Local - :: (a -> a) - -> m b - -> DataLog a m b - -type instance DispatchOf (DataLog a) = Dynamic - -runDataLog :: () - => HasCallStack - => (HasCallStack => i -> Eff r ()) - -> Eff (DataLog i : r) a - -> Eff r a -runDataLog run = - reinterpret (S.runDataLog run) $ \env -> \case - DataLog i -> S.log i - Local f m -> localSeqUnlift env $ \unlift -> S.local f (unlift m) diff --git a/components/datalog/Effectful/Zoo/DataLog/Static.hs b/components/datalog/Effectful/Zoo/DataLog/Static.hs deleted file mode 100644 --- a/components/datalog/Effectful/Zoo/DataLog/Static.hs +++ /dev/null @@ -1,100 +0,0 @@ -module Effectful.Zoo.DataLog.Static - ( DataLog, - runDataLog, - runDataLogTextToHandle, - runDataLogTextToStdout, - runDataLogTextToStderr, - withDataLog, - log, - local, - ) where - -import Data.Text.IO qualified as T -import Data.Kind -import Effectful -import Effectful.Zoo.Core -import Effectful.Dispatch.Static -import Effectful.Zoo.DataLog.Data.DataLogger -import HaskellWorks.Prelude -import System.IO qualified as IO - -data DataLog (i :: Type) :: Effect - -type instance DispatchOf (DataLog i) = Static NoSideEffects - -newtype instance StaticRep (DataLog i) = DataLog (DataLogger i) - -runDataLog :: forall i a r. () - => HasCallStack - => (HasCallStack => i -> Eff r ()) - -> Eff (DataLog i : r) a - -> Eff r a -runDataLog run f = do - s <- mkDataLogger run - evalStaticRep (DataLog s) f - -runDataLogTextToHandle :: () - => HasCallStack - => Handle - -> Eff (DataLog Text : r) a - -> Eff r a -runDataLogTextToHandle h = - evalStaticRep $ DataLog $ DataLogger $ T.hPutStrLn h - -runDataLogTextToStdout :: () - => HasCallStack - => Eff (DataLog Text : r) a - -> Eff r a -runDataLogTextToStdout = - runDataLogTextToHandle IO.stdout - -runDataLogTextToStderr :: () - => HasCallStack - => Eff (DataLog Text : r) a - -> Eff r a -runDataLogTextToStderr = - runDataLogTextToHandle IO.stderr - -withDataLogSerialiser :: () - => HasCallStack - => (DataLogger i -> DataLogger o) - -> Eff (DataLog o : r) a - -> Eff (DataLog i : r) a -withDataLogSerialiser f m = do - logger <- getDataLogger - let _ = logger - raise $ evalStaticRep (DataLog (f logger)) m - -withDataLog :: () - => HasCallStack - => (o -> i) - -> Eff (DataLog o : r) a - -> Eff (DataLog i : r) a -withDataLog = - withDataLogSerialiser . contramap - -getDataLogger :: () - => HasCallStack - => r <: DataLog i - => Eff r (DataLogger i) -getDataLogger = do - DataLog i <- getStaticRep - pure i - -log :: () - => HasCallStack - => r <: DataLog i - => i - -> Eff r () -log i = do - dataLogger <- getDataLogger - unsafeEff_ $ dataLogger.run i - -local :: () - => HasCallStack - => r <: DataLog i - => (i -> i) - -> Eff r a - -> Eff r a -local f = - localStaticRep $ \(DataLog s) -> DataLog (contramap f s) diff --git a/components/lazy/Effectful/Zoo/Lazy/Dynamic.hs b/components/lazy/Effectful/Zoo/Lazy/Dynamic.hs deleted file mode 100644 --- a/components/lazy/Effectful/Zoo/Lazy/Dynamic.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Effectful.Zoo.Lazy.Dynamic - ( Lazy(..), - runLazy, - lazyAsk, - ) where - -import Effectful -import Effectful.Concurrent.MVar -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.Core -import HaskellWorks.Prelude - -data Lazy i :: Effect where - LazyAsk - :: Lazy i m i - -type instance DispatchOf (Lazy i) = Dynamic - -runLazy :: forall i a r. () - => r <: Concurrent - => Eff r i - -> Eff (Lazy i : r) a - -> Eff r a -runLazy f h = do - mvCache <- newMVar @_ @(Maybe i) Nothing - interpret - do \_ -> \case - LazyAsk -> do - resultOrRunning <- takeMVar mvCache - case resultOrRunning of - Just result -> do - putMVar mvCache (Just result) - return result - Nothing -> do - result <- f - putMVar mvCache (Just result) - return result - do h - -lazyAsk :: () - => r <: Lazy i - => Eff r i -lazyAsk = - send LazyAsk diff --git a/components/log/Effectful/Zoo/Log/Api.hs b/components/log/Effectful/Zoo/Log/Api.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Api.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Effectful.Zoo.Log.Api - ( log, - trace, - debug, - info, - warn, - error, - crit, - defaultRenderLogToText, - ) where - -import Effectful.Zoo.Log.Api.Render -import Effectful.Zoo.Log.Api.Text diff --git a/components/log/Effectful/Zoo/Log/Api/Generic.hs b/components/log/Effectful/Zoo/Log/Api/Generic.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Api/Generic.hs +++ /dev/null @@ -1,80 +0,0 @@ -module Effectful.Zoo.Log.Api.Generic - ( log, - trace, - debug, - info, - warn, - error, - crit, - ) where - -import Effectful -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.Core -import Effectful.Zoo.Log.Data.Severity -import Effectful.Zoo.Log.Dynamic -import HaskellWorks.Prelude - -log :: () - => HasCallStack - => r <: Log i - => Severity - -> i - -> Eff r () -log severity message = - withFrozenCallStack $ - send (Log severity message) - -trace :: () - => HasCallStack - => r <: Log i - => i - -> Eff r () -trace = - withFrozenCallStack $ - log Trace - -debug :: () - => HasCallStack - => r <: Log i - => i - -> Eff r () -debug = - withFrozenCallStack $ - log Debug - -info :: () - => HasCallStack - => r <: Log i - => i - -> Eff r () -info = - withFrozenCallStack $ - log Info - -warn :: () - => HasCallStack - => r <: Log i - => i - -> Eff r () -warn = - withFrozenCallStack $ - log Warn - -error :: () - => HasCallStack - => r <: Log i - => i - -> Eff r () -error = - withFrozenCallStack $ - log Error - -crit :: () - => HasCallStack - => r <: Log i - => i - -> Eff r () -crit = - withFrozenCallStack $ - log Crit diff --git a/components/log/Effectful/Zoo/Log/Api/LazyText.hs b/components/log/Effectful/Zoo/Log/Api/LazyText.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Api/LazyText.hs +++ /dev/null @@ -1,80 +0,0 @@ -module Effectful.Zoo.Log.Api.LazyText - ( log, - trace, - debug, - info, - warn, - error, - crit, - ) where - -import Effectful -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.Core -import Effectful.Zoo.Log.Data.Severity -import Effectful.Zoo.Log.Dynamic -import HaskellWorks.Prelude - -log :: () - => HasCallStack - => r <: Log LazyText - => Severity - -> LazyText - -> Eff r () -log severity message = - withFrozenCallStack $ - send (Log severity message) - -trace :: () - => HasCallStack - => r <: Log LazyText - => LazyText - -> Eff r () -trace = - withFrozenCallStack $ - log Trace - -debug :: () - => HasCallStack - => r <: Log LazyText - => LazyText - -> Eff r () -debug = - withFrozenCallStack $ - log Debug - -info :: () - => HasCallStack - => r <: Log LazyText - => LazyText - -> Eff r () -info = - withFrozenCallStack $ - log Info - -warn :: () - => HasCallStack - => r <: Log LazyText - => LazyText - -> Eff r () -warn = - withFrozenCallStack $ - log Warn - -error :: () - => HasCallStack - => r <: Log LazyText - => LazyText - -> Eff r () -error = - withFrozenCallStack $ - log Error - -crit :: () - => HasCallStack - => r <: Log LazyText - => LazyText - -> Eff r () -crit = - withFrozenCallStack $ - log Crit diff --git a/components/log/Effectful/Zoo/Log/Api/Render.hs b/components/log/Effectful/Zoo/Log/Api/Render.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Api/Render.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Effectful.Zoo.Log.Api.Render - ( defaultRenderLogToText, - ) where - -import Effectful.Zoo.Log.Data.Severity -import HaskellWorks.Prelude -import HaskellWorks.ToText - -defaultRenderLogToText :: ToText i => Severity -> i -> Text -defaultRenderLogToText severity i = - "[" <> toText severity <> "] " <> toText i diff --git a/components/log/Effectful/Zoo/Log/Api/String.hs b/components/log/Effectful/Zoo/Log/Api/String.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Api/String.hs +++ /dev/null @@ -1,80 +0,0 @@ -module Effectful.Zoo.Log.Api.String - ( log, - trace, - debug, - info, - warn, - error, - crit, - ) where - -import Effectful -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.Core -import Effectful.Zoo.Log.Data.Severity -import Effectful.Zoo.Log.Dynamic -import HaskellWorks.Prelude - -log :: () - => HasCallStack - => r <: Log String - => Severity - -> String - -> Eff r () -log severity message = - withFrozenCallStack $ - send (Log severity message) - -trace :: () - => HasCallStack - => r <: Log String - => String - -> Eff r () -trace = - withFrozenCallStack $ - log Trace - -debug :: () - => HasCallStack - => r <: Log String - => String - -> Eff r () -debug = - withFrozenCallStack $ - log Debug - -info :: () - => HasCallStack - => r <: Log String - => String - -> Eff r () -info = - withFrozenCallStack $ - log Info - -warn :: () - => HasCallStack - => r <: Log String - => String - -> Eff r () -warn = - withFrozenCallStack $ - log Warn - -error :: () - => HasCallStack - => r <: Log String - => String - -> Eff r () -error = - withFrozenCallStack $ - log Error - -crit :: () - => HasCallStack - => r <: Log String - => String - -> Eff r () -crit = - withFrozenCallStack $ - log Crit diff --git a/components/log/Effectful/Zoo/Log/Api/Text.hs b/components/log/Effectful/Zoo/Log/Api/Text.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Api/Text.hs +++ /dev/null @@ -1,80 +0,0 @@ -module Effectful.Zoo.Log.Api.Text - ( log, - trace, - debug, - info, - warn, - error, - crit, - ) where - -import Effectful -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.Core -import Effectful.Zoo.Log.Data.Severity -import Effectful.Zoo.Log.Dynamic -import HaskellWorks.Prelude - -log :: () - => HasCallStack - => r <: Log Text - => Severity - -> Text - -> Eff r () -log severity message = - withFrozenCallStack $ - send (Log severity message) - -trace :: () - => HasCallStack - => r <: Log Text - => Text - -> Eff r () -trace = - withFrozenCallStack $ - log Trace - -debug :: () - => HasCallStack - => r <: Log Text - => Text - -> Eff r () -debug = - withFrozenCallStack $ - log Debug - -info :: () - => HasCallStack - => r <: Log Text - => Text - -> Eff r () -info = - withFrozenCallStack $ - log Info - -warn :: () - => HasCallStack - => r <: Log Text - => Text - -> Eff r () -warn = - withFrozenCallStack $ - log Warn - -error :: () - => HasCallStack - => r <: Log Text - => Text - -> Eff r () -error = - withFrozenCallStack $ - log Error - -crit :: () - => HasCallStack - => r <: Log Text - => Text - -> Eff r () -crit = - withFrozenCallStack $ - log Crit diff --git a/components/log/Effectful/Zoo/Log/Data/LogMessage.hs b/components/log/Effectful/Zoo/Log/Data/LogMessage.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Data/LogMessage.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Effectful.Zoo.Log.Data.LogMessage where - -import Effectful.Zoo.Log.Data.Severity (Severity) -import HaskellWorks.Prelude - -data LogMessage i = - LogMessage - { severity :: !Severity - , message :: i - } - deriving stock (Eq, Generic, Show) diff --git a/components/log/Effectful/Zoo/Log/Data/Logger.hs b/components/log/Effectful/Zoo/Log/Data/Logger.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Data/Logger.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Effectful.Zoo.Log.Data.Logger - ( Logger(..), - mkLogger, - ) where - -import Effectful -import Effectful.Zoo.Core -import Effectful.Zoo.Log.Data.Severity -import HaskellWorks.Prelude - -newtype Logger i = Logger - { run :: CallStack -> Severity -> i -> IO () - } deriving stock Generic - -instance Contravariant Logger where - contramap f (Logger g) = Logger \cs severity -> g cs severity . f - -mkLogger :: () - => r <: IOE - => UnliftStrategy - -> (CallStack -> Severity -> i -> Eff r ()) - -> Eff r (Logger i) -mkLogger strategy run = - withEffToIO strategy $ \effToIO -> - pure $ Logger $ \cs severity i -> effToIO $ run cs severity i diff --git a/components/log/Effectful/Zoo/Log/Data/Severity.hs b/components/log/Effectful/Zoo/Log/Data/Severity.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Data/Severity.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Effectful.Zoo.Log.Data.Severity - ( Severity (..), - parseSeverity, - ) where - -import GHC.Enum -import Data.Text qualified as T -import HaskellWorks.Prelude -import HaskellWorks.ToText - -data Severity = - Trace - | Debug - | Info - | Warn - | Error - | Crit - deriving stock (Enum, Eq, Generic, Ord, Show) - -parseSeverity :: Text -> Maybe Severity -parseSeverity t = - case T.toLower t of - "trace" -> Just Trace - "debug" -> Just Debug - "info" -> Just Info - "warn" -> Just Warn - "error" -> Just Error - "crit" -> Just Crit - _ -> Nothing - -instance ToText Severity where - toText = \case - Trace -> "trace" - Debug -> "debug" - Info -> "info" - Warn -> "warn" - Error -> "error" - Crit -> "crit" diff --git a/components/log/Effectful/Zoo/Log/Dynamic.hs b/components/log/Effectful/Zoo/Log/Dynamic.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Dynamic.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Effectful.Zoo.Log.Dynamic - ( Log (..), - runLog, - ) where - -import Effectful -import Effectful.Dispatch.Dynamic -import Effectful.Zoo.Core -import Effectful.Zoo.Log.Data.Severity -import Effectful.Zoo.Log.Static qualified as S -import HaskellWorks.Prelude - -data Log i :: Effect where - Log - :: HasCallStack - => Severity - -> i - -> Log i m () - - Local - :: (i -> i) - -> m a - -> Log i m a - -type instance DispatchOf (Log a) = Dynamic - -runLog :: () - => r <: IOE - => UnliftStrategy - -> (CallStack -> Severity -> i -> Eff r ()) - -> Eff (Log i : r) a - -> Eff r a -runLog s run = - reinterpret (S.runLog s run) $ \env -> \case - Log severity i -> S.log severity i - Local f m -> localSeqUnlift env $ \unlift -> S.local f (unlift m) diff --git a/components/log/Effectful/Zoo/Log/Static.hs b/components/log/Effectful/Zoo/Log/Static.hs deleted file mode 100644 --- a/components/log/Effectful/Zoo/Log/Static.hs +++ /dev/null @@ -1,111 +0,0 @@ -module Effectful.Zoo.Log.Static - ( Log, - runLog, - runLogToHandle, - runLogToStdout, - runLogToStderr, - withLog, - log, - local, - ) where - -import Data.Kind -import Data.Text.IO qualified as T -import Effectful -import Effectful.Dispatch.Static -import Effectful.Zoo.Core -import Effectful.Zoo.Log.Data.Logger -import Effectful.Zoo.Log.Data.Severity -import GHC.Stack qualified as GHC -import HaskellWorks.Prelude -import System.IO qualified as IO - -data Log (i :: Type) :: Effect - -type instance DispatchOf (Log i) = Static NoSideEffects - -newtype instance StaticRep (Log i) = Log (Logger i) - -runLog :: () - => r <: IOE - => HasCallStack - => UnliftStrategy - -> (CallStack -> Severity -> i -> Eff r ()) - -> Eff (Log i : r) a - -> Eff r a -runLog strategy run f = do - s <- mkLogger strategy run - evalStaticRep (Log s) f - -runLogToHandle :: () - => HasCallStack - => Handle - -> (Severity -> a -> Text) - -> Eff (Log a : r) a - -> Eff r a -runLogToHandle h f = - evalStaticRep $ Log $ Logger $ \_ severity i -> - T.hPutStrLn h $ f severity i - -runLogToStdout :: () - => HasCallStack - => (Severity -> a -> Text) - -> Eff (Log a : r) a - -> Eff r a -runLogToStdout = - runLogToHandle IO.stdout - -runLogToStderr :: () - => HasCallStack - => (Severity -> a -> Text) - -> Eff (Log a : r) a - -> Eff r a -runLogToStderr = - runLogToHandle IO.stderr - -withDataLogSerialiser :: () - => HasCallStack - => (Logger i -> Logger o) - -> Eff (Log o : r) a - -> Eff (Log i : r) a -withDataLogSerialiser f m = do - logger <- getDataLogger - let _ = logger - raise $ evalStaticRep (Log (f logger)) m - -withLog :: () - => HasCallStack - => (o -> i) - -> Eff (Log o : r) a - -> Eff (Log i : r) a -withLog = - withDataLogSerialiser . contramap - -getDataLogger :: () - => HasCallStack - => r <: Log i - => Eff r (Logger i) -getDataLogger = do - Log i <- getStaticRep - pure i - -log :: () - => HasCallStack - => r <: Log i - => r <: IOE - => Severity - -> i - -> Eff r () -log severity i = - withFrozenCallStack do - dataLogger <- getDataLogger - liftIO $ dataLogger.run GHC.callStack severity i - -local :: () - => HasCallStack - => r <: Log i - => (i -> i) - -> Eff r a - -> Eff r a -local f = - localStaticRep $ \(Log s) -> Log (contramap f s) diff --git a/components/rds-data/Effectful/Zoo/RdsData/Core.hs b/components/rds-data/Effectful/Zoo/RdsData/Core.hs new file mode 100644 --- /dev/null +++ b/components/rds-data/Effectful/Zoo/RdsData/Core.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Effectful.Zoo.RdsData.Core + ( executeStatement, + executeStatement_, + initialiseDb, + newExecuteStatement, + newBatchExecuteStatement, + ) where + +import Amazonka.RDSData.BatchExecuteStatement qualified as AWS +import Amazonka.RDSData.ExecuteStatement qualified as AWS +import Amazonka.Types qualified as AWS +import Data.Generics.Product.Any +import Data.RdsData.Aws +import Effectful +import Effectful.Error.Static +import Effectful.Reader.Static +import Effectful.Zoo.Amazonka.Api.Send +import Effectful.Zoo.Amazonka.Data +import Effectful.Zoo.Amazonka.Dynamic +import Effectful.Zoo.Core +import Effectful.Zoo.Core.Error.Static +import Effectful.Zoo.DataLog.Dynamic +import Effectful.Zoo.Log.Api +import Effectful.Zoo.Log.Dynamic +import Effectful.Zoo.RdsData.Errors +import HaskellWorks.Prelude +import Lens.Micro + +newExecuteStatement :: () + => r <: Reader StatementContext + => Text + -> Eff r AWS.ExecuteStatement +newExecuteStatement sql = do + context <- ask @StatementContext + + let AwsResourceArn theResourceArn = context ^. the @"resourceArn" + let AwsSecretArn theSecretArn = context ^. the @"secretArn" + + pure $ AWS.newExecuteStatement theResourceArn theSecretArn sql + & the @"database" .~ (context ^? the @"database" . _Just . the @1) + +newBatchExecuteStatement :: () + => r <: Reader StatementContext + => Text + -> Eff r AWS.BatchExecuteStatement +newBatchExecuteStatement sql = do + context <- ask @StatementContext + + let AwsResourceArn theResourceArn = context ^. the @"resourceArn" + let AwsSecretArn theSecretArn = context ^. the @"secretArn" + + pure $ AWS.newBatchExecuteStatement theResourceArn theSecretArn sql + & the @"database" .~ (context ^? the @"database" . _Just . the @1) + +executeStatement :: () + => HasCallStack + => r <: Amazonka + => r <: DataLog AwsLogEntry + => r <: Error AWS.Error + => r <: Error RdsDataError + => r <: IOE + => r <: Log Text + => r <: Reader StatementContext + => Text + -> Eff r AWS.ExecuteStatementResponse +executeStatement sql = withFrozenCallStack do + res <- newExecuteStatement sql >>= sendAws + + case res ^. the @"httpStatus" of + 200 -> do + info $ "Successfully executed statement. Results: " <> tshow res + pure res + _ -> throw $ RdsDataError $ "Failed to initialise database: " <> tshow res + +executeStatement_ :: () + => HasCallStack + => r <: Amazonka + => r <: DataLog AwsLogEntry + => r <: Error AWS.Error + => r <: Error RdsDataError + => r <: IOE + => r <: Log Text + => r <: Reader StatementContext + => Text + -> Eff r () +executeStatement_ f = withFrozenCallStack do + void $ executeStatement f + +initialiseDb :: () + => HasCallStack + => r <: Amazonka + => r <: DataLog AwsLogEntry + => r <: Error AWS.Error + => r <: Error RdsDataError + => r <: IOE + => r <: Log Text + => r <: Reader StatementContext + => Eff r () +initialiseDb = withFrozenCallStack do + executeStatement_ $ mconcat + [ "CREATE TABLE IF NOT EXISTS migration (" + , " ulid CHAR(26) NOT NULL PRIMARY KEY," + , " created_at TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP," + , " deployed_by TEXT NOT NULL," + , " CONSTRAINT valid_ulid_constraint" + , " CHECK (ulid::text ~ '^[0-9A-HJKMNP-TV-Z]{26}$')" + , ")" + ] + + executeStatement_ + "CREATE INDEX IF NOT EXISTS idx_migration_created_at ON migration (created_at)" + + executeStatement_ + "CREATE INDEX IF NOT EXISTS idx_migration_deployed_by ON migration (deployed_by)" diff --git a/components/rds-data/Effectful/Zoo/RdsData/Errors.hs b/components/rds-data/Effectful/Zoo/RdsData/Errors.hs new file mode 100644 --- /dev/null +++ b/components/rds-data/Effectful/Zoo/RdsData/Errors.hs @@ -0,0 +1,5 @@ +module Effectful.Zoo.RdsData.Errors + ( RdsDataError(..) + ) where + +import Effectful.Zoo.RdsData.Errors.RdsDataError diff --git a/components/rds-data/Effectful/Zoo/RdsData/Errors/RdsDataError.hs b/components/rds-data/Effectful/Zoo/RdsData/Errors/RdsDataError.hs new file mode 100644 --- /dev/null +++ b/components/rds-data/Effectful/Zoo/RdsData/Errors/RdsDataError.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Effectful.Zoo.RdsData.Errors.RdsDataError + ( RdsDataError(..) + ) where + +import HaskellWorks.Prelude + +data RdsDataError where + EnvironmentVariableMissing + :: String + -> RdsDataError + + RdsDataError + :: Text + -> RdsDataError + +deriving stock instance Show RdsDataError diff --git a/components/rds-data/Effectful/Zoo/RdsData/Migration.hs b/components/rds-data/Effectful/Zoo/RdsData/Migration.hs new file mode 100644 --- /dev/null +++ b/components/rds-data/Effectful/Zoo/RdsData/Migration.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{- HLINT ignore "Use let" -} + +module Effectful.Zoo.RdsData.Migration + ( migrateDown, + migrateUp, + ) where + +import Amazonka.Types qualified as AWS +import Data.Aeson qualified as J +import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Product.Any +import Data.List qualified as L +import Data.RdsData.Aws +import Data.RdsData.Migration.Types hiding (id) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Effectful +import Effectful.Error.Static +import Effectful.Reader.Static +import Effectful.Zoo.Amazonka.Data +import Effectful.Zoo.Amazonka.Dynamic +import Effectful.Zoo.Core +import Effectful.Zoo.DataLog.Dynamic +import Effectful.Zoo.FileSystem +import Effectful.Zoo.Log.Api +import Effectful.Zoo.Log.Dynamic +import Effectful.Zoo.RdsData.Core +import Effectful.Zoo.RdsData.Errors +import HaskellWorks.Prelude +import Lens.Micro + +migrateDown :: () + => r <: Amazonka + => r <: DataLog AwsLogEntry + => r <: Error AWS.Error + => r <: Error IOException + => r <: Error RdsDataError + => r <: Error YamlDecodeError + => r <: FileSystem + => r <: IOE + => r <: Log Text + => r <: Reader StatementContext + => FilePath + -> Eff r () +migrateDown migrationFp = do + value :: Migration <- readYamlFile migrationFp + + let theSteps = value ^.. the @"plan" . to L.reverse . each . the @"steps" . _Just . to L.reverse . each + + forM_ theSteps $ \case + StepOfDown downStep -> do + info $ "Executing statement: " <> tshow downStep + + let statement = downStep ^. the @"down" . the @1 + + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + StepOfUp _ -> pure () + StepOfCreateTable createTableStatement -> do + statement <- pure $ mconcat + [ "DROP TABLE " <> createTableStatement ^. the @"createTable" . the @"name" + ] + + info $ "Executing statement: " <> statement + + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + StepOfCreateIndex createIndexStatement -> do + statement <- pure $ mconcat + [ "DROP INDEX " <> createIndexStatement ^. the @"createIndex" . the @"name" + ] + + info $ "Executing statement: " <> statement + + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + +migrateUp :: () + => r <: Amazonka + => r <: DataLog AwsLogEntry + => r <: Error AWS.Error + => r <: Error IOException + => r <: Error RdsDataError + => r <: Error YamlDecodeError + => r <: FileSystem + => r <: IOE + => r <: Log Text + => r <: Reader StatementContext + => FilePath + -> Eff r () +migrateUp migrationFp = do + value :: Migration <- readYamlFile migrationFp + + let theSteps = value ^.. the @"plan" . each . the @"steps" . _Just . each + + forM_ theSteps $ \case + StepOfUp upStep -> do + info $ "Executing statement: " <> tshow upStep + + let statement = upStep ^. the @"up" . the @1 + + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + StepOfDown _ -> pure () + StepOfCreateTable createTableStatement -> do + columnClauses <- pure $ + createTableStatement ^.. the @"createTable" . the @"columns" . each . to columnToText + + primaryKeyClause <- pure $ + createTableStatement ^.. the @"createTable" . the @"primaryKey" . _Just . to primaryKeyToText + + constraintClauses <- pure $ + createTableStatement ^.. the @"createTable" . the @"constraints" . _Just . each . to constraintToText + + statement <- pure $ mconcat + [ "CREATE TABLE " <> createTableStatement ^. the @"createTable" . the @"name" <> " (" + , mconcat $ L.intersperse ", " (columnClauses <> primaryKeyClause <> constraintClauses) + , ");\n" + ] + + info $ "Executing create table statement: " <> statement + + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + StepOfCreateIndex createIndexStatement -> do + columnClauses <- pure $ + createIndexStatement ^.. the @"createIndex" . the @"columns" . each + + statement <- pure $ mconcat + [ "CREATE INDEX " <> createIndexStatement ^. the @"createIndex" . the @"name" + , " ON " <> createIndexStatement ^. the @"createIndex" . the @"table" <> " (" + , mconcat $ L.intersperse ", " columnClauses + , ");\n" + ] + + info $ "Executing create index statement: " <> statement + + response <- executeStatement statement + + info $ "Results: " <> T.decodeUtf8 (LBS.toStrict (J.encode (response ^. the @"records"))) + +columnToText :: Column -> Text +columnToText c = + T.intercalate " " $ mconcat + [ [c ^. the @"name"] + , [c ^. the @"type_"] + , [ "NOT NULL" + | c ^. the @"required" + ] + , [ "PRIMARY KEY" + | c ^. the @"primaryKey" + ] + , [ "UNIQUE" + | c ^. the @"unique" + ] + , [ "AUTO_INCREMENT" + | c ^. the @"autoIncrement" + ] + , [ [ "REFERENCES" + , fk ^. the @"table" + , "(" + , fk ^. the @"column" + , ")" + ] & T.intercalate " " + | Just fk <- [c ^. the @"references"] + ] + ] + +primaryKeyToText :: [Text] -> Text +primaryKeyToText cs = + T.intercalate " " + [ "PRIMARY KEY" + , "(" + , T.intercalate ", " cs + , ")" + ] + +constraintToText :: Constraint -> Text +constraintToText c = + T.intercalate " " + [ "CONSTRAINT" + , c ^. the @"name" + , "CHECK" + , "(" + , c ^. the @"check" + , ")" + ] diff --git a/effectful-zoo.cabal b/effectful-zoo.cabal --- a/effectful-zoo.cabal +++ b/effectful-zoo.cabal @@ -1,7 +1,7 @@ cabal-version: 3.4 name: effectful-zoo -version: 0.0.1.0 +version: 0.0.2.0 synopsis: Effectful effects for testing description: See https://hackage.haskell.org/package/effectful-zoo/docs/effectful-zoo.html category: Development @@ -25,6 +25,10 @@ common aeson { build-depends: aeson >= 2.2.3 && < 3 } common aeson-pretty { build-depends: aeson-pretty >= 0.8.10 && < 1 } common amazonka { build-depends: amazonka >= 2 && < 3 } +common amazonka-core { build-depends: amazonka-core >= 2 && < 3 } +common amazonka-rds-data { build-depends: amazonka-rds-data >= 2 && < 3 } +common blockfrost-api { build-depends: blockfrost-api >= 0.11 && < 0.12 } +common blockfrost-client { build-depends: blockfrost-client >= 0.8 && < 0.9 } common bytestring { build-depends: bytestring >= 0.11 && < 1 } common effectful { build-depends: effectful >= 2.5 && < 3 } common effectful-core { build-depends: effectful-core >= 2.5 && < 3 } @@ -32,8 +36,9 @@ common generic-lens { build-depends: generic-lens >= 2.2.2 && < 3 } common hedgehog { build-depends: hedgehog >= 1.5 && < 2 } common HUnit { build-depends: HUnit >= 1.6.2 && < 2 } -common hw-prelude { build-depends: hw-prelude >= 0.0.4 && < 0.1 } +common hw-prelude { build-depends: hw-prelude >= 0.0.4.2 && < 0.1 } common microlens { build-depends: microlens >= 0.4.13.1 && < 0.5 } +common rds-data-codecs { build-depends: rds-data:codecs >= 0.1.1.1 && < 0.2 } common resourcet { build-depends: resourcet >= 1.3 && < 2 } common resourcet-effectful { build-depends: resourcet-effectful >= 1.0.1 && < 2 } common tasty { build-depends: tasty >= 1.4.3 && < 1.5 } @@ -45,10 +50,7 @@ common effectful-zoo-amazonka { build-depends: effectful-zoo:amazonka } common effectful-zoo-core { build-depends: effectful-zoo:core } -common effectful-zoo-datalog { build-depends: effectful-zoo:datalog } common effectful-zoo-hedgehog { build-depends: effectful-zoo:hedgehog } -common effectful-zoo-log { build-depends: effectful-zoo:log } -common effectful-zoo-lazy { build-depends: effectful-zoo:lazy } common project-config default-extensions: AllowAmbiguousTypes @@ -97,16 +99,51 @@ default-language: GHC2021 library core - import: project-config, + import: base, project-config, + aeson, + bytestring, + effectful-core, + effectful-core, + effectful-plugin, effectful, hw-prelude, + text, + time, + yaml, visibility: public - exposed-modules: Effectful.Zoo.Core + exposed-modules: Effectful.Zoo.Console.Data.Writer + Effectful.Zoo.Console.Dynamic + Effectful.Zoo.Console.Dynamic.Api + Effectful.Zoo.Console.Dynamic.Effect + Effectful.Zoo.Console.Dynamic.Run + Effectful.Zoo.Console.Effect + Effectful.Zoo.Console.Static + Effectful.Zoo.Core Effectful.Zoo.Core.Error.Dynamic Effectful.Zoo.Core.Error.Static Effectful.Zoo.Core.Exception Effectful.Zoo.Core.Function Effectful.Zoo.Core.Prim + Effectful.Zoo.DataLog.Api + Effectful.Zoo.DataLog.Data.DataLogger + Effectful.Zoo.DataLog.Data.LogEntry + Effectful.Zoo.DataLog.Dynamic + Effectful.Zoo.DataLog.Static + Effectful.Zoo.FileSystem + Effectful.Zoo.Lazy.Dynamic + Effectful.Zoo.Log.Api + Effectful.Zoo.Log.Api.Generic + Effectful.Zoo.Log.Api.LazyText + Effectful.Zoo.Log.Api.Render + Effectful.Zoo.Log.Api.String + Effectful.Zoo.Log.Api.Text + Effectful.Zoo.Log.Data.Logger + Effectful.Zoo.Log.Data.LogMessage + Effectful.Zoo.Log.Data.Severity + Effectful.Zoo.Log.Dynamic + Effectful.Zoo.Log.Static + Effectful.Zoo.Unsafe + ghc-options: -fplugin=Effectful.Plugin hs-source-dirs: components/core library amazonka @@ -117,9 +154,6 @@ effectful-core, effectful-plugin, effectful-zoo-core, - effectful-zoo-datalog, - effectful-zoo-lazy, - effectful-zoo-log, generic-lens, hw-prelude, microlens, @@ -146,41 +180,45 @@ ghc-options: -fplugin=Effectful.Plugin hs-source-dirs: components/amazonka -library console +library blockfrost import: base, project-config, - effectful, + blockfrost-api, + blockfrost-client, effectful-core, effectful-plugin, effectful-zoo-core, hw-prelude, text, visibility: public - exposed-modules: Effectful.Zoo.Console.Data.Writer - Effectful.Zoo.Console.Dynamic - Effectful.Zoo.Console.Dynamic.Api - Effectful.Zoo.Console.Dynamic.Effect - Effectful.Zoo.Console.Dynamic.Run - Effectful.Zoo.Console.Effect - Effectful.Zoo.Console.Static + exposed-modules: Effectful.Zoo.Blockfrost + Effectful.Zoo.Blockfrost.Api + Effectful.Zoo.Blockfrost.Types + Effectful.Zoo.Blockfrost.Dynamic ghc-options: -fplugin=Effectful.Plugin - hs-source-dirs: components/console + hs-source-dirs: components/blockfrost -library datalog +library rds-data import: base, project-config, + aeson, + amazonka, + amazonka-rds-data, + bytestring, effectful-core, effectful-plugin, + effectful-zoo-amazonka, effectful-zoo-core, + generic-lens, hw-prelude, + microlens, + rds-data-codecs, text, - time, visibility: public - exposed-modules: Effectful.Zoo.DataLog.Api - Effectful.Zoo.DataLog.Data.DataLogger - Effectful.Zoo.DataLog.Data.LogEntry - Effectful.Zoo.DataLog.Dynamic - Effectful.Zoo.DataLog.Static + exposed-modules: Effectful.Zoo.RdsData.Core + Effectful.Zoo.RdsData.Errors + Effectful.Zoo.RdsData.Errors.RdsDataError + Effectful.Zoo.RdsData.Migration ghc-options: -fplugin=Effectful.Plugin - hs-source-dirs: components/datalog + hs-source-dirs: components/rds-data library hedgehog import: base, project-config, @@ -190,8 +228,6 @@ effectful-core, effectful-plugin, effectful-zoo-core, - effectful-zoo-datalog, - effectful-zoo-log, hedgehog, hw-prelude, tasty-hedgehog, @@ -222,46 +258,11 @@ exposed-modules: Effectful.Zoo.HUnit hs-source-dirs: components/hunit -library lazy - import: project-config, - effectful, - effectful-core, - effectful-plugin, - effectful-zoo-core, - hw-prelude, - visibility: public - exposed-modules: Effectful.Zoo.Lazy.Dynamic - ghc-options: -fplugin=Effectful.Plugin - hs-source-dirs: components/lazy - -library log - import: base, project-config, - effectful-core, - effectful-plugin, - effectful-zoo-core, - hw-prelude, - text, - visibility: public - exposed-modules: Effectful.Zoo.Log.Api - Effectful.Zoo.Log.Api.Generic - Effectful.Zoo.Log.Api.LazyText - Effectful.Zoo.Log.Api.Render - Effectful.Zoo.Log.Api.String - Effectful.Zoo.Log.Api.Text - Effectful.Zoo.Log.Data.Logger - Effectful.Zoo.Log.Data.LogMessage - Effectful.Zoo.Log.Data.Severity - Effectful.Zoo.Log.Dynamic - Effectful.Zoo.Log.Static - ghc-options: -fplugin=Effectful.Plugin - hs-source-dirs: components/log - test-suite effectful-zoo-test import: project-config, effectful-core, effectful-zoo-core, effectful-zoo-hedgehog, - effectful-zoo-log, hw-prelude, tasty, type: exitcode-stdio-1.0