From 6dd9fdee600d1a18188219c30b660ae0bfe175d0 Mon Sep 17 00:00:00 2001 From: Giovanni Garufi Date: Mon, 14 Feb 2022 13:54:23 +0100 Subject: [PATCH 1/5] Add an endpoint that allows fetching a serialised raw transation. This endpoint must be enabled by the pcEnableTxEndpoint configuration variable. Change-type: minor --- bot-plutus-interface.cabal | 15 ++- src/BotPlutusInterface/Server.hs | 45 ++++++++- src/BotPlutusInterface/Types.hs | 2 + test/Spec.hs | 2 + test/Spec/BotPlutusInterface/Server.hs | 132 +++++++++++++++++++++++++ 5 files changed, 190 insertions(+), 6 deletions(-) create mode 100644 test/Spec/BotPlutusInterface/Server.hs diff --git a/bot-plutus-interface.cabal b/bot-plutus-interface.cabal index ee05dc6b..dd2a4012 100644 --- a/bot-plutus-interface.cabal +++ b/bot-plutus-interface.cabal @@ -84,8 +84,7 @@ library BotPlutusInterface.PreBalance BotPlutusInterface.Types BotPlutusInterface.UtxoParser - - other-modules: BotPlutusInterface.Server + BotPlutusInterface.Server build-depends: , aeson ^>=1.5.0.0 , attoparsec >=0.13.2.2 @@ -106,6 +105,7 @@ library , http-types , lens , memory + , mtl , playground-common , plutus-chain-index , plutus-chain-index-core @@ -145,6 +145,7 @@ test-suite bot-plutus-interface-test Spec.BotPlutusInterface.Contract Spec.BotPlutusInterface.PreBalance Spec.BotPlutusInterface.UtxoParser + Spec.BotPlutusInterface.Server Spec.MockContract build-depends: @@ -161,12 +162,16 @@ test-suite bot-plutus-interface-test , data-default-class , either , extra + , filepath , freer-extras , freer-simple , generic-arbitrary , hex + , http-client + , http-types , lens , neat-interpolation + , playground-common , plutus-chain-index , plutus-chain-index-core , plutus-contract @@ -181,11 +186,17 @@ test-suite bot-plutus-interface-test , quickcheck-instances , row-types , serialise + , servant + , servant-client + , servant-client-core , stm , tasty , tasty-hunit , tasty-quickcheck + , temporary , text ^>=1.2.4.0 , uuid + , utf8-string + , warp hs-source-dirs: test diff --git a/src/BotPlutusInterface/Server.hs b/src/BotPlutusInterface/Server.hs index e0829daf..83043672 100644 --- a/src/BotPlutusInterface/Server.hs +++ b/src/BotPlutusInterface/Server.hs @@ -7,12 +7,13 @@ import BotPlutusInterface.Types ( AppState (AppState), ContractEnvironment (..), ContractState (ContractState, csActivity, csObservableState), - PABConfig, + PABConfig (..), SomeContractState (SomeContractState), ) import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVarIO, readTVar, readTVarIO, retry) import Control.Monad (forever, guard, unless, void) +import Control.Monad.Error.Class (throwError) import Control.Monad.IO.Class (liftIO) import Data.Aeson (FromJSON, ToJSON (toJSON)) import Data.Aeson qualified as JSON @@ -22,6 +23,8 @@ import Data.Map qualified as Map import Data.Maybe (catMaybes) import Data.Proxy (Proxy (Proxy)) import Data.Row (Row) +import Data.Text (Text, unpack) +import Data.Text.IO qualified as Text import Data.UUID.V4 qualified as UUID import Network.WebSockets ( Connection, @@ -45,9 +48,11 @@ import Plutus.PAB.Webserver.Types ( ContractActivationArgs (..), InstanceStatusToClient (ContractFinished, NewObservableState), ) -import Servant.API (JSON, Post, ReqBody, (:<|>) (..), (:>)) +import Servant.API (Capture, Get, JSON, Post, ReqBody, (:<|>) (..), (:>)) import Servant.API.WebSocket (WebSocketPending) -import Servant.Server (Application, Handler, Server, serve) +import Servant.Server (Application, Handler, Server, err404, serve) +import System.Directory (canonicalizePath, doesFileExist, makeAbsolute) +import System.FilePath (replaceExtension, takeDirectory, ()) import Wallet.Types (ContractInstanceId (..)) import Prelude @@ -63,10 +68,16 @@ type API a = :> ReqBody '[JSON] (ContractActivationArgs a) :> Post '[JSON] ContractInstanceId -- Start a new instance. ) + :<|> ( "rawTx" + :> Capture "hash" Text + :> Get '[JSON] Text + ) server :: HasDefinitions t => PABConfig -> AppState -> Server (API t) server pabConfig state = - websocketHandler state :<|> activateContractHandler pabConfig state + websocketHandler state + :<|> activateContractHandler pabConfig state + :<|> rawTxHandler pabConfig apiProxy :: forall (t :: Type). Proxy (API t) apiProxy = Proxy @@ -206,3 +217,29 @@ handleContract pabConf state@(AppState st) contract = liftIO $ do let maybeError = toJSON <$> leftToMaybe result broadcastContractResult @w state contractInstanceID maybeError pure contractInstanceID + +-- | This handler will allow to retrieve raw transactions from the pcTxFileDir if pcEnableTxEndpoint is True +rawTxHandler :: PABConfig -> Text -> Handler Text +rawTxHandler config hash = do + -- Check that endpoint is enabled + assert (pcEnableTxEndpoint config) + -- Absolute path to pcTxFileDir that is specified in the config + txFolderPath <- liftIO $ makeAbsolute (unpack $ pcTxFileDir config) + + -- Add/Set .raw extension on path + let suppliedPath :: FilePath + suppliedPath = replaceExtension (txFolderPath "tx-" <> unpack hash) ".raw" + -- Resolve path indirections + path <- liftIO $ canonicalizePath suppliedPath + -- ensure it does not try to escape txFolderPath + assert (takeDirectory path == txFolderPath) + -- ensure file exists + fileExists <- liftIO $ doesFileExist path + assert fileExists + + -- Read contents of path + liftIO $ Text.readFile path + where + assert :: Bool -> Handler () + assert True = pure () + assert False = throwError err404 diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index 1b8f740d..2416a0e5 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -52,6 +52,7 @@ data PABConfig = PABConfig , pcLogLevel :: !LogLevel , pcOwnPubKeyHash :: PubKeyHash , pcPort :: !Port + , pcEnableTxEndpoint :: !Bool } deriving stock (Show, Eq) @@ -100,4 +101,5 @@ instance Default PABConfig where , pcLogLevel = Info , pcOwnPubKeyHash = "" , pcPort = 9080 + , pcEnableTxEndpoint = False } diff --git a/test/Spec.hs b/test/Spec.hs index 866f076f..5aa88aa0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,6 +3,7 @@ module Main (main) where import Spec.BotPlutusInterface.Contract qualified import Spec.BotPlutusInterface.PreBalance qualified import Spec.BotPlutusInterface.UtxoParser qualified +import Spec.BotPlutusInterface.Server qualified import Test.Tasty (TestTree, defaultMain, testGroup) import Prelude @@ -21,4 +22,5 @@ tests = [ Spec.BotPlutusInterface.Contract.tests , Spec.BotPlutusInterface.UtxoParser.tests , Spec.BotPlutusInterface.PreBalance.tests + , Spec.BotPlutusInterface.Server.tests ] diff --git a/test/Spec/BotPlutusInterface/Server.hs b/test/Spec/BotPlutusInterface/Server.hs new file mode 100644 index 00000000..4917b925 --- /dev/null +++ b/test/Spec/BotPlutusInterface/Server.hs @@ -0,0 +1,132 @@ +module Spec.BotPlutusInterface.Server (tests) where + +import BotPlutusInterface.Server (app, initState) +import BotPlutusInterface.Types ( + HasDefinitions (..), + PABConfig (..), + SomeBuiltin (..), + ) + +import Playground.Types (FunctionSchema) +import Schema (FormSchema) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Network.HTTP.Client (defaultManagerSettings, newManager) +import Network.HTTP.Types.Status (status404) +import Network.Wai.Handler.Warp (testWithApplication) +import Servant.API (Capture, Get, JSON, (:>)) +import Servant.Client (ClientEnv, ClientError (..), client, mkClientEnv, responseStatusCode, runClientM) +import Servant.Client.Core.BaseUrl (BaseUrl (..), parseBaseUrl) + +import Data.Aeson (FromJSON, ToJSON) +import Data.Default (def) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack, unpack) +import Data.Void (Void, absurd) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Prelude + +type RawTxEndpointResponse = Either ClientError Text +type RawTxTest a = (Text -> IO RawTxEndpointResponse) -> IO a + +tests :: TestTree +tests = + testGroup + "Server" + [ rawTxTests + ] + +rawTxTests :: TestTree +rawTxTests = + testGroup + "rawTx" + [ testCase "Can fetch valid tx file" fetchTx + , testCase "If an extension is supplied, it is replaced by .raw" fetchSignedTx + , testCase "Unable to fetch outside tx folder" fetchOutsideTxFolder + , testCase "Returns 404 for valid request when the endpoint is disabled" fetchWithDefaultConfig + ] + where + fetchTx :: IO () + fetchTx = do + initServerAndClient enableTxEndpointConfig $ \runRawTxClient -> do + result <- runRawTxClient txHash + result @?= Right (pack txFileContents) + + fetchSignedTx :: IO () + fetchSignedTx = do + initServerAndClient enableTxEndpointConfig $ \runRawTxClient -> do + result <- runRawTxClient $ txHash <> ".signed" + result @?= Right (pack txFileContents) + + fetchOutsideTxFolder :: IO () + fetchOutsideTxFolder = do + initServerAndClient enableTxEndpointConfig $ \runRawTxClient -> do + Left (FailureResponse _ res) <- runRawTxClient "../somefile" + responseStatusCode res @?= status404 + + fetchWithDefaultConfig :: IO () + fetchWithDefaultConfig = do + initServerAndClient def $ \runRawTxClient -> do + Left (FailureResponse _ res) <- runRawTxClient txHash + responseStatusCode res @?= status404 + +-- Ideally we would reuse the API type definition from BotPlutusInterface.Server but servant-client +-- can not generate a client for the websocket endpoint. +txProxy :: + Proxy + ( "rawTx" + :> Capture "hash" Text + :> Get '[JSON] Text + ) +txProxy = Proxy + +initServerAndClient :: PABConfig -> RawTxTest a -> IO a +initServerAndClient config test = do + withSystemTempDirectory "tx" $ \path -> do + let pabConfig :: PABConfig + pabConfig = config {pcTxFileDir = pack path} + state <- initState + writeFile (path txFileName) txFileContents + testWithApplication (pure $ app @EmptyContract pabConfig state) (initClientOnPort test) + where + initClientOnPort :: RawTxTest a -> Int -> IO a + initClientOnPort testToRun port = do + baseUrl <- parseBaseUrl "http://localhost" + manager <- newManager defaultManagerSettings + + let clientEnv :: ClientEnv + clientEnv = mkClientEnv manager $ baseUrl {baseUrlPort = port} + + runRawTxClient :: Text -> IO RawTxEndpointResponse + runRawTxClient hash = runClientM (client txProxy hash) clientEnv + + testToRun runRawTxClient + +txHash :: Text +txHash = "aaaa" + +txFileName :: FilePath +txFileName = "tx-" <> unpack txHash <> ".raw" + +txFileContents :: String +txFileContents = "test" + +enableTxEndpointConfig :: PABConfig +enableTxEndpointConfig = def {pcEnableTxEndpoint = True} + +-- Since we are not testing the contract endpoints we just use a newtype around Void as a Contract +newtype EmptyContract = EmptyContract {unEmptyContract :: Void} + deriving newtype (FromJSON, ToJSON) + +instance HasDefinitions EmptyContract where + getDefinitions :: [EmptyContract] + getDefinitions = [] + + getSchema :: EmptyContract -> [FunctionSchema FormSchema] + getSchema = absurd . unEmptyContract + + getContract :: (EmptyContract -> SomeBuiltin) + getContract = absurd . unEmptyContract From 942b15742e8089b98333367a2c101e8ad3fe6141 Mon Sep 17 00:00:00 2001 From: Giovanni Garufi Date: Tue, 15 Feb 2022 10:51:34 +0100 Subject: [PATCH 2/5] Change return type to RawTx from Text Change-type: patch Signed-off-by: Giovanni Garufi --- src/BotPlutusInterface/Server.hs | 13 ++++++----- src/BotPlutusInterface/Types.hs | 13 +++++++++++ test/Spec.hs | 2 +- test/Spec/BotPlutusInterface/Server.hs | 30 +++++++++++++++++--------- 4 files changed, 42 insertions(+), 16 deletions(-) diff --git a/src/BotPlutusInterface/Server.hs b/src/BotPlutusInterface/Server.hs index 83043672..1f56ab25 100644 --- a/src/BotPlutusInterface/Server.hs +++ b/src/BotPlutusInterface/Server.hs @@ -8,6 +8,7 @@ import BotPlutusInterface.Types ( ContractEnvironment (..), ContractState (ContractState, csActivity, csObservableState), PABConfig (..), + RawTx, SomeContractState (SomeContractState), ) import Control.Concurrent (ThreadId, forkIO) @@ -17,6 +18,7 @@ import Control.Monad.Error.Class (throwError) import Control.Monad.IO.Class (liftIO) import Data.Aeson (FromJSON, ToJSON (toJSON)) import Data.Aeson qualified as JSON +import Data.ByteString.Lazy qualified as LBS import Data.Either.Combinators (leftToMaybe) import Data.Kind (Type) import Data.Map qualified as Map @@ -24,7 +26,6 @@ import Data.Maybe (catMaybes) import Data.Proxy (Proxy (Proxy)) import Data.Row (Row) import Data.Text (Text, unpack) -import Data.Text.IO qualified as Text import Data.UUID.V4 qualified as UUID import Network.WebSockets ( Connection, @@ -70,7 +71,7 @@ type API a = ) :<|> ( "rawTx" :> Capture "hash" Text - :> Get '[JSON] Text + :> Get '[JSON] RawTx ) server :: HasDefinitions t => PABConfig -> AppState -> Server (API t) @@ -219,7 +220,7 @@ handleContract pabConf state@(AppState st) contract = liftIO $ do pure contractInstanceID -- | This handler will allow to retrieve raw transactions from the pcTxFileDir if pcEnableTxEndpoint is True -rawTxHandler :: PABConfig -> Text -> Handler Text +rawTxHandler :: PABConfig -> Text -> Handler RawTx rawTxHandler config hash = do -- Check that endpoint is enabled assert (pcEnableTxEndpoint config) @@ -237,8 +238,10 @@ rawTxHandler config hash = do fileExists <- liftIO $ doesFileExist path assert fileExists - -- Read contents of path - liftIO $ Text.readFile path + contents <- liftIO $ LBS.readFile path + case JSON.decode contents of + Just rawTx -> pure rawTx + Nothing -> throwError err404 where assert :: Bool -> Handler () assert True = pure () diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index 2416a0e5..d84efc58 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} module BotPlutusInterface.Types ( PABConfig (..), @@ -11,16 +12,19 @@ module BotPlutusInterface.Types ( HasDefinitions (..), SomeBuiltin (SomeBuiltin), endpointsToSchemas, + RawTx (..), ) where import Cardano.Api (NetworkId (Testnet), NetworkMagic (..)) import Cardano.Api.ProtocolParameters (ProtocolParameters) import Control.Concurrent.STM (TVar) import Data.Aeson (ToJSON) +import Data.Aeson.TH (Options (..), defaultOptions, deriveJSON) import Data.Default (Default (def)) import Data.Kind (Type) import Data.Map (Map) import Data.Text (Text) +import GHC.Generics (Generic) import Ledger (PubKeyHash) import Network.Wai.Handler.Warp (Port) import Plutus.PAB.Core.ContractInstance.STM (Activity) @@ -103,3 +107,12 @@ instance Default PABConfig where , pcPort = 9080 , pcEnableTxEndpoint = False } + +data RawTx = RawTx + { rawType :: Text + , rawDescription :: Text + , rawCborHex :: Text + } + deriving (Generic, Eq, Show) + +$(deriveJSON defaultOptions {fieldLabelModifier = drop 3} ''RawTx) diff --git a/test/Spec.hs b/test/Spec.hs index 5aa88aa0..9a2e01ef 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,8 +2,8 @@ module Main (main) where import Spec.BotPlutusInterface.Contract qualified import Spec.BotPlutusInterface.PreBalance qualified -import Spec.BotPlutusInterface.UtxoParser qualified import Spec.BotPlutusInterface.Server qualified +import Spec.BotPlutusInterface.UtxoParser qualified import Test.Tasty (TestTree, defaultMain, testGroup) import Prelude diff --git a/test/Spec/BotPlutusInterface/Server.hs b/test/Spec/BotPlutusInterface/Server.hs index 4917b925..a56d2a73 100644 --- a/test/Spec/BotPlutusInterface/Server.hs +++ b/test/Spec/BotPlutusInterface/Server.hs @@ -4,6 +4,7 @@ import BotPlutusInterface.Server (app, initState) import BotPlutusInterface.Types ( HasDefinitions (..), PABConfig (..), + RawTx (..), SomeBuiltin (..), ) @@ -20,7 +21,8 @@ import Servant.API (Capture, Get, JSON, (:>)) import Servant.Client (ClientEnv, ClientError (..), client, mkClientEnv, responseStatusCode, runClientM) import Servant.Client.Core.BaseUrl (BaseUrl (..), parseBaseUrl) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON, encode) +import Data.ByteString.Lazy qualified as LBS import Data.Default (def) import Data.Proxy (Proxy (..)) import Data.Text (Text, pack, unpack) @@ -29,13 +31,13 @@ import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import Prelude -type RawTxEndpointResponse = Either ClientError Text +type RawTxEndpointResponse = Either ClientError RawTx type RawTxTest a = (Text -> IO RawTxEndpointResponse) -> IO a tests :: TestTree tests = testGroup - "Server" + "BotPlutusInterface.Server" [ rawTxTests ] @@ -53,13 +55,13 @@ rawTxTests = fetchTx = do initServerAndClient enableTxEndpointConfig $ \runRawTxClient -> do result <- runRawTxClient txHash - result @?= Right (pack txFileContents) + result @?= Right rawTx fetchSignedTx :: IO () fetchSignedTx = do initServerAndClient enableTxEndpointConfig $ \runRawTxClient -> do result <- runRawTxClient $ txHash <> ".signed" - result @?= Right (pack txFileContents) + result @?= Right rawTx fetchOutsideTxFolder :: IO () fetchOutsideTxFolder = do @@ -79,7 +81,7 @@ txProxy :: Proxy ( "rawTx" :> Capture "hash" Text - :> Get '[JSON] Text + :> Get '[JSON] RawTx ) txProxy = Proxy @@ -89,7 +91,7 @@ initServerAndClient config test = do let pabConfig :: PABConfig pabConfig = config {pcTxFileDir = pack path} state <- initState - writeFile (path txFileName) txFileContents + LBS.writeFile (path txFileName) txFileContents testWithApplication (pure $ app @EmptyContract pabConfig state) (initClientOnPort test) where initClientOnPort :: RawTxTest a -> Int -> IO a @@ -106,13 +108,21 @@ initServerAndClient config test = do testToRun runRawTxClient txHash :: Text -txHash = "aaaa" +txHash = "test" txFileName :: FilePath txFileName = "tx-" <> unpack txHash <> ".raw" -txFileContents :: String -txFileContents = "test" +rawTx :: RawTx +rawTx = + RawTx + { rawType = "TxBodyAlonzo" + , rawDescription = "description" + , rawCborHex = "hex" + } + +txFileContents :: LBS.ByteString +txFileContents = encode rawTx enableTxEndpointConfig :: PABConfig enableTxEndpointConfig = def {pcEnableTxEndpoint = True} From bc89ade1412d0a57fc57bc606293ee50c960f130 Mon Sep 17 00:00:00 2001 From: Giovanni Garufi Date: Tue, 15 Feb 2022 10:52:40 +0100 Subject: [PATCH 3/5] Update examples with new config parameter Change-type: patch Signed-off-by: Giovanni Garufi --- examples/plutus-game/app/Main.hs | 1 + examples/plutus-nft/app/Main.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/examples/plutus-game/app/Main.hs b/examples/plutus-game/app/Main.hs index 074420bd..48040075 100644 --- a/examples/plutus-game/app/Main.hs +++ b/examples/plutus-game/app/Main.hs @@ -64,5 +64,6 @@ main = do , pcDryRun = True , pcLogLevel = Debug , pcProtocolParamsFile = "./protocol.json" + , pcEnableTxEndpoint = False } BotPlutusInterface.runPAB @GameContracts pabConf diff --git a/examples/plutus-nft/app/Main.hs b/examples/plutus-nft/app/Main.hs index 783a5383..6d3992e5 100644 --- a/examples/plutus-nft/app/Main.hs +++ b/examples/plutus-nft/app/Main.hs @@ -64,5 +64,6 @@ main = do , pcDryRun = True , pcLogLevel = Debug , pcProtocolParamsFile = "./protocol.json" + , pcEnableTxEndpoint = False } BotPlutusInterface.runPAB @MintNFTContracts pabConf From b5d2e80de7f3c6fe21f5d872f6a7057eb9dbe0de Mon Sep 17 00:00:00 2001 From: Giovanni Garufi Date: Tue, 15 Feb 2022 11:04:56 +0100 Subject: [PATCH 4/5] Rename RawTx fields Change-type: patch Signed-off-by: Giovanni Garufi --- src/BotPlutusInterface/Types.hs | 10 ++++++---- test/Spec/BotPlutusInterface/Server.hs | 6 +++--- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index d84efc58..22661ff8 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -109,10 +109,12 @@ instance Default PABConfig where } data RawTx = RawTx - { rawType :: Text - , rawDescription :: Text - , rawCborHex :: Text + { _type :: Text + , _description :: Text + , _cborHex :: Text } deriving (Generic, Eq, Show) -$(deriveJSON defaultOptions {fieldLabelModifier = drop 3} ''RawTx) +-- type is a reserved keyword in haskell and can not be used as a field name +-- when converting this to JSON we drop the _ prefix from each field +$(deriveJSON defaultOptions {fieldLabelModifier = drop 1} ''RawTx) diff --git a/test/Spec/BotPlutusInterface/Server.hs b/test/Spec/BotPlutusInterface/Server.hs index a56d2a73..287efa66 100644 --- a/test/Spec/BotPlutusInterface/Server.hs +++ b/test/Spec/BotPlutusInterface/Server.hs @@ -116,9 +116,9 @@ txFileName = "tx-" <> unpack txHash <> ".raw" rawTx :: RawTx rawTx = RawTx - { rawType = "TxBodyAlonzo" - , rawDescription = "description" - , rawCborHex = "hex" + { _type = "TxBodyAlonzo" + , _description = "description" + , _cborHex = "hex" } txFileContents :: LBS.ByteString From 294e2502033e82216c4b855b7865c1eb236b99c4 Mon Sep 17 00:00:00 2001 From: Giovanni Garufi Date: Tue, 15 Feb 2022 13:09:03 +0100 Subject: [PATCH 5/5] Split each endpoint into its own type synonym Change-type: patch Signed-off-by: Giovanni Garufi --- bot-plutus-interface.cabal | 1 - src/BotPlutusInterface/Server.hs | 43 +++++++++++++++++--------- src/BotPlutusInterface/Types.hs | 2 +- test/Spec/BotPlutusInterface/Server.hs | 12 ++----- 4 files changed, 31 insertions(+), 27 deletions(-) diff --git a/bot-plutus-interface.cabal b/bot-plutus-interface.cabal index dd2a4012..08c7cc8d 100644 --- a/bot-plutus-interface.cabal +++ b/bot-plutus-interface.cabal @@ -186,7 +186,6 @@ test-suite bot-plutus-interface-test , quickcheck-instances , row-types , serialise - , servant , servant-client , servant-client-core , stm diff --git a/src/BotPlutusInterface/Server.hs b/src/BotPlutusInterface/Server.hs index 1f56ab25..5ccab747 100644 --- a/src/BotPlutusInterface/Server.hs +++ b/src/BotPlutusInterface/Server.hs @@ -1,6 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -module BotPlutusInterface.Server (app, initState) where +module BotPlutusInterface.Server ( + app, + initState, + WebSocketEndpoint, + ActivateContractEndpoint, + RawTxEndpoint, +) where import BotPlutusInterface.Contract (runContract) import BotPlutusInterface.Types ( @@ -61,18 +67,25 @@ initState :: IO AppState initState = AppState <$> newTVarIO Map.empty -- | Mock API Schema, stripped endpoints that we don't use in this project -type API a = - ("ws" :> WebSocketPending) -- Combined websocket (subscription protocol) - :<|> ( "api" - :> "contract" - :> "activate" - :> ReqBody '[JSON] (ContractActivationArgs a) - :> Post '[JSON] ContractInstanceId -- Start a new instance. - ) - :<|> ( "rawTx" - :> Capture "hash" Text - :> Get '[JSON] RawTx - ) +type API a = WebSocketEndpoint :<|> ActivateContractEndpoint a :<|> RawTxEndpoint + +-- Endpoints are split up so it is easier to test them. In particular servant-client +-- can not generate a client for the WebSocketEndpoint; this allows us to still +-- use servant-client to test the other endpoints + +type WebSocketEndpoint = "ws" :> WebSocketPending -- Combined websocket (subscription protocol) + +type ActivateContractEndpoint a = + "api" + :> "contract" + :> "activate" + :> ReqBody '[JSON] (ContractActivationArgs a) + :> Post '[JSON] ContractInstanceId -- Start a new instance. + +type RawTxEndpoint = + "rawTx" + :> Capture "hash" Text + :> Get '[JSON] RawTx server :: HasDefinitions t => PABConfig -> AppState -> Server (API t) server pabConfig state = @@ -223,9 +236,9 @@ handleContract pabConf state@(AppState st) contract = liftIO $ do rawTxHandler :: PABConfig -> Text -> Handler RawTx rawTxHandler config hash = do -- Check that endpoint is enabled - assert (pcEnableTxEndpoint config) + assert config.pcEnableTxEndpoint -- Absolute path to pcTxFileDir that is specified in the config - txFolderPath <- liftIO $ makeAbsolute (unpack $ pcTxFileDir config) + txFolderPath <- liftIO $ makeAbsolute (unpack config.pcTxFileDir) -- Add/Set .raw extension on path let suppliedPath :: FilePath diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index 48832068..756a0217 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -135,4 +135,4 @@ data RawTx = RawTx -- type is a reserved keyword in haskell and can not be used as a field name -- when converting this to JSON we drop the _ prefix from each field -$(deriveJSON defaultOptions {fieldLabelModifier = drop 1} ''RawTx) +deriveJSON defaultOptions {fieldLabelModifier = drop 1} ''RawTx diff --git a/test/Spec/BotPlutusInterface/Server.hs b/test/Spec/BotPlutusInterface/Server.hs index 287efa66..4a47de2f 100644 --- a/test/Spec/BotPlutusInterface/Server.hs +++ b/test/Spec/BotPlutusInterface/Server.hs @@ -1,6 +1,6 @@ module Spec.BotPlutusInterface.Server (tests) where -import BotPlutusInterface.Server (app, initState) +import BotPlutusInterface.Server (RawTxEndpoint, app, initState) import BotPlutusInterface.Types ( HasDefinitions (..), PABConfig (..), @@ -17,7 +17,6 @@ import Test.Tasty.HUnit (testCase, (@?=)) import Network.HTTP.Client (defaultManagerSettings, newManager) import Network.HTTP.Types.Status (status404) import Network.Wai.Handler.Warp (testWithApplication) -import Servant.API (Capture, Get, JSON, (:>)) import Servant.Client (ClientEnv, ClientError (..), client, mkClientEnv, responseStatusCode, runClientM) import Servant.Client.Core.BaseUrl (BaseUrl (..), parseBaseUrl) @@ -75,14 +74,7 @@ rawTxTests = Left (FailureResponse _ res) <- runRawTxClient txHash responseStatusCode res @?= status404 --- Ideally we would reuse the API type definition from BotPlutusInterface.Server but servant-client --- can not generate a client for the websocket endpoint. -txProxy :: - Proxy - ( "rawTx" - :> Capture "hash" Text - :> Get '[JSON] RawTx - ) +txProxy :: Proxy RawTxEndpoint txProxy = Proxy initServerAndClient :: PABConfig -> RawTxTest a -> IO a