Merge pull request #57 from mlabs-haskell/sam/late-raw-tx-changes

Convert Text to TxId, update examples

Author: samuelWilliams99

.github/workflows/integrate.yaml

@@ -61,6 +61,7 @@ jobs:
           extra_nix_config: |
             trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
             substituters = https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/
+            extra-experimental-features = nix-command flakes
       - uses: cachix/cachix-action@v10
         with:
           name: mlabs
@@ -75,4 +76,4 @@ jobs:
             dist-newstyle
           key: ${{ runner.os }}-cabal
       - name: Build the full ci derivation
-        run: nix build -L .#check.x86_64-linux --extra-experimental-features nix-command --extra-experimental-features flakes
+        run: make nix_build

Makefile

@@ -3,7 +3,7 @@
 # In most cases you should execute Make after entering nix-shell.
 
 .PHONY: hoogle pab_servers_all pab_servers_all pab_db clean_db \
-	build test accept_pirs watch ghci readme_contents \
+	nix_build build test accept_pirs watch ghci readme_contents \
 	format lint requires_nix_shell 
 
 usage:
@@ -16,6 +16,7 @@ usage:
 	@echo
 	@echo "Available commands:"
 	@echo "  hoogle              -- Start local hoogle"
+	@echo "  nix_build           -- Run nix build -L on all targets"
 	@echo "  build               -- Run cabal v2-build"
 	@echo "  watch               -- Track files: bot-plutus-interface.cabal, src/* and run 'make build' on change"
 	@echo "  test                -- Run cabal v2-test"
@@ -44,6 +45,9 @@ ifdef FLAGS
 GHC_FLAGS = --ghc-options "$(FLAGS)"
 endif
 
+nix_build:
+	nix build -L .#check.x86_64-linux .#plutus-transfer:exe:plutus-transfer-pab .#plutus-game:exe:plutus-game-pab .#plutus-nft:exe:plutus-nft-pab
+
 build: requires_nix_shell
 	cabal v2-build $(GHC_FLAGS)
 

bot-plutus-interface.cabal

@@ -118,6 +118,7 @@ library
     , plutus-tx
     , plutus-tx-plugin
     , process
+    , QuickCheck
     , row-types
     , serialise
     , servant
@@ -186,6 +187,7 @@ test-suite bot-plutus-interface-test
     , quickcheck-instances
     , row-types
     , serialise
+    , servant
     , servant-client
     , servant-client-core
     , stm

cabal.project

@@ -2,11 +2,13 @@
 index-state: 2021-10-20T00:00:00Z
 
 packages: ./.
+          ./examples/plutus-game/plutus-game.cabal
+          ./examples/plutus-transfer/plutus-transfer.cabal
+          ./examples/plutus-nft/plutus-nft.cabal
 
 -- You never, ever, want this.
 write-ghc-environment-files: never
 
 -- Always build tests and benchmarks.
 tests: true
 benchmarks: true
-

examples/plutus-game/app/Main.hs

@@ -66,6 +66,6 @@ main = do
           , pcDryRun = True
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
-          , pcEnableTxEndpoint = False
+          , pcEnableTxEndpoint = True
           }
   BotPlutusInterface.runPAB @GameContracts pabConf

examples/plutus-nft/app/Main.hs

@@ -66,6 +66,6 @@ main = do
           , pcDryRun = True
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
-          , pcEnableTxEndpoint = False
+          , pcEnableTxEndpoint = True
           }
   BotPlutusInterface.runPAB @MintNFTContracts pabConf

examples/plutus-transfer/app/Main.hs

@@ -65,5 +65,6 @@ main = do
           , pcDryRun = True
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
+          , pcEnableTxEndpoint = True
           }
   BotPlutusInterface.runPAB @TransferContracts pabConf

src/BotPlutusInterface/Files.hs

