Add OpenAPI schema

src/exe/write-openapi-schema/Main.hs

@@ -0,0 +1,13 @@
+module Main where
+
+import Data.Aeson.Encode.Pretty (encodePretty)
+import Data.ByteString.Lazy qualified as BSL
+import Data.Proxy (Proxy (..))
+import Servant.OpenApi (toOpenApi)
+import System.Environment qualified
+import Wst.Server.Types (APIInEra)
+
+main :: IO ()
+main = do
+  fp:_ <- System.Environment.getArgs
+  BSL.writeFile fp $ encodePretty $ toOpenApi $ Proxy @APIInEra

src/lib/SmartTokens/Types/ProtocolParams.hs

@@ -1,18 +1,25 @@
 {-# LANGUAGE NamedFieldPuns       #-}
+{-# LANGUAGE OverloadedLists      #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-deferred-type-errors #-}
-{-# LANGUAGE InstanceSigs         #-}
 
 module SmartTokens.Types.ProtocolParams (
   ProgrammableLogicGlobalParams (..),
   PProgrammableLogicGlobalParams (..),
 ) where
 
 import Cardano.Api.Shelley qualified as C
+import Control.Lens ((&), (.~), (?~))
 import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))
 import Data.Aeson qualified as Aeson
 import Data.Bifunctor (Bifunctor (..))
+import Data.OpenApi.Internal (OpenApiType (OpenApiArray, OpenApiObject, OpenApiString),
+                              Referenced (Inline))
+import Data.OpenApi.Lens qualified as L
+import Data.OpenApi.ParamSchema (ToParamSchema (..))
+import Data.OpenApi.Schema (ToSchema (..), defaultSchemaOptions,
+                            paramSchemaToNamedSchema)
 import Generics.SOP qualified as SOP
 import Plutarch.Core.PlutusDataList (DerivePConstantViaDataList (..),
                                      PlutusTypeDataList, ProductIsData (..))
@@ -80,3 +87,26 @@ instance FromJSON ProgrammableLogicGlobalParams where
     ProgrammableLogicGlobalParams
       <$> (obj .: "directory_node_currency_symbol" >>= either fail pure . plutusDataFromJSON)
       <*> (obj .: "programmable_logic_credential" >>= either fail pure . plutusDataFromJSON)
+
+instance ToParamSchema ProgrammableLogicGlobalParams where
+  toParamSchema _proxy =
+    mempty
+      & L.type_ ?~ OpenApiObject
+      & L.description ?~ "Global parameters of the programmable token directory"
+      & L.properties .~
+        [ ( "directory_node_currency_symbol"
+          , Inline $ mempty
+              & L.type_ ?~ OpenApiString
+              & L.description ?~ "base16-encoded script payment credential of the programmable logic script"
+              & L.example ?~ "0xc0000000000000000000000000000000000000000000000000000000"
+          )
+        , ( "programmable_logic_credential"
+        , Inline $ mempty
+              & L.type_ ?~ OpenApiArray
+              & L.description ?~ "plutus-data-encoded payment credential of the programmable logic"
+              & L.example ?~ toJSON @[Aeson.Value] [toJSON @Int 0, toJSON @[String] ["0x0a0eb28fbaec9e61d20e9fe4c6ac5e5ee4520bb274b1e3292721d26f"]]
+          )
+        ]
+
+instance ToSchema ProgrammableLogicGlobalParams where
+  declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions

src/lib/Wst/JSON/Utils.hs

@@ -0,0 +1,11 @@
+{-| JSON utility functions
+-}
+module Wst.JSON.Utils(
+  customJsonOptions
+) where
+
+import Data.Aeson qualified as JSON
+
+-- | JSON options that drop @n@ characters and then apply @JSON.camel2@ to the rest
+customJsonOptions :: Int -> JSON.Options
+customJsonOptions i = JSON.defaultOptions{JSON.fieldLabelModifier= JSON.camelTo2 '_' . drop i }

src/lib/Wst/Offchain/Query.hs

@@ -26,18 +26,25 @@ import Convex.PlutusLedger.V1 (transCredential, unTransStakeCredential)
 import Convex.Scripts (fromHashableScriptData)
 import Convex.Utxos (UtxoSet, toApiUtxo)
 import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson qualified as JSON
 import Data.Map qualified as Map
 import Data.Maybe (listToMaybe, mapMaybe)
+import Data.OpenApi.Schema (ToSchema (..))
+import Data.OpenApi.Schema qualified as Schema
+import Data.OpenApi.SchemaOptions qualified as SchemaOptions
+import Data.Typeable (Typeable)
 import GHC.Exts (IsList (..))
 import GHC.Generics (Generic)
 import PlutusTx qualified
 import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams)
 import SmartTokens.Types.PTokenDirectory (BlacklistNode, DirectorySetNode (..))
 import Wst.AppError (AppError (GlobalParamsNodeNotFound))
