diff --git a/bot-plutus-interface.cabal b/bot-plutus-interface.cabal index ee05dc6b..08c7cc8d 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,16 @@ test-suite bot-plutus-interface-test , quickcheck-instances , row-types , serialise + , 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/examples/plutus-game/app/Main.hs b/examples/plutus-game/app/Main.hs index ded25b77..4cd33f54 100644 --- a/examples/plutus-game/app/Main.hs +++ b/examples/plutus-game/app/Main.hs @@ -66,5 +66,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 8c3de429..2afad858 100644 --- a/examples/plutus-nft/app/Main.hs +++ b/examples/plutus-nft/app/Main.hs @@ -66,5 +66,6 @@ main = do , pcDryRun = True , pcLogLevel = Debug , pcProtocolParamsFile = "./protocol.json" + , pcEnableTxEndpoint = False } BotPlutusInterface.runPAB @MintNFTContracts pabConf diff --git a/src/BotPlutusInterface/Server.hs b/src/BotPlutusInterface/Server.hs index e0829daf..5ccab747 100644 --- a/src/BotPlutusInterface/Server.hs +++ b/src/BotPlutusInterface/Server.hs @@ -1,27 +1,37 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -module BotPlutusInterface.Server (app, initState) where +module BotPlutusInterface.Server ( + app, + initState, + WebSocketEndpoint, + ActivateContractEndpoint, + RawTxEndpoint, +) where import BotPlutusInterface.Contract (runContract) import BotPlutusInterface.Types ( AppState (AppState), ContractEnvironment (..), ContractState (ContractState, csActivity, csObservableState), - PABConfig, + PABConfig (..), + RawTx, 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 +import Data.ByteString.Lazy qualified as LBS import Data.Either.Combinators (leftToMaybe) import Data.Kind (Type) 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.UUID.V4 qualified as UUID import Network.WebSockets ( Connection, @@ -45,9 +55,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 @@ -55,18 +67,31 @@ 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. - ) +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 = - websocketHandler state :<|> activateContractHandler pabConfig state + websocketHandler state + :<|> activateContractHandler pabConfig state + :<|> rawTxHandler pabConfig apiProxy :: forall (t :: Type). Proxy (API t) apiProxy = Proxy @@ -206,3 +231,31 @@ 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 RawTx +rawTxHandler config hash = do + -- Check that endpoint is enabled + assert config.pcEnableTxEndpoint + -- Absolute path to pcTxFileDir that is specified in the config + txFolderPath <- liftIO $ makeAbsolute (unpack config.pcTxFileDir) + + -- 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 + + contents <- liftIO $ LBS.readFile path + case JSON.decode contents of + Just rawTx -> pure rawTx + Nothing -> throwError err404 + where + assert :: Bool -> Handler () + assert True = pure () + assert False = throwError err404 diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index d8b3d930..756a0217 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} module BotPlutusInterface.Types ( PABConfig (..), @@ -13,6 +14,7 @@ module BotPlutusInterface.Types ( HasDefinitions (..), SomeBuiltin (SomeBuiltin), endpointsToSchemas, + RawTx (..), ) where import Cardano.Api (NetworkId (Testnet), NetworkMagic (..)) @@ -20,6 +22,7 @@ import Cardano.Api.ProtocolParameters (ProtocolParameters) import Control.Concurrent.STM (TVar) import Data.Aeson (ToJSON) import Data.Aeson qualified as JSON +import Data.Aeson.TH (Options (..), defaultOptions, deriveJSON) import Data.Default (Default (def)) import Data.Kind (Type) import Data.Map (Map) @@ -59,6 +62,7 @@ data PABConfig = PABConfig , pcLogLevel :: !LogLevel , pcOwnPubKeyHash :: !PubKeyHash , pcPort :: !Port + , pcEnableTxEndpoint :: !Bool } deriving stock (Show, Eq) @@ -119,4 +123,16 @@ instance Default PABConfig where , pcLogLevel = Info , pcOwnPubKeyHash = "" , pcPort = 9080 + , pcEnableTxEndpoint = False } + +data RawTx = RawTx + { _type :: Text + , _description :: Text + , _cborHex :: Text + } + deriving (Generic, Eq, Show) + +-- 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.hs b/test/Spec.hs index 866f076f..9a2e01ef 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,6 +2,7 @@ module Main (main) where import Spec.BotPlutusInterface.Contract qualified import Spec.BotPlutusInterface.PreBalance qualified +import Spec.BotPlutusInterface.Server qualified import Spec.BotPlutusInterface.UtxoParser 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..4a47de2f --- /dev/null +++ b/test/Spec/BotPlutusInterface/Server.hs @@ -0,0 +1,134 @@ +module Spec.BotPlutusInterface.Server (tests) where + +import BotPlutusInterface.Server (RawTxEndpoint, app, initState) +import BotPlutusInterface.Types ( + HasDefinitions (..), + PABConfig (..), + RawTx (..), + 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.Client (ClientEnv, ClientError (..), client, mkClientEnv, responseStatusCode, runClientM) +import Servant.Client.Core.BaseUrl (BaseUrl (..), parseBaseUrl) + +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) +import Data.Void (Void, absurd) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Prelude + +type RawTxEndpointResponse = Either ClientError RawTx +type RawTxTest a = (Text -> IO RawTxEndpointResponse) -> IO a + +tests :: TestTree +tests = + testGroup + "BotPlutusInterface.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 rawTx + + fetchSignedTx :: IO () + fetchSignedTx = do + initServerAndClient enableTxEndpointConfig $ \runRawTxClient -> do + result <- runRawTxClient $ txHash <> ".signed" + result @?= Right rawTx + + 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 + +txProxy :: Proxy RawTxEndpoint +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 + LBS.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 = "test" + +txFileName :: FilePath +txFileName = "tx-" <> unpack txHash <> ".raw" + +rawTx :: RawTx +rawTx = + RawTx + { _type = "TxBodyAlonzo" + , _description = "description" + , _cborHex = "hex" + } + +txFileContents :: LBS.ByteString +txFileContents = encode rawTx + +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