Add a swagger ui page for chain index endpoints (#130)

* Add a swagger ui page for chain index endpoints

* Add tighter types for few chain index responses

freer-extras/src/Control/Monad/Freer/Extras/Pagination.hs

@@ -82,6 +82,8 @@ data Page a = Page
     deriving stock (Eq, Ord, Show, Generic, Functor)
     deriving anyclass (ToJSON, FromJSON)
 
+deriving instance OpenApi.ToSchema a => OpenApi.ToSchema (Page a)
+
 -- | Given a 'Set', request the 'Page' with the given 'PageQuery'.
 pageOf
   :: (Eq a)

playground-common/src/PSGenerator/Common.hs

@@ -34,6 +34,7 @@ import Ledger.Tx.CardanoAPI (FromCardanoError, ToCardanoError)
 import Ledger.Typed.Tx (ConnectionError, WrongOutTypeError)
 import Ledger.Value (AssetClass, CurrencySymbol, TokenName, Value)
 import Playground.Types (ContractCall, FunctionSchema, KnownCurrency)
+import Plutus.ChainIndex.Api (IsUtxoResponse, UtxosResponse)
 import Plutus.ChainIndex.ChainIndexError (ChainIndexError)
 import Plutus.ChainIndex.ChainIndexLog (ChainIndexLog)
 import Plutus.ChainIndex.Tx (ChainIndexTx, ChainIndexTxOutputs)
@@ -358,6 +359,8 @@ ledgerTypes =
     , equal . genericShow . argonaut $ mkSumType @PABResp
     , equal . genericShow . argonaut $ mkSumType @ChainIndexQuery
     , equal . genericShow . argonaut $ mkSumType @ChainIndexResponse
+    , equal . genericShow . argonaut $ mkSumType @IsUtxoResponse
+    , equal . genericShow . argonaut $ mkSumType @UtxosResponse
     , equal . genericShow . argonaut $ mkSumType @ChainIndexTx
     , equal . genericShow . argonaut $ mkSumType @ChainIndexTxOutputs
     , equal . genericShow . argonaut $ mkSumType @ChainIndexTxOut

plutus-chain-index-core/plutus-chain-index-core.cabal

@@ -80,6 +80,7 @@ library
         lens -any,
         memory -any,
         nothunks -any,
+        openapi3 -any,
         ouroboros-network -any,
         ouroboros-network-framework -any,
         ouroboros-consensus -any,
@@ -96,7 +97,9 @@ library
         bytestring -any,
         text -any,
         servant -any,
+        servant-openapi3 -any,
         servant-server -any,
+        servant-swagger-ui -any,
         stm -any,
         mtl -any,
         warp -any,

plutus-chain-index-core/src/Plutus/ChainIndex/Api.hs

@@ -1,24 +1,37 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeOperators         #-}
+
 module Plutus.ChainIndex.Api
   ( API
   , FromHashAPI
+  , FullAPI
+  , IsUtxoResponse(..)
+  , SwaggerAPI
   , UtxoAtAddressRequest(..)
+  , UtxosResponse(..)
   , UtxoWithCurrencyRequest(..)
+  , swagger
   ) where
 
 import Control.Monad.Freer.Extras.Pagination (Page, PageQuery)
-import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson (FromJSON, ToJSON, Value)
+import Data.OpenApi qualified as OpenApi
+import Data.Proxy (Proxy (..))
 import GHC.Generics (Generic)
 import Ledger (AssetClass, Datum, DatumHash, MintingPolicy, MintingPolicyHash, Redeemer, RedeemerHash, StakeValidator,
                StakeValidatorHash, TxId, Validator, ValidatorHash)
 import Ledger.Credential (Credential)
 import Ledger.Tx (ChainIndexTxOut, TxOutRef)
 import Plutus.ChainIndex.Tx (ChainIndexTx)
 import Plutus.ChainIndex.Types (Diagnostics, Tip)
-import Servant.API (Get, JSON, NoContent, Post, Put, ReqBody, (:<|>), (:>))
+import Servant qualified
+import Servant.API (Description, Get, JSON, NoContent, Post, Put, ReqBody, (:<|>), (:>))
+import Servant.OpenApi (toOpenApi)
+import Servant.Swagger.UI (SwaggerSchemaUI, SwaggerSchemaUI', swaggerSchemaUIServer)
 
 -- | When requesting UTxOs of a given address, you need to provide the address,
 -- and optionnally the number of elements per page and the last item of the last
@@ -76,7 +89,7 @@ data UtxoAtAddressRequest = UtxoAtAddressRequest
     { pageQuery  :: Maybe (PageQuery TxOutRef)
     , credential :: Credential
     }
-    deriving (Show, Eq, Generic, FromJSON, ToJSON)
+    deriving (Show, Eq, Generic, FromJSON, ToJSON, OpenApi.ToSchema)
 
 -- | See the comment on 'UtxoAtAddressRequest'.
 --
@@ -100,23 +113,45 @@ data UtxoWithCurrencyRequest = UtxoWithCurrencyRequest
     { pageQuery :: Maybe (PageQuery TxOutRef)
     , currency  :: AssetClass
     }
-    deriving (Show, Eq, Generic, FromJSON, ToJSON)
+    deriving (Show, Eq, Generic, FromJSON, ToJSON, OpenApi.ToSchema)
+
+-- | Response type for the utxo-{at-address|with-currency} endpoints.
+data UtxosResponse = UtxosResponse
+    { currentTip :: Tip
+    , page       :: Page TxOutRef
+    }
+    deriving (Show, Eq, Generic, FromJSON, ToJSON, OpenApi.ToSchema)
+
+-- | Response type for the is-utxo endpoint.
+data IsUtxoResponse = IsUtxoResponse
+    { currentTip :: Tip
+    , isUtxo     :: Bool
+    }
+    deriving (Show, Eq, Generic, FromJSON, ToJSON, OpenApi.ToSchema)
 
 type API
-    = "healthcheck" :> Get '[JSON] NoContent
+    = "healthcheck" :> Description "Is the server alive?" :> Get '[JSON] NoContent
     :<|> "from-hash" :> FromHashAPI
-    :<|> "tx-out" :> ReqBody '[JSON] TxOutRef :> Post '[JSON] ChainIndexTxOut
-    :<|> "tx" :> ReqBody '[JSON] TxId :> Post '[JSON] ChainIndexTx
-    :<|> "is-utxo" :> ReqBody '[JSON] TxOutRef :> Post '[JSON] (Tip, Bool)
-    :<|> "utxo-at-address" :> ReqBody '[JSON] UtxoAtAddressRequest :> Post '[JSON] (Tip, Page TxOutRef)
-    :<|> "utxo-with-currency" :> ReqBody '[JSON] UtxoWithCurrencyRequest :> Post '[JSON] (Tip, Page TxOutRef)
-    :<|> "tip" :> Get '[JSON] Tip
-    :<|> "collect-garbage" :> Put '[JSON] NoContent
-    :<|> "diagnostics" :> Get '[JSON] Diagnostics
+    :<|> "tx-out" :> Description "Get a transaction output from its reference." :> ReqBody '[JSON] TxOutRef :> Post '[JSON] ChainIndexTxOut
+    :<|> "tx" :> Description "Get a transaction from its id." :> ReqBody '[JSON] TxId :> Post '[JSON] ChainIndexTx
+    :<|> "is-utxo" :> Description "Check if the reference is an UTxO." :> ReqBody '[JSON] TxOutRef :> Post '[JSON] IsUtxoResponse
+    :<|> "utxo-at-address" :> Description "Get all UTxOs at an address." :> ReqBody '[JSON] UtxoAtAddressRequest :> Post '[JSON] UtxosResponse
+    :<|> "utxo-with-currency" :> Description "Get all UTxOs with a currency." :> ReqBody '[JSON] UtxoWithCurrencyRequest :> Post '[JSON] UtxosResponse
+    :<|> "tip" :> Description "Get the current synced tip." :> Get '[JSON] Tip
+    :<|> "collect-garbage" :> Description "Collect chain index garbage to free up space." :> Put '[JSON] NoContent
+    :<|> "diagnostics" :> Description "Get the current stats of the chain index." :> Get '[JSON] Diagnostics
 
 type FromHashAPI =
-    "datum" :> ReqBody '[JSON] DatumHash :> Post '[JSON] Datum
-    :<|> "validator" :> ReqBody '[JSON] ValidatorHash :> Post '[JSON] Validator
-    :<|> "minting-policy" :> ReqBody '[JSON] MintingPolicyHash :> Post '[JSON] MintingPolicy
-    :<|> "stake-validator" :> ReqBody '[JSON] StakeValidatorHash :> Post '[JSON] StakeValidator
-    :<|> "redeemer" :> ReqBody '[JSON] RedeemerHash :> Post '[JSON] Redeemer
+    "datum" :> Description "Get a datum from its hash." :> ReqBody '[JSON] DatumHash :> Post '[JSON] Datum
+    :<|> "validator" :> Description "Get a validator script from its hash." :> ReqBody '[JSON] ValidatorHash :> Post '[JSON] Validator
+    :<|> "minting-policy" :> Description "Get a minting policy from its hash." :> ReqBody '[JSON] MintingPolicyHash :> Post '[JSON] MintingPolicy
+    :<|> "stake-validator" :> Description "Get a stake validator from its hash." :> ReqBody '[JSON] StakeValidatorHash :> Post '[JSON] StakeValidator
+    :<|> "redeemer" :> Description "Get a redeemer from its hash." :> ReqBody '[JSON] RedeemerHash :> Post '[JSON] Redeemer
+
+type SwaggerAPI = "swagger" :> SwaggerSchemaUI "swagger-ui" "swagger.json"
+
+swagger :: forall dir api. Servant.Server api ~ Servant.Handler Value => Servant.Server (SwaggerSchemaUI' dir api)
+swagger = swaggerSchemaUIServer (toOpenApi (Proxy @API))
+
+-- We don't include `SwaggerAPI` into `API` to exclude it from the effects code.
+type FullAPI = API :<|> SwaggerAPI

plutus-chain-index-core/src/Plutus/ChainIndex/Client.hs

@@ -22,16 +22,15 @@ module Plutus.ChainIndex.Client(
 
 import Control.Monad.Freer (Eff, LastMember, Member, sendM, type (~>))
 import Control.Monad.Freer.Error (Error, throwError)
-import Control.Monad.Freer.Extras.Pagination (Page)
 import Control.Monad.Freer.Reader (Reader, ask)
 import Control.Monad.IO.Class (MonadIO (..))
 import Data.Proxy (Proxy (..))
 import Ledger (Datum, DatumHash, MintingPolicy, MintingPolicyHash, Redeemer, RedeemerHash, StakeValidator,
                StakeValidatorHash, TxId, Validator, ValidatorHash)
 import Ledger.Tx (ChainIndexTxOut, TxOutRef)
 import Network.HTTP.Types.Status (Status (..))
-import Plutus.ChainIndex.Api (API, UtxoAtAddressRequest (UtxoAtAddressRequest),
-                              UtxoWithCurrencyRequest (UtxoWithCurrencyRequest))
+import Plutus.ChainIndex.Api (API, IsUtxoResponse, UtxoAtAddressRequest (UtxoAtAddressRequest),
+                              UtxoWithCurrencyRequest (UtxoWithCurrencyRequest), UtxosResponse)
 import Plutus.ChainIndex.Effects (ChainIndexQueryEffect (..))
 import Plutus.ChainIndex.Tx (ChainIndexTx)
 import Plutus.ChainIndex.Types (Tip)
@@ -51,9 +50,9 @@ getRedeemer :: RedeemerHash -> ClientM Redeemer
 
 getTxOut :: TxOutRef -> ClientM ChainIndexTxOut
 getTx :: TxId -> ClientM ChainIndexTx
-getIsUtxo :: TxOutRef -> ClientM (Tip, Bool)
-getUtxoSetAtAddress :: UtxoAtAddressRequest -> ClientM (Tip, Page TxOutRef)
-getUtxoSetWithCurrency :: UtxoWithCurrencyRequest -> ClientM (Tip, Page TxOutRef)
+getIsUtxo :: TxOutRef -> ClientM IsUtxoResponse
+getUtxoSetAtAddress :: UtxoAtAddressRequest -> ClientM UtxosResponse
+getUtxoSetWithCurrency :: UtxoWithCurrencyRequest -> ClientM UtxosResponse
 getTip :: ClientM Tip
 
 (healthCheck, (getDatum, getValidator, getMintingPolicy, getStakeValidator, getRedeemer), getTxOut, getTx, getIsUtxo, getUtxoSetAtAddress, getUtxoSetWithCurrency, getTip, collectGarbage) =

plutus-chain-index-core/src/Plutus/ChainIndex/Effects.hs

@@ -26,12 +26,13 @@ module Plutus.ChainIndex.Effects(
     , getDiagnostics
     ) where
 
-import Control.Monad.Freer.Extras.Pagination (Page, PageQuery)
+import Control.Monad.Freer.Extras.Pagination (PageQuery)
 import Control.Monad.Freer.TH (makeEffect)
 import Ledger (AssetClass, Datum, DatumHash, MintingPolicy, MintingPolicyHash, Redeemer, RedeemerHash, StakeValidator,
                StakeValidatorHash, TxId, Validator, ValidatorHash)
 import Ledger.Credential (Credential)
 import Ledger.Tx (ChainIndexTxOut, TxOutRef)
+import Plutus.ChainIndex.Api (IsUtxoResponse, UtxosResponse)
 import Plutus.ChainIndex.Tx (ChainIndexTx)
 import Plutus.ChainIndex.Types (BlockProcessOption, Diagnostics, Point, Tip)
 
@@ -59,16 +60,16 @@ data ChainIndexQueryEffect r where
     TxFromTxId :: TxId -> ChainIndexQueryEffect (Maybe ChainIndexTx)
 
     -- | Whether a tx output is part of the UTXO set
-    UtxoSetMembership :: TxOutRef -> ChainIndexQueryEffect (Tip, Bool)
+    UtxoSetMembership :: TxOutRef -> ChainIndexQueryEffect IsUtxoResponse
 
     -- | Unspent outputs located at addresses with the given credential.
-    UtxoSetAtAddress :: PageQuery TxOutRef -> Credential -> ChainIndexQueryEffect (Tip, Page TxOutRef)
+    UtxoSetAtAddress :: PageQuery TxOutRef -> Credential -> ChainIndexQueryEffect UtxosResponse
 
     -- | Unspent outputs containing a specific currency ('AssetClass').
     --
     -- Note that requesting unspent outputs containing Ada should not return
     -- anything, as this request will always return all unspent outputs.
-    UtxoSetWithCurrency :: PageQuery TxOutRef -> AssetClass -> ChainIndexQueryEffect (Tip, Page TxOutRef)
+    UtxoSetWithCurrency :: PageQuery TxOutRef -> AssetClass -> ChainIndexQueryEffect UtxosResponse
 
     -- | Get the tip of the chain index
     GetTip :: ChainIndexQueryEffect Tip

plutus-chain-index-core/src/Plutus/ChainIndex/Emulator/Handlers.hs

@@ -35,6 +35,7 @@ import Ledger (Address (addressCredential), ChainIndexTxOut (..), MintingPolicy
                StakeValidatorHash (StakeValidatorHash), TxId, TxOut (txOutAddress), TxOutRef (..),
                Validator (Validator), ValidatorHash (ValidatorHash), txOutDatumHash, txOutValue)
 import Ledger.Scripts (ScriptHash (ScriptHash))
+import Plutus.ChainIndex.Api (IsUtxoResponse (IsUtxoResponse), UtxosResponse (UtxosResponse))
 import Plutus.ChainIndex.ChainIndexError (ChainIndexError (..))
 import Plutus.ChainIndex.ChainIndexLog (ChainIndexLog (..))
 import Plutus.ChainIndex.Effects (ChainIndexControlEffect (..), ChainIndexQueryEffect (..))
@@ -124,7 +125,7 @@ handleQuery = \case
         utxo <- gets (utxoState . view utxoIndex)
         case tip utxo of
             TipAtGenesis -> throwError QueryFailedNoTip
-            tp           -> pure (tp, TxUtxoBalance.isUnspentOutput r utxo)
+            tp           -> pure (IsUtxoResponse tp (TxUtxoBalance.isUnspentOutput r utxo))
     UtxoSetAtAddress pageQuery cred -> do
         state <- get
         let outRefs = view (diskState . addressMap . at cred) state
@@ -135,8 +136,8 @@ handleQuery = \case
         case tip utxo of
             TipAtGenesis -> do
                 logWarn TipIsGenesis
-                pure (TipAtGenesis, pageOf pageQuery Set.empty)
-            tp           -> pure (tp, page)
+                pure (UtxosResponse TipAtGenesis (pageOf pageQuery Set.empty))
+            tp           -> pure (UtxosResponse tp page)
     UtxoSetWithCurrency pageQuery assetClass -> do
         state <- get
         let outRefs = view (diskState . assetClassMap . at assetClass) state
@@ -146,8 +147,8 @@ handleQuery = \case
         case tip utxo of
             TipAtGenesis -> do
                 logWarn TipIsGenesis
-                pure (TipAtGenesis, pageOf pageQuery Set.empty)
-            tp           -> pure (tp, page)
+                pure (UtxosResponse TipAtGenesis (pageOf pageQuery Set.empty))
+            tp           -> pure (UtxosResponse tp page)
     GetTip ->
         gets (tip . utxoState . view utxoIndex)
 

plutus-chain-index-core/src/Plutus/ChainIndex/Emulator/Server.hs

@@ -23,10 +23,11 @@ import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
 import Network.Wai.Handler.Warp qualified as Warp
 import Plutus.ChainIndex (ChainIndexError, ChainIndexLog)
-import Plutus.ChainIndex.Api (API)
+import Plutus.ChainIndex.Api (API, FullAPI, swagger)
 import Plutus.ChainIndex.Effects (ChainIndexControlEffect, ChainIndexQueryEffect)
 import Plutus.ChainIndex.Emulator.Handlers (ChainIndexEmulatorState (..), handleControl, handleQuery)
 import Plutus.ChainIndex.Server hiding (serveChainIndexQueryServer)
+import Servant.API ((:<|>) (..))
 import Servant.Server (Handler, ServerError, err500, errBody, hoistServer, serve)
 
 serveChainIndexQueryServer ::
@@ -35,7 +36,7 @@ serveChainIndexQueryServer ::
     -> IO ()
 serveChainIndexQueryServer port diskState = do
     let server = hoistServer (Proxy @API) (runChainIndexQuery diskState) serveChainIndex
-    Warp.run port (serve (Proxy @API) server)
+    Warp.run port (serve (Proxy @FullAPI) (server :<|> swagger))
 
 runChainIndexQuery ::
     TVar ChainIndexEmulatorState