Creating Endpoints

{
  "coreProvider": ...,
  "networkId": "preprod",
  "logging": [{ "type": { "tag": "stderr" }, "severity": "Debug", "verbosity": "V2" }],
  "logTiming": false
}

-- | Getting path for our core configuration.
parseArgs :: IO FilePath
parseArgs = do
  args <- getArgs
  case args of
    coreCfg: _ -> return coreCfg
    _invalidArgument -> fail "Error: wrong arguments, needed a path to the CoreConfig JSON configuration file\n"
 
main :: IO ()
main = do
  putStrLn "Writing Swagger file ..."
  BL8.writeFile "swagger-api.json" (encodePretty apiSwagger)
 
  putStrLn "parsing Config ..."
  coreCfgPath <- parseArgs
  coreCfg <- coreConfigIO coreCfgPath  -- Parsing our core configuration.
 
  putStrLn "Loading Providers ..."
  withCfgProviders coreCfg "api-server"  $ \providers -> do
    let port = 8081
        ctx = Ctx coreCfg providers
    putStrLn $ "Starting server at \n " <> "http://localhost:" <> show port
    run port $ app ctx
 
 
app :: Ctx -> Application
app ctx = cors (const $ Just simpleCorsResourcePolicy { corsRequestHeaders = [HttpTypes.hContentType] }) $ serve appApi $ hoistServer appApi (Handler . ExceptT . try)  $ apiServer ctx

-- | Our Context.
data Ctx = Ctx
  { ctxCoreCfg   :: !GYCoreConfig
  , ctxProviders :: !GYProviders
  }
 
-- | To run for simple queries, the one which don't requiring building for transaction skeleton.
runQuery :: Ctx -> GYTxQueryMonadIO a -> IO a
runQuery ctx q = do
  let nid = cfgNetworkId $ ctxCoreCfg ctx
      providers = ctxProviders ctx
  runGYTxQueryMonadIO nid providers q
 
-- | Tries to build for given skeleton.
runTx ::
  Ctx ->
  -- | User's used addresses.
  [GYAddress] ->
  -- | User's change address.
  GYAddress ->
  -- | Browser wallet's reserved collateral (if set).
  Maybe GYTxOutRefCbor ->
  GYTxBuilderMonadIO (GYTxSkeleton v) ->
  IO GYTxBody
runTx ctx addrs addr collateral skeleton = do
  let nid = cfgNetworkId $ ctxCoreCfg ctx
      providers = ctxProviders ctx
  runGYTxBuilderMonadIO
    nid
    providers
    addrs
    addr
    ( collateral
        >>= ( \c ->
                Just
                  ( getTxOutRefHex c
                  , True -- Make this as `False` to not do 5-ada-only check for value in this given UTxO to be used as collateral.
                  )
            )
    )
    (skeleton >>= buildTxBody)

-- | Return type of API when submitting a transaction.
data SubmitTxResponse = SubmitTxResponse
                          { submitTxFee :: !Integer
                          , submitTxId  :: !GYTxId
                          } deriving (Show, Generic, ToJSON, Swagger.ToSchema)
 
-- | Input parameters to add for reference script.
data AddWitAndSubmitParams = AddWitAndSubmitParams
  { awasTxUnsigned :: !GYTx
  , awasTxWit      :: !GYTxWitness
  } deriving (Generic, FromJSON, Swagger.ToSchema)
 
-- | Construct `SubmitTxResponse` return type from the given signed transaction body.
txBodySubmitTxResponse :: GYTxBody -> SubmitTxResponse
txBodySubmitTxResponse txBody = SubmitTxResponse
                                  { submitTxFee = txBodyFee txBody
                                  , submitTxId  = txBodyTxId txBody
                                  }
 
-- | Type for our Servant API.
type TxAPI =
      "add-wit-and-submit"
    :> ReqBody '[JSON] AddWitAndSubmitParams
    :> Post '[JSON] SubmitTxResponse
 
-- | Serving our API.
handleTx :: Ctx -> ServerT TxAPI IO
handleTx = handleAddWitAndSubmitTx
 
-- | Handle for adding key witness to the unsigned transaction & then submit it.
handleAddWitAndSubmitTx :: Ctx -> AddWitAndSubmitParams -> IO SubmitTxResponse
handleAddWitAndSubmitTx ctx AddWitAndSubmitParams{..} = do
  let txBody = getTxBody awasTxUnsigned
  void $ gySubmitTx (ctxProviders ctx) $ makeSignedTransaction awasTxWit txBody
  return $ txBodySubmitTxResponse txBody

-- | Input wrapper around corresponding Plutus type.
data BetRefParams = BetRefParams
  { brpOracleAddress :: !GYAddress
  , brpBetUntil      :: !GYTime
  , brpBetReveal     :: !GYTime
  , brpBetStep       :: !GYValue
  } deriving (Show, Generic, FromJSON, Swagger.ToSchema)
 
