Skip to content

Commit

Permalink
SCP-2107: JSON encoding bug (#2981)
Browse files Browse the repository at this point in the history 
* SCP-2107: JSON encoding bug
* Add a test sending a response to the contact
  • Loading branch information
@j-mueller
j-mueller committed Apr 13, 2021
1 parent 31846fa commit a525e55
Show file tree
Hide file tree
Showing 3 changed files with 140 additions and 59 deletions.
144 changes: 106 additions & 38 deletions plutus-pab/src/Plutus/PAB/ContractCLI.hs
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,8 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
Expand All @@ -25,30 +27,57 @@ module Plutus.PAB.ContractCLI
, runCliCommand
, runUpdate
, Command(..)
-- * Debugging
, contractCliApp
, runPromptPure
, runPromptIO
) where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Encode.Pretty as JSON
import Data.Bifunctor (bimap)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import Data.Proxy (Proxy (..))
import Data.Row (AllUniqueLabels, Forall, type (.\\))
import Data.Text (Text)
import qualified Data.Text as Text
import Options.Applicative (CommandFields, Mod, Parser, command, customExecParser, disambiguate,
fullDesc, helper, idm, info, prefs, progDesc, showHelpOnEmpty,
showHelpOnError, subparser)
import Playground.Schema (EndpointToSchema, endpointsToSchemas)
import Plutus.Contract (BlockchainActions, Contract)
import Plutus.Contract.Schema (Input, Output)
import qualified Plutus.Contract.State as ContractState
import System.Exit (ExitCode (ExitFailure), exitSuccess, exitWith)
import Control.Monad.Freer (Eff, LastMember, Member, interpret, run, runM, send, sendM,
type (~>))
import Control.Monad.Freer.Error (Error, runError, throwError)
import qualified Control.Monad.Freer.Extras.Modify as Modify
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Encode.Pretty as JSON
import Data.Bifunctor (bimap)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable (traverse_)
import Data.Proxy (Proxy (..))
import Data.Row (AllUniqueLabels, Forall, type (.\\))
import Data.Text (Text)
import qualified Data.Text as Text
import Options.Applicative (CommandFields, Mod, Parser, ParserResult, command, disambiguate,
execParserPure, fullDesc, helper, idm, info, prefs, progDesc,
showHelpOnEmpty, showHelpOnError, subparser)
import qualified Options.Applicative
import Playground.Schema (EndpointToSchema, endpointsToSchemas)
import Plutus.Contract (BlockchainActions, Contract)
import Plutus.Contract.Schema (Input, Output)
import qualified Plutus.Contract.State as ContractState
import Prelude hiding (getContents)
import System.Environment (getArgs)
import System.Exit (ExitCode (ExitFailure), exitSuccess, exitWith)
import qualified System.IO

-- | Read from stdin
data CliEff r where
GetContents :: CliEff BS.ByteString -- ^ Read from stdin
HandleParseResult :: Show a => ParserResult a -> CliEff a -- ^ Deal with a 'ParserResult' from @optparse-applicative@

getContents :: forall effs. Member CliEff effs => Eff effs BS.ByteString
getContents = send GetContents

handleParseResult :: forall a effs. (Member CliEff effs, Show a) => ParserResult a -> Eff effs a
handleParseResult = send . HandleParseResult

-- | A program that takes some argument, reads some input
-- and returns either an error or a response
type Prompt a = Eff '[CliEff, Error [BS.ByteString]] a

data Command
= Initialise
| Update
Expand Down Expand Up @@ -77,27 +106,26 @@ exportSignatureParser =
command "export-signature" $
info (pure ExportSignature) (fullDesc <> progDesc "Export the contract's signature.")

runCliCommand :: forall w s s2 m.
runCliCommand :: forall w s s2.
( AllUniqueLabels (Input s)
, Forall (Input s) FromJSON
, Forall (Output s) ToJSON
, Forall (Input s) ToJSON
, EndpointToSchema (s .\\ s2)
, MonadIO m
, ToJSON w
, Monoid w
)
=> Proxy s2
-> Contract w s Text ()
-> Command
-> m (Either BS8.ByteString BS8.ByteString)
runCliCommand _ schema Initialise = pure $ Right $ BSL.toStrict $ JSON.encodePretty $ ContractState.initialiseContract schema
-> Prompt BS8.ByteString
runCliCommand _ schema Initialise = pure $ BSL.toStrict $ JSON.encodePretty $ ContractState.initialiseContract schema
runCliCommand _ schema Update = do
arg <- liftIO BS.getContents
pure $ runUpdate schema arg
arg <- getContents
runUpdate schema arg
runCliCommand _ _ ExportSignature = do
let r = endpointsToSchemas @(s .\\ s2)
pure $ Right $ BSL.toStrict $ JSON.encodePretty r
pure $ BSL.toStrict $ JSON.encodePretty r

