Merge pull request #49 from mlabs-haskell/nazrhom/raw-tx

nazrhom · web-flow · commit 4877e4ad3d34 · 2022-02-15T13:31:03.000+01:00
Nazrhom/raw tx
diff --git 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
@@ -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
@@ -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
@@ -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,28 +55,43 @@ 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
 
 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
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module BotPlutusInterface.Types (
   PABConfig (..),
@@ -13,13 +14,15 @@ 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 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
@@ -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
@@ -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

Original file line number	Diff line number	Diff line change
`@@ -66,5 +66,6 @@ main = do`
`66`	`66`	`, pcDryRun = True`
`67`	`67`	`, pcLogLevel = Debug`
`68`	`68`	`, pcProtocolParamsFile = "./protocol.json"`
	`69`	`+ , pcEnableTxEndpoint = False`
`69`	`70`	`}`
`70`	`71`	`BotPlutusInterface.runPAB @GameContracts pabConf`