-- | Convert the above `BetRefParams` with corresponding representation defined in our Plutus validator script.
betParamsToScript :: BetRefParams -> Script.BetRefParams
betParamsToScript brp = Script.BetRefParams
  { Script.brpOraclePkh = pubKeyHashToPlutus $ fromJust $ addressToPubKeyHash $ brpOracleAddress brp
  , Script.brpBetUntil = timeToPlutus $  brpBetUntil brp
  , Script.brpBetReveal = timeToPlutus $ brpBetReveal brp
  , Script.brpBetStep = valueToPlutus $  brpBetStep brp
  }
 
-- | Input parameters for place bet operation.
data PlaceBetRefParams = PlaceBetRefParams
  { pbrUsedAddrs  :: ![GYAddress]
  , pbrChangeAddr :: !GYAddress
  , pbrCollateral :: !(Maybe GYTxOutRefCbor)
  , pbrBetParams  :: !BetRefParams
  , pbrBetGuess   :: !Integer
  , pbrBetAmt     :: !GYValue
  , pbrRefScript  :: !GYTxOutRef
  , pbrPrevBetRef :: !(Maybe GYTxOutRef)
  } deriving (Show, Generic, FromJSON, Swagger.ToSchema)
 
-- | Input parameters for take bets operation.
data TakeBetRefParams = TakeBetRefParams
  { tbrUsedAddrs         :: ![GYAddress]
  , tbrChangeAddr        :: !GYAddress
  , tbrCollateral        :: !(Maybe GYTxOutRefCbor)
  , tbrBetParams         :: !BetRefParams
  , tbrRefScript         :: !GYTxOutRef
  , tbrPrevBetRef        :: !GYTxOutRef
  , tbrOracleRefInputRef :: !GYTxOutRef
  } deriving (Show, Generic, FromJSON, Swagger.ToSchema)
 
-- | Input parameters to add for reference script.
data AddRefScriptParams = AddRefScriptParams
  { arsUsedAddrs  :: ![GYAddress]
  , arsChangeAddr :: !GYAddress
  , arsCollateral :: !(Maybe GYTxOutRefCbor)
  , arsPutAddress :: !GYAddress
  , arsBetParams  :: !BetRefParams
  } deriving (Show, Generic, FromJSON, Swagger.ToSchema)
 
-- | Input parameters to add for reference input.
data AddRefInputParams = AddRefInputParams
  { ariUsedAddrs  :: ![GYAddress]
  , ariChangeAddr :: !GYAddress
  , ariCollateral :: !(Maybe GYTxOutRefCbor)
  , ariPutAddress :: !GYAddress
  , ariBetAnswer  :: !Integer
  } deriving (Show, Generic, FromJSON, Swagger.ToSchema)
 
-- | Return type for our API endpoints defined here.
data UnsignedTxResponse = UnsignedTxResponse
  { urspTxBodyHex :: !T.Text              -- ^ Unsigned transaction cbor.
  , urspTxFee     :: !(Maybe Integer)     -- ^ Tx fees.
  , urspUtxoRef   :: !(Maybe GYTxOutRef)  -- ^ Some operations might need to show for relevant UTxO generated.
  } deriving (Show, Generic, FromJSON, ToJSON, Swagger.ToSchema)
 
-- | Construct `UnsignedTxResponse` return type for our endpoint given the transaction body & relevant index for UTxO (if such exists).
unSignedTxWithFee :: GYTxBody -> Maybe GYTxOutRef -> UnsignedTxResponse
unSignedTxWithFee txBody mUtxoRef = UnsignedTxResponse
  { urspTxBodyHex  = T.pack $ txToHex $ unsignedTx txBody
  , urspTxFee      = Just $ txBodyFee txBody
  , urspUtxoRef    = mUtxoRef
  }
 
-- | Type for our Servant API.
type BetRefApi =
       "place"
    :> ReqBody '[JSON] PlaceBetRefParams
    :> Post    '[JSON] UnsignedTxResponse
  :<|> "take"
    :> ReqBody '[JSON] TakeBetRefParams
    :> Post    '[JSON] UnsignedTxResponse
  :<|> "add-ref-script"
    :> ReqBody  '[JSON] AddRefScriptParams
    :> Post     '[JSON] UnsignedTxResponse
  :<|> "add-ref-input"
    :> ReqBody  '[JSON] AddRefInputParams
    :> Post     '[JSON] UnsignedTxResponse
 
-- | Serving our API.
handleBetRefApi :: Ctx -> ServerT BetRefApi IO
handleBetRefApi ctx =   handlePlaceBet ctx
                   :<|> handleTakeBet ctx
                   :<|> handleAddRefScript ctx
                   :<|> handleOracleRefInput ctx
 