+import Wst.JSON.Utils qualified as JSON
 import Wst.Offchain.Env (DirectoryEnv (..), HasDirectoryEnv (directoryEnv),
                          HasTransferLogicEnv (transferLogicEnv),
                          TransferLogicEnv (tleBlacklistSpendingScript),
                          blacklistNodePolicyId, directoryNodePolicyId)
+import Wst.Orphans ()
 
 -- TODO: We should probably filter the UTxOs to check that they have the correct NFTs
 
@@ -50,7 +57,21 @@ data UTxODat era a =
     , uDatum :: a
     }
   deriving stock (Eq, Show, Generic)
-  deriving anyclass (ToJSON, FromJSON)
+
+-- | Aeson options for the UTxODat type. Used to derive JSON instances and ToSchema
+utxoDatOptions :: JSON.Options
+utxoDatOptions = JSON.customJsonOptions 2
+
+instance (C.IsCardanoEra era, ToJSON a) => ToJSON (UTxODat era a) where
+  toJSON = JSON.genericToJSON utxoDatOptions
+  toEncoding = JSON.genericToEncoding utxoDatOptions
+
+instance (C.IsCardanoEra era, FromJSON a, C.IsShelleyBasedEra era) => FromJSON (UTxODat era a) where
+  parseJSON = JSON.genericParseJSON utxoDatOptions
+
+  -- TODO:
+instance (Typeable a, ToSchema a, Typeable era) => ToSchema (UTxODat era a) where
+  declareNamedSchema = Schema.genericDeclareNamedSchema (SchemaOptions.fromAesonOptions utxoDatOptions)
 
 {-| Find all UTxOs that make up the registry
 -}

src/lib/Wst/Orphans.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-| Orphan instances
+-}
+module Wst.Orphans() where
+
+import Cardano.Api qualified as C
+import Control.Lens ((&), (.~), (?~))
+import Data.OpenApi.Internal (NamedSchema (..),
+                              OpenApiType (OpenApiInteger, OpenApiObject, OpenApiString),
+                              Referenced (Inline), Schema)
+import Data.OpenApi.Lens qualified as L
+import Data.OpenApi.Schema (ToSchema (..))
+import Data.Typeable (Typeable)
+
+instance (Typeable ctx, Typeable era) => ToSchema (C.TxOut ctx era) where
+  declareNamedSchema _ = pure
+    $ NamedSchema (Just "TxOut")
+    $ mempty
+      & L.type_ ?~ OpenApiObject
+      & L.description ?~ "Global parameters of the programmable token directory"
+      & L.properties .~
+        [ ( "address"
+          , Inline addrSchema
+          )
+        , ( "datum"
+          , Inline $ mempty
+              & L.type_ ?~ OpenApiObject
+              & L.description ?~ "the datum of the output (if any)"
+          )
+        , ( "inlineDatum"
+          , Inline $ mempty
+              & L.type_ ?~ OpenApiObject
+              & L.description ?~ "the inline datum of the output (if any)"
+          )
+        , ( "inlineDatumRaw"
+          , Inline $ mempty
+              & L.type_ ?~ OpenApiObject
+              & L.description ?~ "the inline datum of the output (if any), CBOR serialised and base-16 encoded"
+          )
+        , ( "inlineDatumhash"
+          , Inline $ mempty
+              & L.type_ ?~ OpenApiString
+              & L.description ?~ "hash of the inline datum of the output (if it exists)"
+          )
+        , ( "referenceScript"
+          , Inline $ mempty
+              & L.type_ ?~ OpenApiObject
+              & L.description ?~ "reference script (if any), text envelope format"
+          )
+        , ( "value"
+          , Inline valueSchema
+          )
+        ]
+
+instance ToSchema C.TxIn where
+  declareNamedSchema _ = pure
+    $ NamedSchema (Just "TxIn")
+    $ mempty
+        & L.type_ ?~ OpenApiString
+        & L.description ?~ "TxIn consisting of (Transaction hash + # + index)"
+        & L.example ?~ "01f4b788593d4f70de2a45c2e1e87088bfbdfa29577ae1b62aba60e095e3ab53#2"
+
+instance ToSchema (C.Hash C.PaymentKey) where
+  declareNamedSchema _ = pure
+    $ NamedSchema (Just "Hash PaymentKey")
+    $ mempty
+        & L.type_ ?~ OpenApiString
+        & L.description ?~ "Hash of a payment key"
+        & L.example ?~ "f6ac5676b58d8ce280c1f09af4a2e82dd58c1aa2fb075aa005afa1da"
+
+valueSchema :: Schema
+valueSchema = mempty
+  & L.type_ ?~ OpenApiObject
+  & L.description ?~ "Value locked in the output. Always includes a 'lovelace' key, may include other keys if non-Ada assets are present."
+  & L.properties .~
+    [ ("lovelace", Inline $ mempty & L.type_ ?~ OpenApiInteger)
+    ]
+
+instance ToSchema C.Value where
+  declareNamedSchema _ = pure
+    $ NamedSchema (Just "Value") valueSchema
+
+addrSchema :: Schema
+addrSchema = mempty
+  & L.type_ ?~ OpenApiString
+  & L.description ?~ "bech32-encoded cardano address"
+  & L.example ?~ "addr_test1qpju2uhn72ur6j5alln6nz7dqcgcjal7xjaw7lwdjdaex4qhr3xpz63fjwvlpsnu8efnhfdja78d3vkv8ks6ac09g3usemu2yl"
+
+instance ToSchema (C.Address C.ShelleyAddr) where
+  declareNamedSchema _ = pure
+    $ NamedSchema (Just "Address") addrSchema
+
+instance ToSchema C.AssetName where
+  declareNamedSchema _ = pure
+    $ NamedSchema (Just "Asset name")
+    $ mempty
+        & L.type_ ?~ OpenApiString
+
+instance ToSchema C.Quantity where
+  declareNamedSchema _ = pure
+    $ NamedSchema (Just "Quantity")
+    $ mempty
+        & L.type_ ?~ OpenApiInteger
+

