{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators    #-}
module Plutus.ChainIndex.Client(
    -- * HTTP Client handler
    handleChainIndexClient
    -- * Servant client functions
    , healthCheck
    , collectGarbage

    , getDatum
    , getValidator
    , getMintingPolicy
    , getStakeValidator
    , getRedeemer

    , getTxOut
    , getTx
    , getUnspentTxOut
    , getIsUtxo
    , getUtxoSetAtAddress
    , getUnspentTxOutsAtAddress
    , getUtxoSetWithCurrency
    , getTxs
    , getTxoSetAtAddress
    , getTip
    ) where

import Control.Monad.Freer (Eff, LastMember, Member, sendM, type (~>))
import Control.Monad.Freer.Error (Error, throwError)
import Control.Monad.Freer.Reader (Reader, ask)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Proxy (Proxy (..))
import Ledger (TxId)
import Ledger.Tx (DecoratedTxOut, TxOutRef, Versioned)
import Network.HTTP.Types.Status (Status (..))
import Plutus.ChainIndex.Api (API, IsUtxoResponse, QueryAtAddressRequest (QueryAtAddressRequest), QueryResponse,
                              TxoAtAddressRequest (TxoAtAddressRequest), TxosResponse,
                              UtxoAtAddressRequest (UtxoAtAddressRequest),
                              UtxoWithCurrencyRequest (UtxoWithCurrencyRequest), UtxosResponse)
import Plutus.ChainIndex.Effects (ChainIndexQueryEffect (..))
import Plutus.ChainIndex.Tx (ChainIndexTx)
import Plutus.ChainIndex.Types (Tip)
import Plutus.V1.Ledger.Api (Datum, DatumHash, MintingPolicy, MintingPolicyHash, Redeemer, RedeemerHash, StakeValidator,
                             StakeValidatorHash, Validator, ValidatorHash)
import Servant (NoContent, (:<|>) (..))
import Servant.Client (ClientEnv, ClientError (..), ClientM, client, runClientM)
import Servant.Client.Core.Response (ResponseF (..))

healthCheck :: ClientM NoContent
collectGarbage :: ClientM NoContent

-- TODO: Catch 404 error
getDatum :: DatumHash -> ClientM Datum
getValidator :: ValidatorHash -> ClientM (Versioned Validator)
getMintingPolicy :: MintingPolicyHash -> ClientM (Versioned MintingPolicy)
getStakeValidator :: StakeValidatorHash -> ClientM (Versioned StakeValidator)
getRedeemer :: RedeemerHash -> ClientM Redeemer

getTxOut :: TxOutRef -> ClientM DecoratedTxOut
getTx :: TxId -> ClientM ChainIndexTx
getUnspentTxOut :: TxOutRef -> ClientM DecoratedTxOut
getIsUtxo :: TxOutRef -> ClientM IsUtxoResponse
getUtxoSetAtAddress :: UtxoAtAddressRequest -> ClientM UtxosResponse
getUnspentTxOutsAtAddress :: QueryAtAddressRequest -> ClientM (QueryResponse [(TxOutRef, DecoratedTxOut)])
getDatumsAtAddress :: QueryAtAddressRequest -> ClientM (QueryResponse [Datum])
getUtxoSetWithCurrency :: UtxoWithCurrencyRequest -> ClientM UtxosResponse
getTxs :: [TxId] -> ClientM [ChainIndexTx]
getTxoSetAtAddress :: TxoAtAddressRequest -> ClientM TxosResponse
getTip :: ClientM Tip

(ClientM NoContent
healthCheck, (DatumHash -> ClientM Datum
getDatum, ValidatorHash -> ClientM (Versioned Validator)
getValidator, MintingPolicyHash -> ClientM (Versioned MintingPolicy)
getMintingPolicy, StakeValidatorHash -> ClientM (Versioned StakeValidator)
getStakeValidator, RedeemerHash -> ClientM Redeemer
getRedeemer), TxOutRef -> ClientM DecoratedTxOut
getTxOut, TxOutRef -> ClientM DecoratedTxOut
getUnspentTxOut, TxId -> ClientM ChainIndexTx
getTx, TxOutRef -> ClientM IsUtxoResponse
getIsUtxo, UtxoAtAddressRequest -> ClientM UtxosResponse
getUtxoSetAtAddress, QueryAtAddressRequest
-> ClientM (QueryResponse [(TxOutRef, DecoratedTxOut)])
getUnspentTxOutsAtAddress, QueryAtAddressRequest -> ClientM (QueryResponse [Datum])
getDatumsAtAddress, UtxoWithCurrencyRequest -> ClientM UtxosResponse
getUtxoSetWithCurrency, [TxId] -> ClientM [ChainIndexTx]
getTxs, TxoAtAddressRequest -> ClientM TxosResponse
getTxoSetAtAddress, ClientM Tip
getTip, ClientM NoContent
collectGarbage) =
    (ClientM NoContent
healthCheck_, (DatumHash -> ClientM Datum
getDatum_, ValidatorHash -> ClientM (Versioned Validator)
getValidator_, MintingPolicyHash -> ClientM (Versioned MintingPolicy)
getMintingPolicy_, StakeValidatorHash -> ClientM (Versioned StakeValidator)
getStakeValidator_, RedeemerHash -> ClientM Redeemer
getRedeemer_), TxOutRef -> ClientM DecoratedTxOut
getTxOut_, TxOutRef -> ClientM DecoratedTxOut
getUnspentTxOut_, TxId -> ClientM ChainIndexTx
getTx_, TxOutRef -> ClientM IsUtxoResponse
getIsUtxo_, UtxoAtAddressRequest -> ClientM UtxosResponse
getUtxoSetAtAddress_, QueryAtAddressRequest
-> ClientM (QueryResponse [(TxOutRef, DecoratedTxOut)])
getUnspentTxOutsAtAddress_, QueryAtAddressRequest -> ClientM (QueryResponse [Datum])
getDatumsAtAddress_, UtxoWithCurrencyRequest -> ClientM UtxosResponse
getUtxoSetWithCurrency_, [TxId] -> ClientM [ChainIndexTx]
getTxs_, TxoAtAddressRequest -> ClientM TxosResponse
getTxoSetAtAddress_, ClientM Tip
getTip_, ClientM NoContent
collectGarbage_) where
        ClientM NoContent
healthCheck_
            :<|> (DatumHash -> ClientM Datum
getDatum_ :<|> ValidatorHash -> ClientM (Versioned Validator)
getValidator_ :<|> MintingPolicyHash -> ClientM (Versioned MintingPolicy)
getMintingPolicy_ :<|> StakeValidatorHash -> ClientM (Versioned StakeValidator)
getStakeValidator_ :<|> RedeemerHash -> ClientM Redeemer
getRedeemer_)
            :<|> TxOutRef -> ClientM DecoratedTxOut
getTxOut_
            :<|> TxOutRef -> ClientM DecoratedTxOut
getUnspentTxOut_
            :<|> TxId -> ClientM ChainIndexTx
getTx_
            :<|> TxOutRef -> ClientM IsUtxoResponse
getIsUtxo_
            :<|> UtxoAtAddressRequest -> ClientM UtxosResponse
getUtxoSetAtAddress_
            :<|> QueryAtAddressRequest
-> ClientM (QueryResponse [(TxOutRef, DecoratedTxOut)])
getUnspentTxOutsAtAddress_
            :<|> QueryAtAddressRequest -> ClientM (QueryResponse [Datum])
getDatumsAtAddress_
            :<|> UtxoWithCurrencyRequest -> ClientM UtxosResponse
getUtxoSetWithCurrency_
            :<|> [TxId] -> ClientM [ChainIndexTx]
getTxs_
            :<|> TxoAtAddressRequest -> ClientM TxosResponse
getTxoSetAtAddress_
            :<|> ClientM Tip
getTip_
            :<|> ClientM NoContent
collectGarbage_
            :<|> ClientM Diagnostics
_ = Proxy API -> Client ClientM API
forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client (Proxy API
forall k (t :: k). Proxy t
Proxy @API)

-- | Handle 'ChainIndexQueryEffect' by making HTTP calls to a remote
--   server.
handleChainIndexClient ::
    forall m effs.
    ( LastMember m effs
    , Member (Reader ClientEnv) effs
    , MonadIO m
    , Member (Error ClientError) effs
    )
    => ChainIndexQueryEffect
    ~> Eff effs
handleChainIndexClient :: ChainIndexQueryEffect ~> Eff effs
handleChainIndexClient ChainIndexQueryEffect x
event = do
    ClientEnv
clientEnv <- Eff effs ClientEnv
forall r (effs :: [* -> *]). Member (Reader r) effs => Eff effs r
ask
    let
        runClient :: forall a. ClientM a -> Eff effs a
        runClient :: ClientM a -> Eff effs a
runClient ClientM a
a = (m (Either ClientError a) -> Eff effs (Either ClientError a)
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM (m (Either ClientError a) -> Eff effs (Either ClientError a))
-> m (Either ClientError a) -> Eff effs (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ IO (Either ClientError a) -> m (Either ClientError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ClientError a) -> m (Either ClientError a))
-> IO (Either ClientError a) -> m (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ ClientM a -> ClientEnv -> IO (Either ClientError a)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM a
a ClientEnv
clientEnv) Eff effs (Either ClientError a)
-> (Either ClientError a -> Eff effs a) -> Eff effs a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ClientError -> Eff effs a)
-> (a -> Eff effs a) -> Either ClientError a -> Eff effs a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> Eff effs a
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError a -> Eff effs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        runClientMaybe :: forall a. ClientM a -> Eff effs (Maybe a)
        runClientMaybe :: ClientM a -> Eff effs (Maybe a)
runClientMaybe ClientM a
a = do
            Either ClientError a
response <- m (Either ClientError a) -> Eff effs (Either ClientError a)
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM (m (Either ClientError a) -> Eff effs (Either ClientError a))
-> m (Either ClientError a) -> Eff effs (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ IO (Either ClientError a) -> m (Either ClientError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ClientError a) -> m (Either ClientError a))
-> IO (Either ClientError a) -> m (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ ClientM a -> ClientEnv -> IO (Either ClientError a)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM a
a ClientEnv
clientEnv
            case Either ClientError a
response of
                Right a
a'                                                                     -> Maybe a -> Eff effs (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a')

                -- convert 404 (NOT FOUND) to 'Nothing'
                Left (FailureResponse RequestF () (BaseUrl, ByteString)
_ Response{responseStatusCode :: forall a. ResponseF a -> Status
responseStatusCode=Status{statusCode :: Status -> Int
statusCode=Int
404}}) -> Maybe a -> Eff effs (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
                Left ClientError
e                                                                       -> ClientError -> Eff effs (Maybe a)
forall e (effs :: [* -> *]) a.
Member (Error e) effs =>
e -> Eff effs a
throwError ClientError
e
    case ChainIndexQueryEffect x
event of
        DatumFromHash DatumHash
d               -> ClientM Datum -> Eff effs (Maybe Datum)
forall a. ClientM a -> Eff effs (Maybe a)
runClientMaybe (DatumHash -> ClientM Datum
getDatum DatumHash
d)
        ValidatorFromHash ValidatorHash
d           -> ClientM (Versioned Validator)
-> Eff effs (Maybe (Versioned Validator))
forall a. ClientM a -> Eff effs (Maybe a)
runClientMaybe (ValidatorHash -> ClientM (Versioned Validator)
getValidator ValidatorHash
d)
        MintingPolicyFromHash MintingPolicyHash
d       -> ClientM (Versioned MintingPolicy)
-> Eff effs (Maybe (Versioned MintingPolicy))
forall a. ClientM a -> Eff effs (Maybe a)
runClientMaybe (MintingPolicyHash -> ClientM (Versioned MintingPolicy)
getMintingPolicy MintingPolicyHash
d)
        StakeValidatorFromHash StakeValidatorHash
d      -> ClientM (Versioned StakeValidator)
-> Eff effs (Maybe (Versioned StakeValidator))
forall a. ClientM a -> Eff effs (Maybe a)
runClientMaybe (StakeValidatorHash -> ClientM (Versioned StakeValidator)
getStakeValidator StakeValidatorHash
d)
        RedeemerFromHash RedeemerHash
d            -> ClientM Redeemer -> Eff effs (Maybe Redeemer)
forall a. ClientM a -> Eff effs (Maybe a)
runClientMaybe (RedeemerHash -> ClientM Redeemer
getRedeemer RedeemerHash
d)
        TxFromTxId TxId
t                  -> ClientM ChainIndexTx -> Eff effs (Maybe ChainIndexTx)
forall a. ClientM a -> Eff effs (Maybe a)
runClientMaybe (TxId -> ClientM ChainIndexTx
getTx TxId
t)
        TxOutFromRef TxOutRef
r                -> ClientM DecoratedTxOut -> Eff effs (Maybe DecoratedTxOut)
forall a. ClientM a -> Eff effs (Maybe a)
runClientMaybe (TxOutRef -> ClientM DecoratedTxOut
getTxOut TxOutRef
r)
        UnspentTxOutFromRef TxOutRef
r         -> ClientM DecoratedTxOut -> Eff effs (Maybe DecoratedTxOut)
forall a. ClientM a -> Eff effs (Maybe a)
runClientMaybe (TxOutRef -> ClientM DecoratedTxOut
getUnspentTxOut TxOutRef
r)
        UtxoSetMembership TxOutRef
r           -> ClientM IsUtxoResponse -> Eff effs IsUtxoResponse
forall a. ClientM a -> Eff effs a
runClient (TxOutRef -> ClientM IsUtxoResponse
getIsUtxo TxOutRef
r)
        UtxoSetAtAddress PageQuery TxOutRef
pq Credential
a         -> ClientM UtxosResponse -> Eff effs UtxosResponse
forall a. ClientM a -> Eff effs a
runClient (UtxoAtAddressRequest -> ClientM UtxosResponse
getUtxoSetAtAddress (UtxoAtAddressRequest -> ClientM UtxosResponse)
-> UtxoAtAddressRequest -> ClientM UtxosResponse
forall a b. (a -> b) -> a -> b
$ Maybe (PageQuery TxOutRef) -> Credential -> UtxoAtAddressRequest
UtxoAtAddressRequest (PageQuery TxOutRef -> Maybe (PageQuery TxOutRef)
forall a. a -> Maybe a
Just PageQuery TxOutRef
pq) Credential
a)
        UnspentTxOutSetAtAddress PageQuery TxOutRef
pq Credential
a -> ClientM (QueryResponse [(TxOutRef, DecoratedTxOut)])
-> Eff effs (QueryResponse [(TxOutRef, DecoratedTxOut)])
forall a. ClientM a -> Eff effs a
runClient (QueryAtAddressRequest
-> ClientM (QueryResponse [(TxOutRef, DecoratedTxOut)])
getUnspentTxOutsAtAddress (QueryAtAddressRequest
 -> ClientM (QueryResponse [(TxOutRef, DecoratedTxOut)]))
-> QueryAtAddressRequest
-> ClientM (QueryResponse [(TxOutRef, DecoratedTxOut)])
forall a b. (a -> b) -> a -> b
$ Maybe (PageQuery TxOutRef) -> Credential -> QueryAtAddressRequest
QueryAtAddressRequest (PageQuery TxOutRef -> Maybe (PageQuery TxOutRef)
forall a. a -> Maybe a
Just PageQuery TxOutRef
pq) Credential
a)
        DatumsAtAddress PageQuery TxOutRef
pq Credential
a          -> ClientM (QueryResponse [Datum]) -> Eff effs (QueryResponse [Datum])
forall a. ClientM a -> Eff effs a
runClient (QueryAtAddressRequest -> ClientM (QueryResponse [Datum])
getDatumsAtAddress (QueryAtAddressRequest -> ClientM (QueryResponse [Datum]))
-> QueryAtAddressRequest -> ClientM (QueryResponse [Datum])
forall a b. (a -> b) -> a -> b
$ Maybe (PageQuery TxOutRef) -> Credential -> QueryAtAddressRequest
QueryAtAddressRequest (PageQuery TxOutRef -> Maybe (PageQuery TxOutRef)
forall a. a -> Maybe a
Just PageQuery TxOutRef
pq) Credential
a)
        UtxoSetWithCurrency PageQuery TxOutRef
pq AssetClass
a      -> ClientM UtxosResponse -> Eff effs UtxosResponse
forall a. ClientM a -> Eff effs a
runClient (UtxoWithCurrencyRequest -> ClientM UtxosResponse
getUtxoSetWithCurrency (UtxoWithCurrencyRequest -> ClientM UtxosResponse)
-> UtxoWithCurrencyRequest -> ClientM UtxosResponse
forall a b. (a -> b) -> a -> b
$ Maybe (PageQuery TxOutRef) -> AssetClass -> UtxoWithCurrencyRequest
UtxoWithCurrencyRequest (PageQuery TxOutRef -> Maybe (PageQuery TxOutRef)
forall a. a -> Maybe a
Just PageQuery TxOutRef
pq) AssetClass
a)
        TxsFromTxIds [TxId]
t                -> ClientM [ChainIndexTx] -> Eff effs [ChainIndexTx]
forall a. ClientM a -> Eff effs a
runClient ([TxId] -> ClientM [ChainIndexTx]
getTxs [TxId]
t)
        TxoSetAtAddress PageQuery TxOutRef
pq Credential
a          -> ClientM TxosResponse -> Eff effs TxosResponse
forall a. ClientM a -> Eff effs a
runClient (TxoAtAddressRequest -> ClientM TxosResponse
getTxoSetAtAddress (TxoAtAddressRequest -> ClientM TxosResponse)
-> TxoAtAddressRequest -> ClientM TxosResponse
forall a b. (a -> b) -> a -> b
$ Maybe (PageQuery TxOutRef) -> Credential -> TxoAtAddressRequest
TxoAtAddressRequest (PageQuery TxOutRef -> Maybe (PageQuery TxOutRef)
forall a. a -> Maybe a
Just PageQuery TxOutRef
pq) Credential
a)
        ChainIndexQueryEffect x
GetTip                        -> ClientM Tip -> Eff effs Tip
forall a. ClientM a -> Eff effs a
runClient ClientM Tip
getTip