Skip to content

Commit

Permalink
Merge pull request #719 from input-output-hk/plt-5458-open-api-improv…
Browse files Browse the repository at this point in the history
…ements

PLT-5458 Open API Improvements
  • Loading branch information
jhbertra authored Sep 26, 2023
2 parents 39eecd8 + 827692b commit 432cef3
Show file tree
Hide file tree
Showing 7 changed files with 270 additions and 52 deletions.
2 changes: 2 additions & 0 deletions marlowe-runtime-web/CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,8 @@

- Use of generics for REST error reporting

- Improved quality of generated Open API documentation

## Fixed

- Serialization for Token Names containing "."
Expand Down
12 changes: 6 additions & 6 deletions marlowe-runtime-web/marlowe-runtime-web.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -111,6 +111,7 @@ library server
Language.Marlowe.Runtime.Web.Server.REST.Withdrawals
Language.Marlowe.Runtime.Web.Server.SyncClient
Language.Marlowe.Runtime.Web.Server.TxClient
Paths_marlowe_runtime_web

build-depends:
, aeson >=2 && <3
Expand All @@ -131,6 +132,7 @@ library server
, exceptions >=0.10 && <0.12
, http-media ^>=0.8
, lens >=5.2 && <6
, lens-aeson ^>=1.2
, marlowe-cardano ==0.2.0.0
, marlowe-chain-sync ==0.0.5
, marlowe-client ==0.0.5
Expand Down Expand Up @@ -159,14 +161,13 @@ library server
, wai-cors ^>=0.2

executable marlowe-web-server
import: lang
hs-source-dirs: app
main-is: Main.hs
import: lang
hs-source-dirs: app
main-is: Main.hs
other-modules:
Options
Paths_marlowe_runtime_web

autogen-modules: Paths_marlowe_runtime_web
build-depends:
, async-components ==0.1.1.0
, base >=4.9 && <5
Expand All @@ -187,14 +188,13 @@ executable marlowe-web-server
, wai >=3.2 && <4
, warp

ghc-options: -threaded
ghc-options: -threaded

test-suite marlowe-runtime-web-test
import: lang
hs-source-dirs: test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules: Paths_marlowe_runtime_web
build-depends:
, aeson >=2 && <3
, base >=4.9 && <5
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -7,11 +7,17 @@
-- specification.
module Language.Marlowe.Runtime.Web.Server.OpenAPI where

import Control.Applicative ((<|>))
import Control.Lens
import Data.Aeson
import Data.Aeson.Lens
import Data.OpenApi hiding (Server)
import Data.String (fromString)
import qualified Data.Text as T
import Data.Version (showVersion)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import qualified Language.Marlowe.Runtime.Web as Web
import qualified Paths_marlowe_runtime_web
import Servant
import Servant.OpenApi (toOpenApi)
import Servant.Pagination
Expand Down Expand Up @@ -46,7 +52,34 @@ instance KnownSymbolList '[] where
instance (KnownSymbolList ss, KnownSymbol s) => KnownSymbolList (s ': ss) where
symbolListVal _ = symbolVal (Proxy @s) : symbolListVal (Proxy @ss)

type API = "openapi.json" :> Get '[JSON] OpenApi
newtype OpenApiWithEmptySecurity = OpenApiWithEmptySecurity OpenApi

instance ToJSON OpenApiWithEmptySecurity where
toJSON (OpenApiWithEmptySecurity openApi) =
openApi
& toJSON
& key "paths" . members . members . atKey "security" %~ (<|> Just (Array mempty))

type API = "openapi.json" :> Get '[JSON] OpenApiWithEmptySecurity

server :: (Applicative m) => ServerT API m
server = pure $ toOpenApi Web.api
server =
pure $
OpenApiWithEmptySecurity $
toOpenApi Web.api
& info
%~ (title .~ "Marlowe Runtime REST API")
. (version .~ T.pack (showVersion Paths_marlowe_runtime_web.version))
. (description ?~ "REST API for Marlowe Runtime")
. ( license
?~ License
{ _licenseName = "Apache 2.0"
, _licenseUrl = Just $ URL "https://www.apache.org/licenses/LICENSE-2.0.html"
}
)
& servers
.~ [ "https://marlowe-runtime-preprod-web.scdev.aws.iohkdev.io"
, "https://marlowe-runtime-preview-web.scdev.aws.iohkdev.io"
, "https://marlowe-runtime-mainnet-web.scdev.aws.iohkdev.io"
, "http://localhost:3780"
]
Original file line number Diff line number Diff line change
Expand Up @@ -54,7 +54,7 @@ import Servant.Pagination
server :: ServerT ContractsAPI ServerM
server =
get
:<|> (postCreateTxBodyResponse :<|> postCreateTxResponse)
:<|> (\stakeAddress -> postCreateTxBodyResponse stakeAddress :<|> postCreateTxResponse stakeAddress)
:<|> contractServer
:<|> ContractSources.server

Expand Down Expand Up @@ -97,27 +97,27 @@ postCreateTxBody PostContractsRequest{..} stakeAddressDTO changeAddressDTO mAddr
(ContractCreated ReferenceTxInsScriptsInlineDatumsInConwayEra ContractCreatedInEra{contractId, txBody, safetyErrors}) -> pure (contractId, TxBodyInAnyEra txBody, safetyErrors)

postCreateTxBodyResponse
:: PostContractsRequest
-> Maybe StakeAddress
:: Maybe StakeAddress
-> PostContractsRequest
-> Address
-> Maybe (CommaList Address)
-> Maybe (CommaList TxOutRef)
-> ServerM (PostContractsResponse CardanoTxBody)
postCreateTxBodyResponse req stakeAddressDTO changeAddressDTO mAddresses mCollateralUtxos = do
postCreateTxBodyResponse stakeAddressDTO req changeAddressDTO mAddresses mCollateralUtxos = do
(contractId, TxBodyInAnyEra txBody, safetyErrors) <-
postCreateTxBody req stakeAddressDTO changeAddressDTO mAddresses mCollateralUtxos
let (contractId', txBody') = toDTO (contractId, txBody)
let body = CreateTxEnvelope contractId' txBody' safetyErrors
pure $ IncludeLink (Proxy @"contract") body

postCreateTxResponse
:: PostContractsRequest
-> Maybe StakeAddress
:: Maybe StakeAddress
-> PostContractsRequest
-> Address
-> Maybe (CommaList Address)
-> Maybe (CommaList TxOutRef)
-> ServerM (PostContractsResponse CardanoTx)
postCreateTxResponse req stakeAddressDTO changeAddressDTO mAddresses mCollateralUtxos = do
postCreateTxResponse stakeAddressDTO req changeAddressDTO mAddresses mCollateralUtxos = do
(contractId, TxBodyInAnyEra txBody, safetyErrors) <-
postCreateTxBody req stakeAddressDTO changeAddressDTO mAddresses mCollateralUtxos
let tx = makeSignedTransaction [] txBody
Expand Down
Loading

0 comments on commit 432cef3

Please sign in to comment.