runUpdate :: forall w s.
( AllUniqueLabels (Input s)
Expand All @@ -109,8 +137,8 @@ runUpdate :: forall w s.
)
=> Contract w s Text ()
-> BS.ByteString
-> Either BS8.ByteString BS8.ByteString
runUpdate contract arg =
-> Prompt BS8.ByteString
runUpdate contract arg = either (throwError @[BS.ByteString] . return) pure $
bimap
(BSL.toStrict . JSON.encodePretty . Text.pack)
(BSL.toStrict . JSON.encodePretty . ContractState.insertAndUpdateContract contract)
Expand Down Expand Up @@ -145,17 +173,57 @@ commandLineApp' :: forall w s s2.
=> Proxy s2
-> Contract w s Text ()
-> IO ()
commandLineApp' p schema = do
cmd <-
customExecParser
(prefs $ disambiguate <> showHelpOnEmpty <> showHelpOnError)
(info (helper <*> commandLineParser) idm)
result <- runCliCommand p schema cmd
commandLineApp' p schema = runPromptIO (contractCliApp p schema)

contractCliApp :: forall w s s2.
( AllUniqueLabels (Input s)
, Forall (Input s) FromJSON
, Forall (Input s) ToJSON
, Forall (Output s) ToJSON
, EndpointToSchema (s .\\ s2)
, ToJSON w
, Monoid w
)
=> Proxy s2
-> Contract w s Text ()
-> [String]
-> Prompt BS.ByteString
contractCliApp p schema args = do
cmd <- handleParseResult $ execParserPure (prefs $ disambiguate <> showHelpOnEmpty <> showHelpOnError) (info (helper <*> commandLineParser) idm) args
runCliCommand p schema cmd

handleCliEffIO ::
forall effs.
LastMember IO effs
=> CliEff
~> Eff effs
handleCliEffIO = \case
GetContents -> sendM BS.getContents
HandleParseResult a -> liftIO (Options.Applicative.handleParseResult a)

handleCliEffPure ::
forall effs.
Member (Error [BS.ByteString]) effs
=> BS.ByteString
-> CliEff
~> Eff effs
handleCliEffPure input = \case
GetContents -> return input
HandleParseResult a -> case Options.Applicative.getParseResult a of
Nothing -> throwError @[BS.ByteString] [BS8.pack $ show a]
Just a' -> pure a'

runPromptIO :: ([String] -> Prompt BS.ByteString) -> IO ()
runPromptIO p = do
args <- getArgs
result <- runM $ runError $ interpret handleCliEffIO $ Modify.raiseEnd $ p args
case result of
Left err -> do
BS8.hPut System.IO.stderr "Error "
BS8.hPut System.IO.stderr (BSL.toStrict $ JSON.encodePretty err)
Left errs -> do
traverse_ (BS8.hPut System.IO.stderr) errs
exitWith $ ExitFailure 1
Right response -> do
BS8.putStrLn response
exitSuccess

runPromptPure :: Prompt a -> BS.ByteString -> Either [BS.ByteString] a
runPromptPure p input = run $ runError $ interpret (handleCliEffPure input) p
9 changes: 5 additions & 4 deletions plutus-pab/src/Plutus/PAB/Effects/Contract/ContractExe.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,7 +40,8 @@ import GHC.Generics (Generic)
import Plutus.Contract.Resumable (Response)
import Plutus.Contract.State (ContractRequest (..))
import Plutus.PAB.Effects.Contract (ContractEffect (..), PABContract (..))
import Plutus.PAB.Events.Contract (ContractPABRequest)
import Plutus.PAB.Events.Contract (ContractHandlerRequest (..), ContractHandlersResponse (..),
ContractPABRequest)
import qualified Plutus.PAB.Events.Contract as Events.Contract
import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse)
import qualified Plutus.PAB.Events.ContractInstanceState as ContractInstanceState
Expand Down Expand Up @@ -81,13 +82,13 @@ handleContractEffectContractExe =
\case
InitialState (ContractExe contractPath) -> do
logDebug $ InitContractMsg contractPath
liftProcess $ readProcessWithExitCode contractPath ["init"] ""
fmap (fmap unContractHandlerRequest) <$> liftProcess $ readProcessWithExitCode contractPath ["init"] ""
UpdateContract (ContractExe contractPath) (oldState :: PartiallyDecodedResponse ContractPABRequest) (input :: Response Events.Contract.ContractResponse) -> do
let req :: ContractRequest Value
req = ContractRequest{oldState = ContractInstanceState.newState oldState, event = toJSON <$> input}
req = ContractRequest{oldState = ContractInstanceState.newState oldState, event = toJSON . ContractHandlersResponse <$> input}
pl = BSL8.unpack (JSON.encodePretty req)
logDebug $ UpdateContractMsg contractPath req
liftProcess $ readProcessWithExitCode contractPath ["update"] pl
fmap (fmap unContractHandlerRequest) <$> liftProcess $ readProcessWithExitCode contractPath ["update"] pl
ExportSchema (ContractExe contractPath) -> do
logDebug $ ExportSignatureMsg contractPath
liftProcess $
Expand Down
46 changes: 29 additions & 17 deletions plutus-pab/test/Plutus/PAB/Events/ContractSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,25 +7,32 @@ module Plutus.PAB.Events.ContractSpec
( tests
) where