src/lib/Wst/Server/Types.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedLists    #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE TypeOperators      #-}
 
@@ -26,13 +27,23 @@ module Wst.Server.Types (
 
 import Cardano.Api (AssetName, Quantity)
 import Cardano.Api qualified as C
+import Control.Lens ((&), (.~), (?~))
 import Data.Aeson (FromJSON (..), ToJSON (..))
+import Data.Aeson qualified as JSON
+import Data.OpenApi (NamedSchema (..), OpenApiType (OpenApiObject),
+                     Referenced (Inline), ToSchema (..))
+import Data.OpenApi.Internal (OpenApiType (OpenApiString))
+import Data.OpenApi.Lens qualified as L
+import Data.OpenApi.ParamSchema (ToParamSchema (..))
+import Data.OpenApi.Schema qualified as Schema
+import Data.OpenApi.SchemaOptions qualified as SchemaOptions
 import Data.Proxy (Proxy (..))
 import GHC.Generics (Generic)
 import Servant (FromHttpApiData (..), ToHttpApiData (toUrlPiece))
 import Servant.API (Capture, Description, Get, JSON, NoContent, Post, ReqBody,
                     type (:>), (:<|>) (..))
 import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams)
+import Wst.JSON.Utils qualified as JSON
 import Wst.Offchain.Query (UTxODat (..))
 
 type APIInEra = API C.ConwayEra
@@ -45,8 +56,27 @@ instance C.HasTextEnvelope a => ToJSON (TextEnvelopeJSON a) where
 instance C.HasTextEnvelope a => FromJSON (TextEnvelopeJSON a) where
   parseJSON val = parseJSON val >>= either (fail . show) (pure . TextEnvelopeJSON) . C.deserialiseFromTextEnvelope (C.proxyToAsType Proxy)
 
+instance C.HasTextEnvelope a => ToSchema (TextEnvelopeJSON a) where
+  declareNamedSchema _ = pure
+    $ NamedSchema (Just "TextEnvelopeJSON")
+    $ mempty
+        & L.type_ ?~ OpenApiObject
+        & L.description ?~ "Text envelope"
+        & L.properties .~
+          [ ("cborHex", Inline $ mempty & L.type_ ?~ OpenApiString & L.description ?~ "The CBOR-serialised value, base-16 encoded")
+          , ("description", Inline $ mempty & L.type_ ?~ OpenApiString & L.description ?~ "Description of the serialised value")
+          , ("type", Inline $ mempty & L.type_ ?~ OpenApiString & L.description ?~ "Type of the serialised value")
+          ]
+
 newtype SerialiseAddress a = SerialiseAddress{unSerialiseAddress :: a }
 
