Skip to content

fix local server issue. closes #347 #348

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

fix local server issue. closes #347 #348

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
16 changes: 11 additions & 5 deletions pact-request-api/Pact/Core/Command/Server.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -90,10 +90,12 @@ instance Show ProcessResult where

data ProcessMsg
= StoreMsg RequestKey (CommandResult Hash PactOnChainError) (MVar ProcessResult)
| StoreLocalMsg RequestKey (CommandResult Hash PactOnChainError) (MVar ProcessResult)

instance Show ProcessMsg where
show = \case
StoreMsg rk _ _ -> show rk
StoreLocalMsg rk _ _ -> show rk

-- | Runtime environment for a Pact server.
data ServerRuntime
Expand Down Expand Up @@ -210,13 +212,17 @@ runServer (Config port persistDir logDir _verbose _gl) spv = do

processMsg :: ServerRuntime -> IO ()
processMsg env = do
el <- readChan (_srvChan env)
case el of
sm <- readChan (_srvChan env)
case sm of
StoreMsg rk cmd result -> _histDbRead (_srHistoryDb env) rk >>= \case
Nothing -> _histDbInsert (_srHistoryDb env) rk cmd >>= \case
Right _ -> putMVar result PESuccess
Left e -> putMVar result (PEUnknownException e)
Right _ -> putMVar result PESuccess
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm not usually nitpicking on style, but why is the indent so much more dramatic here?

Left e -> putMVar result (PEUnknownException e)
Just _ -> putMVar result PEExistingRequestKey
StoreLocalMsg rk _cmd result -> _histDbRead (_srHistoryDb env) rk >>= \case
Nothing -> putMVar result PESuccess
Just _ -> putMVar result PEExistingRequestKey



runServer_ :: ServerRuntime -> Port -> Maybe FilePath -> IO ()
Expand Down Expand Up @@ -368,7 +374,7 @@ localHandler env (LocalRequest cmd) = do
res <- liftIO $ try $! do
result <- computeResultAndUpdateState env Local requestKey cmd
storeResult <- newEmptyMVar
writeChan (_srvChan env) (StoreMsg requestKey result storeResult)
writeChan (_srvChan env) (StoreLocalMsg requestKey result storeResult)
(result,) <$> readMVar storeResult
case res of
Right (result, PESuccess) -> pure $ LocalResponse result
Expand Down
11 changes: 11 additions & 0 deletions pact-tests/Pact/Core/Test/PactServerTests.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -136,6 +136,17 @@ tests = withResource
assertStatus 200 res
let (Just (LocalResponse cmdResult)) :: Maybe LocalResponse = A.decodeStrict $ LBS.toStrict reqResp
liftIO $ assertEqual "Result match expected output" (PactResultOk $ PInteger 3) (_crResult cmdResult)

, mkTestCase env "regression #347 (tx validated on local, rejected on send)" $ do
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Could you add a few test cases that local doesn't modify the DB? So a few off the top of my head:

  • Sending a command in local then a command in send (Allowed, should be same command)
  • Sending the same local request twice (Should be allowed)
  • Sending a local request that would manipulate state, and ensure it does not (Try incrementing some module-stored counter and check that the result is the same in two subsequent transactions)
  • Sending a command then sending it again in local (this should not be allowed)

ks <- liftIO generateEd25519KeyPair
cmd <- liftIO $ mkCmd ks "(+ 1 2)"
let lreq = J.encode $ J.build $ LocalRequest cmd
res <- postWithHeaders "/api/v1/local" lreq [(HTTP.hContentType, "application/json")]
assertStatus 200 res

let sreq = J.encode $ J.build $ SubmitBatch $ cmd NE.:| []
resSend <- postWithHeaders "/api/v1/send" sreq [(HTTP.hContentType, "application/json")]
assertStatus 200 resSend
]
integrationTests env = testGroup "integration test (combined send and listen)"
[ mkTestCase env "send and listen request" $ do
Expand Down
Loading