import Control.Monad (void)
import Control.Monad.Except (ExceptT (ExceptT), runExceptT)
import Control.Monad.Trans.Except (except)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Encode.Pretty as JSON
import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSL8
import Data.Proxy (Proxy (Proxy))
import qualified Data.Text as T
import GHC.TypeLits (symbolVal)
import Plutus.Contract (BlockchainActions)
import Plutus.Contract.Effects.ExposeEndpoint (ActiveEndpoint (..),
EndpointDescription (EndpointDescription))
import Plutus.Contract.Resumable (Response (..))
import qualified Plutus.Contract.Schema as Schema
import Plutus.Contract.State (ContractRequest (..))
import Plutus.Contracts.GameStateMachine (GameStateMachineSchema, contract)
import Plutus.PAB.Arbitrary ()
import Plutus.PAB.ContractCLI (Command (Initialise), runCliCommand)
import Plutus.PAB.Events.Contract (ContractHandlerRequest, ContractHandlersResponse,
ContractPABRequest)
import Plutus.PAB.ContractCLI (Command (Initialise, Update), runCliCommand, runPromptPure)
import Plutus.PAB.Events.Contract (ContractHandlerRequest, ContractHandlersResponse (..),
ContractPABRequest, ContractResponse (AwaitSlotResponse))
import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse)
import qualified Plutus.PAB.Events.ContractInstanceState as ContractInstanceState
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase)

Expand All @@ -46,20 +53,25 @@ jsonTests =
}
response :: Either String ContractHandlerRequest
response = JSON.eitherDecode $ JSON.encode handlers
in assertRight response
in void (assertRight response)
, testCase "Decode contract initialisation" $ do
v <-
runExceptT $ do
initialisationResponse <-
ExceptT $
first BS.unpack <$> runCliCommand (Proxy @BlockchainActions) (first (T.pack . show) contract) Initialise
result <-
except $ JSON.eitherDecode $ BSL.fromStrict initialisationResponse
pure
(result :: PartiallyDecodedResponse ContractHandlerRequest)
assertRight v
void (assertRight initialResponse)

, testCase "Send a response to the contract" $ do
oldState <- assertRight initialResponse
let req :: ContractRequest JSON.Value
req = ContractRequest{oldState = ContractInstanceState.newState oldState, event = Response{rspRqID = 0, rspItID = 0, rspResponse = JSON.toJSON (ContractHandlersResponse $ AwaitSlotResponse 1)}}
input = BSL.toStrict (JSON.encodePretty req)
v = first (foldMap BS8.unpack) $ runPromptPure (runCliCommand (Proxy @BlockchainActions) (first (T.pack . show) contract) Update) input
result = v >>= JSON.eitherDecode @(PartiallyDecodedResponse ContractHandlerRequest) . BSL.fromStrict

void (assertRight result)
]

assertRight :: Either String a -> IO ()
assertRight (Left err) = assertFailure err
assertRight (Right _) = pure ()
assertRight :: Either String a -> IO a
assertRight = either assertFailure pure

initialResponse :: Either String (PartiallyDecodedResponse ContractHandlerRequest)
initialResponse =
let v = first (foldMap BS8.unpack) $ runPromptPure (runCliCommand (Proxy @BlockchainActions) (first (T.pack . show) contract) Initialise) mempty
in v >>= JSON.eitherDecode @(PartiallyDecodedResponse ContractHandlerRequest) . BSL.fromStrict

0 comments on commit a525e55

Please sign in to comment.