+instance ToParamSchema (SerialiseAddress a) where
+  toParamSchema _proxy =
+    mempty
+      & L.type_ ?~ OpenApiString
+      & L.description ?~ "bech32-serialised cardano address"
+      & L.example ?~ "addr1q9d42egme33z960rr8vlnt69lpmythdpm7ydk2e6k5nj5ghay9rg60vw49kejfah76sqeh4yshlsntgg007y0wgjlfwju6eksr"
+
 instance C.SerialiseAddress a => FromHttpApiData (SerialiseAddress a) where
   parseUrlPiece =
     maybe (Left "Failed to deserialise address") (Right . SerialiseAddress) . C.deserialiseAddress (C.proxyToAsType Proxy)
@@ -74,7 +104,22 @@ data IssueProgrammableTokenArgs =
     , itaQuantity  :: Quantity
     }
     deriving stock (Eq, Show, Generic)
-    deriving anyclass (ToJSON, FromJSON)
+
+jsonOptions3 :: JSON.Options
+jsonOptions3 = JSON.customJsonOptions 3
+
+jsonOptions2 :: JSON.Options
+jsonOptions2 = JSON.customJsonOptions 2
+
+instance ToJSON IssueProgrammableTokenArgs where
+  toJSON = JSON.genericToJSON jsonOptions3
+  toEncoding = JSON.genericToEncoding jsonOptions3
+
+instance FromJSON IssueProgrammableTokenArgs where
+  parseJSON = JSON.genericParseJSON jsonOptions3
+
+instance ToSchema IssueProgrammableTokenArgs where
+  declareNamedSchema = Schema.genericDeclareNamedSchema (SchemaOptions.fromAesonOptions jsonOptions3)
 
 data TransferProgrammableTokenArgs =
   TransferProgrammableTokenArgs
@@ -85,23 +130,50 @@ data TransferProgrammableTokenArgs =
     , ttaQuantity  :: Quantity
     }
     deriving stock (Eq, Show, Generic)
-    deriving anyclass (ToJSON, FromJSON)
+
+instance ToJSON TransferProgrammableTokenArgs where
+  toJSON = JSON.genericToJSON jsonOptions3
+  toEncoding = JSON.genericToEncoding jsonOptions3
+
+instance FromJSON TransferProgrammableTokenArgs where
+  parseJSON = JSON.genericParseJSON jsonOptions3
+
+instance ToSchema TransferProgrammableTokenArgs where
+  declareNamedSchema = Schema.genericDeclareNamedSchema (SchemaOptions.fromAesonOptions jsonOptions3)
 
 data AddToBlacklistArgs =
   AddToBlacklistArgs
     { atbIssuer           :: C.Address C.ShelleyAddr
     , atbBlacklistAddress :: C.Address C.ShelleyAddr
     }
     deriving stock (Eq, Show, Generic)
-    deriving anyclass (ToJSON, FromJSON)
+
+instance ToJSON AddToBlacklistArgs where
+  toJSON = JSON.genericToJSON jsonOptions3
+  toEncoding = JSON.genericToEncoding jsonOptions3
+
+instance FromJSON AddToBlacklistArgs where
+  parseJSON = JSON.genericParseJSON jsonOptions3
+
+instance ToSchema AddToBlacklistArgs where
+  declareNamedSchema = Schema.genericDeclareNamedSchema (SchemaOptions.fromAesonOptions jsonOptions3)
 
 data SeizeAssetsArgs =
   SeizeAssetsArgs
     { saIssuer  :: C.Address C.ShelleyAddr
     , saTarget  :: C.Address C.ShelleyAddr
     }
     deriving stock (Eq, Show, Generic)
-    deriving anyclass (ToJSON, FromJSON)
+
+instance ToJSON SeizeAssetsArgs where
+  toJSON = JSON.genericToJSON jsonOptions2
+  toEncoding = JSON.genericToEncoding jsonOptions2
+
+instance FromJSON SeizeAssetsArgs where
+  parseJSON = JSON.genericParseJSON jsonOptions2
+
+instance ToSchema SeizeAssetsArgs where
+  declareNamedSchema = Schema.genericDeclareNamedSchema (SchemaOptions.fromAesonOptions jsonOptions2)
 
 type BuildTxAPI era =
   "programmable-token" :>