-- | Handle for place bet operation.
handlePlaceBet :: Ctx -> PlaceBetRefParams -> IO UnsignedTxResponse
handlePlaceBet ctx PlaceBetRefParams{..} = do
  let brp = betParamsToScript pbrBetParams
  validatorAddress <- runQuery ctx (betRefAddress brp)
  txBody <- runTxI ctx pbrUsedAddrs pbrChangeAddr pbrCollateral
              $ placeBet pbrRefScript (betParamsToScript pbrBetParams) (Script.OracleAnswerDatum pbrBetGuess) pbrBetAmt (head pbrUsedAddrs) pbrPrevBetRef
  placeUtxoRef <- case find (\utxo -> utxoAddress utxo == validatorAddress) $ utxosToList $ txBodyUTxOs txBody of
        Nothing -> fail "Shouldn't happen: No reference for placed bet in body"
        Just utxo -> pure $ utxoRef utxo
  pure $ unSignedTxWithFee txBody $ Just placeUtxoRef
 
-- | Handle for take bets operation.
handleTakeBet :: Ctx -> TakeBetRefParams -> IO UnsignedTxResponse
handleTakeBet ctx TakeBetRefParams{..} = do
  txBody <- runTxI ctx tbrUsedAddrs tbrChangeAddr tbrCollateral
              $ takeBets tbrRefScript (betParamsToScript tbrBetParams) tbrPrevBetRef (head tbrUsedAddrs) tbrOracleRefInputRef
  pure $ unSignedTxWithFee txBody Nothing
 
-- | Handle for adding reference script.
handleAddRefScript :: Ctx -> AddRefScriptParams  -> IO UnsignedTxResponse
handleAddRefScript  ctx AddRefScriptParams{..} = do
  let validator = betRefValidator' (betParamsToScript arsBetParams)
  txBody <- runTxI ctx arsUsedAddrs arsChangeAddr arsCollateral
              $ pure $ addRefScript' arsPutAddress validator
  let refs   = Limbo.findRefScriptsInBody txBody
  outRef <- case Map.lookup (Some (validatorToScript validator)) refs of
                 Nothing  -> fail "Shouldn't happen: No reference for added Script in body"
                 Just ref -> return ref
  pure $ unSignedTxWithFee txBody $ Just outRef
 
-- | Handle for adding reference input.
handleOracleRefInput :: Ctx -> AddRefInputParams  -> IO UnsignedTxResponse
handleOracleRefInput  ctx AddRefInputParams{..} = do
  let ourDatumPlutus = Script.OracleAnswerDatum ariBetAnswer
      ourDatumGY = datumFromPlutusData ourDatumPlutus
  txBody <- runTxI ctx ariUsedAddrs ariChangeAddr ariCollateral
              $ pure $ addRefInput' ariPutAddress ourDatumPlutus
  let utxos = utxosToList $ txBodyUTxOs txBody
      ourDatumHash = hashDatum ourDatumGY
      mRefInputUtxo = find (\utxo ->
        case utxoOutDatum utxo of
          GYOutDatumHash dh  -> ourDatumHash == dh
          GYOutDatumInline d -> ourDatumGY == d
          GYOutDatumNone     -> False
        ) utxos
  case mRefInputUtxo of
    Nothing               -> fail "Shouldn't happen: Couldn't find the desired UTxO in Tx outputs"
    Just GYUTxO {utxoRef} -> pure $ unSignedTxWithFee txBody $ Just utxoRef

-- | Type for our Servant API.
type Api =
        "tx"  :> TxAPI
  :<|>  "betref" :>  BetRefApi
 
appApi :: Proxy Api
appApi = Proxy
 
apiSwagger  :: Swagger
apiSwagger  = toSwagger appApi
 
apiServer :: Ctx -> ServerT Api IO
apiServer ctx =
       handleTx ctx
  :<|> handleBetRefApi ctx

-- | Getting path for our core configuration.
parseArgs :: IO FilePath
parseArgs = do
  args <- getArgs
  case args of
    coreCfg: _ -> return coreCfg
    _invalidArgument -> fail "Error: wrong arguments, needed a path to the CoreConfig JSON configuration file\n"
 
main :: IO ()
main = do
  putStrLn "Writing Swagger file ..."
  BL8.writeFile "swagger-api.json" (encodePretty apiSwagger)
 
  putStrLn "parsing Config ..."
  coreCfgPath <- parseArgs
  coreCfg <- coreConfigIO coreCfgPath  -- Parsing our core configuration.
 
  putStrLn "Loading Providers ..."
  withCfgProviders coreCfg "api-server"  $ \providers -> do
    let port = 8081
        ctx = Ctx coreCfg providers
    putStrLn $ "Starting server at \n " <> "http://localhost:" <> show port
    run port $ app ctx
 
 
app :: Ctx -> Application
app ctx = cors (const $ Just simpleCorsResourcePolicy { corsRequestHeaders = [HttpTypes.hContentType] }) $ serve appApi $ hoistServer appApi (Handler . ExceptT . try)  $ apiServer ctx