@@ -9,6 +9,7 @@ module BotPlutusInterface.Files (
   signingKeyFilePath,
   txFilePath,
   txFileName,
+  txIdToText,
   writeAll,
   writePolicyScriptFile,
   redeemerJsonFilePath,
@@ -84,7 +85,7 @@ import Plutus.V1.Ledger.Api (
  )
 import PlutusTx (ToData, toData)
 import PlutusTx.Builtins (fromBuiltin)
-import System.FilePath (replaceExtension, takeExtension, (</>))
+import System.FilePath (takeExtension, (</>))
 import Prelude
 
 -- | Filename of a minting policy script
@@ -115,12 +116,13 @@ signingKeyFilePath pabConf (PubKeyHash pubKeyHash) =
    in pabConf.pcSigningKeyFileDir <> "/signing-key-" <> h <> ".skey"
 
 txFilePath :: PABConfig -> Text -> Tx.Tx -> Text
-txFilePath pabConf ext tx =
-  let txId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txId tx
-   in pabConf.pcTxFileDir <> "/" <> txFileName txId ext
+txFilePath pabConf ext tx = pabConf.pcTxFileDir <> "/" <> txFileName (Tx.txId tx) ext
 
-txFileName :: Text -> Text -> Text
-txFileName name ext = Text.pack $ replaceExtension ("tx-" <> Text.unpack name) (Text.unpack ext)
+txFileName :: TxId.TxId -> Text -> Text
+txFileName txId ext = "tx-" <> txIdToText txId <> "." <> ext
+
+txIdToText :: TxId.TxId -> Text
+txIdToText = encodeByteString . fromBuiltin . TxId.getTxId
 
 -- | Compiles and writes a script file under the given folder
 writePolicyScriptFile ::

src/BotPlutusInterface/Server.hs

@@ -6,10 +6,11 @@ module BotPlutusInterface.Server (
   WebSocketEndpoint,
   ActivateContractEndpoint,
   RawTxEndpoint,
+  TxIdCapture (TxIdCapture),
 ) where
 
 import BotPlutusInterface.Contract (runContract)
-import BotPlutusInterface.Files (txFileName)
+import BotPlutusInterface.Files (txFileName, txIdToText)
 import BotPlutusInterface.Types (
   AppState (AppState),
   ContractEnvironment (..),
@@ -25,15 +26,19 @@ 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.Bifunctor (bimap)
 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.String (fromString)
+import Data.Text (Text, pack, unpack)
+import Data.Text.Encoding (encodeUtf8)
 import Data.UUID.V4 qualified as UUID
+import Ledger.TxId (TxId (TxId))
 import Network.WebSockets (
   Connection,
   PendingConnection,
@@ -56,11 +61,24 @@ import Plutus.PAB.Webserver.Types (
   ContractActivationArgs (..),
   InstanceStatusToClient (ContractFinished, NewObservableState),
  )
-import Servant.API (Capture, Get, JSON, Post, ReqBody, (:<|>) (..), (:>))
+import Plutus.V1.Ledger.Bytes (LedgerBytes (LedgerBytes), fromHex)
+import PlutusTx.Prelude (lengthOfByteString)
+import Servant.API (
+  Capture,
+  FromHttpApiData (parseUrlPiece),
+  Get,
+  JSON,
+  Post,
+  ReqBody,
+  ToHttpApiData (toUrlPiece),
+  (:<|>) ((:<|>)),
+  (:>),
+ )
 import Servant.API.WebSocket (WebSocketPending)
 import Servant.Server (Application, Handler, Server, err404, serve)
-import System.Directory (canonicalizePath, doesFileExist, makeAbsolute)
-import System.FilePath (takeDirectory, (</>))
+import System.Directory (doesFileExist, makeAbsolute)
+import System.FilePath ((</>))
+import Test.QuickCheck (Arbitrary (arbitrary), elements, vectorOf)
 import Wallet.Types (ContractInstanceId (..))
 import Prelude
 
@@ -85,9 +103,30 @@ type ActivateContractEndpoint a =
 
 type RawTxEndpoint =
   "raw-tx"
-    :> Capture "txId" Text
+    :> Capture "tx-id" TxIdCapture
     :> Get '[JSON] RawTx
 
+newtype TxIdCapture = TxIdCapture TxId
+  deriving newtype (Eq, Show)
+
+instance FromHttpApiData TxIdCapture where
+  parseUrlPiece :: Text -> Either Text TxIdCapture
+  parseUrlPiece t = bimap pack bytesToTxIdCapture $ checkLength =<< fromHex (encodeUtf8 t)
+    where
+      checkLength :: LedgerBytes -> Either String LedgerBytes
+      checkLength b@(LedgerBytes bs) =
+        if lengthOfByteString bs == 32
+          then Right b
+          else Left "Invalid length"
+      bytesToTxIdCapture :: LedgerBytes -> TxIdCapture
+      bytesToTxIdCapture (LedgerBytes b) = TxIdCapture $ TxId b
+
+instance ToHttpApiData TxIdCapture where
+  toUrlPiece (TxIdCapture txId) = txIdToText txId
+
+instance Arbitrary TxIdCapture where
+  arbitrary = TxIdCapture . fromString <$> vectorOf 64 (elements "0123456789abcdefABCDEF")
+
 server :: HasDefinitions t => PABConfig -> AppState -> Server (API t)
 server pabConfig state =
   websocketHandler state
@@ -234,20 +273,17 @@ 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 RawTx
-rawTxHandler config txId = do
+rawTxHandler :: PABConfig -> TxIdCapture -> Handler RawTx
+rawTxHandler config (TxIdCapture txId) = 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 = txFolderPath </> unpack (txFileName txId ".raw")
-  -- Resolve path indirections
-  path <- liftIO $ canonicalizePath suppliedPath
-  -- ensure it does not try to escape txFolderPath
-  assert (takeDirectory path == txFolderPath)
+  -- Create full path
+  let path :: FilePath
+      path = txFolderPath </> unpack (txFileName txId "raw")
+
   -- ensure file exists
   fileExists <- liftIO $ doesFileExist path
   assert fileExists

test/Spec/BotPlutusInterface/Server.hs

@@ -1,38 +1,44 @@
 module Spec.BotPlutusInterface.Server (tests) where
 
 import BotPlutusInterface.Files (txFileName)
-import BotPlutusInterface.Server (RawTxEndpoint, app, initState)
+import BotPlutusInterface.Server (RawTxEndpoint, TxIdCapture (TxIdCapture), app, initState)
 import BotPlutusInterface.Types (
   HasDefinitions (..),
   PABConfig (..),
   RawTx (..),
   SomeBuiltin (..),
  )
 
+import Ledger.TxId (TxId)
 import Playground.Types (FunctionSchema)
 import Schema (FormSchema)
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (testCase, (@?=))
+import Test.Tasty.QuickCheck (Property, testProperty, (===))
 
 import Network.HTTP.Client (defaultManagerSettings, newManager)
 import Network.HTTP.Types.Status (status404)
 import Network.Wai.Handler.Warp (testWithApplication)
+import Servant.API (
+  FromHttpApiData (parseUrlPiece),
+  ToHttpApiData (toUrlPiece),
+ )
 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.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
+type RawTxTest a = (TxId -> IO RawTxEndpointResponse) -> IO a
 
 tests :: TestTree
 tests =
@@ -46,9 +52,9 @@ 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 missing txs" fetchMissingTx
     , testCase "Returns 404 for valid request when the endpoint is disabled" fetchWithDefaultConfig
+    , testProperty "TxId URL encoding reversible" txIdReversible
     ]
   where
     fetchTx :: IO ()
@@ -57,16 +63,10 @@ rawTxTests =
         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
+    fetchMissingTx :: IO ()
+    fetchMissingTx = do
       initServerAndClient enableTxEndpointConfig $ \runRawTxClient -> do
-        Left (FailureResponse _ res) <- runRawTxClient "../somefile"
+        Left (FailureResponse _ res) <- runRawTxClient txHash2
         responseStatusCode res @?= status404
 
     fetchWithDefaultConfig :: IO ()
@@ -75,6 +75,9 @@ rawTxTests =
         Left (FailureResponse _ res) <- runRawTxClient txHash
         responseStatusCode res @?= status404
 
+    txIdReversible :: TxIdCapture -> Property
+    txIdReversible txId = parseUrlPiece (toUrlPiece txId) === Right txId
+
 txProxy :: Proxy RawTxEndpoint
 txProxy = Proxy
 
@@ -95,16 +98,19 @@ initServerAndClient config test = do
       let clientEnv :: ClientEnv
           clientEnv = mkClientEnv manager $ baseUrl {baseUrlPort = port}
 
-          runRawTxClient :: Text -> IO RawTxEndpointResponse
-          runRawTxClient hash = runClientM (client txProxy hash) clientEnv
+          runRawTxClient :: TxId -> IO RawTxEndpointResponse
+          runRawTxClient txId = runClientM (client txProxy (TxIdCapture txId)) clientEnv
 
       testToRun runRawTxClient
 
-txHash :: Text
-txHash = "test"
+txHash :: TxId
+txHash = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+
+txHash2 :: TxId
+txHash2 = "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
 
 testTxFileName :: FilePath
-testTxFileName = unpack $ txFileName txHash ".raw"
+testTxFileName = unpack $ txFileName txHash "raw"
 
 rawTx :: RawTx
 rawTx =