Skip to content

Commit df858d7

Browse files
epostepost
authored
360/handle calls with stbx protocol (#362)
* [#360] [stbx-service-rest, stbx-tx-store] make Store handlers more general * [#360] [stbx-protocol, stbx-service-rest, stbx-store] rename stbx-tx-store to stbx-store * [#360] [stbx-protocol] interpret StoreActions as Store Actions * [#360] [stbx-protocol] eval MultipleStoresActions in terms of evaluations of the single stores * [#360] [stbx-protocol] eval directly StoreActions * [#360] [stbx-protocol, stbx-service-rest] integrate protocol with service * [#360] [studio-common] add type annotation * [#360] [stbx-service-rest] return error message if POSTing fails * [#360] [stbx-protocol] add Show instance to ProcessError * [#360] [stbx-service-rest] setup transaction dictionary with uber root * [#360] [stbx-core] patch root tx decoder for missing 'previous' field * [#360] [stbx-core] fix imports * [#360] [stbx-core] use .!= to provide default value * [#360] [stbx-service-rest] use hash instead of hexStr as key * [#360] [stbx-rest-integration] clean imports * [#360] [stbx-protocol] rename Hadler.purs to Handler.purs * [#360] [stbx-protocol] use (/\) instead of Tuple * [#360] [stbx-protocol] rename and reformat Embeddable instance signatures * [#360] [stbx-protocol] Chiseling away on some types * [#360] [stbx-protocol] Syntax * [#360] [stbx-protocol] prefix Actions with 'Store.' * [#360] [stbx-service] make AppState tupling and lensing more explicit * [#360] [stbx-proto] fix param names * [#360] [stbx-store] fix typo * [#360] [stbx-service] syntax * [#360] [stbx-protocol, stbx-service-rest] updates after review Co-authored-by: Erik Post <[email protected]>
1 parent 7fc0604 commit df858d7

File tree

21 files changed

+264
-133
lines changed

21 files changed

+264
-133
lines changed

Diff for: ‎packages.dhall

+2-1
Original file line numberDiff line numberDiff line change
@@ -8,8 +8,9 @@ let additions =
88
, stbx-client-rest = ./stbx-client-rest/spago.dhall as Location
99
, stbx-example-data = ./stbx-example-data/spago.dhall as Location
1010
, stbx-lang = ./stbx-lang/spago.dhall as Location
11+
, stbx-protocol = ./stbx-protocol/spago.dhall as Location
1112
, stbx-service-rest = ./stbx-service-rest/spago.dhall as Location
12-
, stbx-tx-store = ./stbx-tx-store/spago.dhall as Location
13+
, stbx-store = ./stbx-store/spago.dhall as Location
1314
, studio = ./studio/spago.dhall as Location
1415
, studio-common = ./studio-common/spago.dhall as Location
1516
, vec = ./vec/spago.dhall as Location

Diff for: ‎stbx-core/src/Statebox/Core/Transaction/Codec.purs

+11-5
Original file line numberDiff line numberDiff line change
@@ -5,19 +5,19 @@ import Control.Alt ((<|>))
55
import Data.Argonaut.Core (Json, jsonEmptyObject)
66
import Data.Argonaut.Encode.Combinators ((:=), (~>))
77
import Data.Argonaut.Encode.Class (encodeJson)
8-
import Data.Argonaut.Decode (decodeJson, (.:), (.:?))
8+
import Data.Argonaut.Decode (decodeJson, (.:), (.:?), (.!=))
99
import Data.Argonaut.Decode.Class (decodeJArray)
10-
import Data.Lens (over)
11-
import Data.Profunctor.Choice (left)
1210
import Data.Either (Either(..))
1311
import Data.Either.Nested (type (\/))
12+
import Data.Lens (over)
1413
import Data.Maybe (maybe)
1514
import Data.NonEmpty (singleton)
15+
import Data.Profunctor.Choice (left)
1616
import Data.Traversable (traverse)
1717
import Foreign.Object (Object, lookup)
1818

1919
import Statebox.Core.Lenses (_wiring')
20-
import Statebox.Core.Transaction (Tx, InitialTx, WiringTx, FiringTx, TxSum(..), mapTx, evalTxSum)
20+
import Statebox.Core.Transaction (Tx, InitialTx, WiringTx, FiringTx, TxSum(..), mapTx, evalTxSum, uberRootHash)
2121
import Statebox.Core.Types (Net, Wiring, Firing)
2222
import Statebox.Core.Wiring as Wiring
2323
import Statebox.Core.Wiring (WiringRaw)
@@ -46,8 +46,14 @@ decodeTxFiringTx = decodeTxWith decodeFiringTx <=< decodeJson
4646

4747
--------------------------------------------------------------------------------
4848

49+
-- | A handcrafted decoder that ensures a field "previous": "z" is present in the result, even if "previous" is missing
50+
-- | from the JSON input. The "z" value is the `uberRootHash`.
4951
decodeInitialTx :: Json -> String \/ InitialTx
50-
decodeInitialTx = decodeJson
52+
decodeInitialTx = decodeJson >=> \x -> do
53+
root <- x .: "root"
54+
-- if we encounter JSON without a "previous" field in the root's "decoded" payload, insert it artificially
55+
previous <- x .:? "previous" .!= uberRootHash
56+
pure { root, previous }
5157

5258
decodeWiringTx :: Json -> String \/ WiringTx
5359
decodeWiringTx = decodeJson >=> \x -> do

Diff for: ‎stbx-core/test/Statebox/Core.purs

+4-4
Original file line numberDiff line numberDiff line change
@@ -2,22 +2,22 @@ module Test.Statebox.Core where
22

33
import Prelude
44
import Data.Either (Either(..))
5-
import Effect.Class (liftEffect)
6-
import Effect.Console (log)
75

86
import Statebox.Core as Stbx
97

108
import Test.Spec (Spec, describe, it)
119
import Test.Spec.Assertions (shouldEqual)
1210

13-
import Debug.Trace (spy)
14-
1511
-- | We define this FFI value in order to load the FFI module, which imports (requires) stbx.js.
1612
foreign import requireStbxJs_HACK :: String
1713

1814
suite :: Spec Unit
1915
suite = do
2016
describe "Stbx" do
17+
it "should decode a root transaction from hex correctly" do
18+
let eitherDecodedString = Stbx.decodeToJsonString "0a0022200a1e47756172616e746565642d456e7472616e63652d546f6b656e2e74657374"
19+
eitherDecodedString `shouldEqual` Right "{\"root\":{\"message\":\"47756172616e746565642d456e7472616e63652d546f6b656e2e74657374\"}}"
20+
2121
it "should decode a wiring transaction from hex correctly" do
2222
let eitherDecodedString = Stbx.decodeToJsonString "0a04deadbeef1a2c0a150a01611000100110001001100010001a01781a0179120f0a017a10011801180222017322017418001800"
2323
eitherDecodedString `shouldEqual` Right """{"wiring":{"nets":[{"name":"a","partition":[0,1,0,1,0,0],"names":["x","y"]}],"diagrams":[{"name":"z","width":1,"pixels":[1,2],"names":["s","t"]}],"labels":[0,0]},"previous":"z6h8cQN"}"""

Diff for: ‎stbx-core/test/Statebox/Core/Transaction/Codec.purs

+4-8
Original file line numberDiff line numberDiff line change
@@ -2,21 +2,17 @@ module Test.Statebox.Core.Transaction.Codec where
22

33
import Prelude
44

5-
import Data.Argonaut.Core (Json)
65
import Data.Argonaut.Decode (decodeJson)
76
import Data.Argonaut.Parser (jsonParser)
87
import Data.Either.Nested (type (\/))
9-
import Data.Either (Either(..), either)
8+
import Data.Either (either)
109
import Data.NonEmpty (singleton) as NonEmpty
1110
import Debug.Trace (spy)
12-
import Test.Spec (Spec, pending, describe, it)
11+
import Test.Spec (Spec, describe, it)
1312
import Test.Spec.Assertions (shouldEqual, fail)
14-
import Test.Spec.Reporter.Console (consoleReporter)
15-
import Test.Spec.Runner (run)
1613

17-
import Statebox.Core.Transaction (TxSum(..), Tx, FiringTx, evalTxSum)
18-
import Statebox.Core.Types (Firing)
19-
import Statebox.Core.Transaction.Codec (decodeTxTxSum, decodeFiringTx, decodeTxFiringTx)
14+
import Statebox.Core.Transaction (FiringTx, Tx, TxSum, evalTxSum)
15+
import Statebox.Core.Transaction.Codec (decodeTxTxSum, decodeFiringTx)
2016

2117
suite :: Spec Unit
2218
suite = do

Diff for: ‎stbx-protocol/spago.dhall

+1-1
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
, name =
44
"stbx-protocol"
55
, dependencies =
6-
[ "stbx-core", "studio-common", "stbx-tx-store" ]
6+
[ "stbx-core", "studio-common", "stbx-store" ]
77
, packages =
88
./../packages.dhall
99
}

Diff for: ‎stbx-protocol/src/Statebox/Protocol.purs

+25-9
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ import Data.Maybe (Maybe(..), maybe)
88

99
import Statebox.Core.Lenses (_firingExecution)
1010
import Statebox.Core.Transaction (FiringTx, HashStr, HashTx, InitialTx, TxId, TxSum(..), WiringTx, evalTxSum, isInitialTx, isUberRootHash)
11+
import Statebox.Protocol.ExecutionState (ExecutionState(..))
1112
import Statebox.Protocol.Fire (fire)
1213
import Statebox.Protocol.Store (getTransaction, putTransaction, getExecutionState, updateExecutionState) as Store
1314
import Statebox.Protocol.Store (StoreActions)
@@ -51,6 +52,21 @@ data ProcessError
5152
-- | The fired transition should be enabled.
5253
| FiringNormalTransitionShouldBeEnabled TxId ExecutionId
5354

55+
instance showProcessError :: Show ProcessError where
56+
show = case _ of
57+
NoUberRoot -> "NoUberRoot"
58+
InitialPreviousShouldBeUberRoot txId -> "InitialPreviousShouldBeUberRoot " <> show txId
59+
WiringPreviousShouldBeInitial txId -> "WiringPreviousShouldBeInitial " <> show txId
60+
FiringInitialShouldBeCreatedOnlyOnce txId -> "FiringInitialShouldBeCreatedOnlyOnce " <> show txId
61+
FiringInitialShouldHavePrevious txId -> "FiringInitialShouldHavePrevious " <> show txId
62+
FiringInitialPreviousShouldBeWiring txId -> "FiringInitialPreviousShouldBeWiring " <> show txId
63+
FiringInitialTransitionShouldBeInitial txId -> "FiringInitialTransitionShouldBeInitial" <> show txId
64+
FiringNormalShouldHaveExistingExecution txId executionId -> "FiringNormalShouldHaveExistingExecution " <> show txId <> " " <> show executionId
65+
FiringNormalPreviousShouldMatchCurrentState txId executionId -> "FiringNormalPreviousShouldMatchCurrentState " <> show txId <> " " <> show executionId
66+
FiringNormalExecutionShouldPointToExistingWiring txId executionId -> "FiringNormalExecutionShouldPointToExistingWiring " <> show txId <> " " <> show executionId
67+
FiringNormalExecutionWiringShouldBeAWiring txId executionId -> "FiringNormalExecutionWiringShouldBeAWiring " <> show txId <> " " <> show executionId
68+
FiringNormalTransitionShouldBeEnabled txId executionId -> "FiringNormalTransitionShouldBeEnabled " <> show txId <> " " <> show executionId
69+
5470
processTxSum :: HashTx -> StoreActions (ProcessError \/ Unit)
5571
processTxSum hashTx = case hashTx.tx of
5672
UberRootTxInj -> pure $ Left NoUberRoot
@@ -114,10 +130,10 @@ processInitialFiringTx hash firingTx = do
114130
(const $ pure $ Left $ FiringInitialTransitionShouldBeInitial hash)
115131
(\newMarking -> map Right $ do
116132
Store.putTransaction hash $ FiringTxInj firingTx
117-
Store.updateExecutionState hash $ { lastFiring: hash
118-
, wiring: firingTx.previous
119-
, marking: newMarking
120-
})
133+
Store.updateExecutionState hash $ ExecutionState { lastFiring: hash
134+
, wiring: firingTx.previous
135+
, marking: newMarking
136+
})
121137
(fire wiringTx.wiring mempty firingTx.firing)
122138
)
123139
(const $ pure $ Left $ FiringInitialPreviousShouldBeWiring hash)
@@ -130,7 +146,7 @@ processNormalFiringTx hash firingTx executionHash = do
130146
-- execution does not exist
131147
Nothing -> pure $ Left $ FiringNormalShouldHaveExistingExecution hash executionHash
132148
-- execution does exist
133-
Just execution -> do
149+
Just (ExecutionState execution) -> do
134150
-- check if the previous transaction corresponds to the current state of the execution
135151
if firingTx.previous == execution.lastFiring
136152
then do
@@ -145,10 +161,10 @@ processNormalFiringTx hash firingTx executionHash = do
145161
(const $ pure $ Left $ FiringNormalTransitionShouldBeEnabled hash executionHash)
146162
(\newMarking -> map Right $ do
147163
Store.putTransaction hash $ FiringTxInj firingTx
148-
Store.updateExecutionState executionHash { lastFiring: hash
149-
, wiring: execution.wiring
150-
, marking: newMarking
151-
})
164+
Store.updateExecutionState executionHash $ ExecutionState { lastFiring: hash
165+
, wiring: execution.wiring
166+
, marking: newMarking
167+
})
152168
(fire wiringTx.wiring execution.marking firingTx.firing))
153169
(const $ pure $ Left $ FiringNormalExecutionWiringShouldBeAWiring hash executionHash)
154170
transaction

Diff for: ‎stbx-protocol/src/Statebox/Protocol/ExecutionState.purs

+1-1
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ import Statebox.Core.Transaction (TxId)
44
import Statebox.Core.Types (PID)
55
import Data.Petrinet.Representation.Marking (MarkingF)
66

7-
type ExecutionState =
7+
newtype ExecutionState = ExecutionState
88
{ lastFiring :: TxId
99
, wiring :: TxId
1010
, marking :: Marking

Diff for: ‎stbx-protocol/src/Statebox/Protocol/Store/TransactionExecutionStateHandler.purs

+69
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,69 @@
1+
module Statebox.Protocol.Store.TransactionExecutionStateHandler where
2+
3+
import Prelude
4+
import Control.Monad.Free (Free, hoistFree, runFreeM)
5+
import Control.Monad.Rec.Class (class MonadRec)
6+
import Control.Monad.State.Trans (StateT(..))
7+
import Data.Map (Map)
8+
import Data.Tuple.Nested (type (/\), (/\))
9+
10+
import Statebox.Core.Transaction (TxSum, TxId)
11+
import Statebox.Protocol.ExecutionState (ExecutionState)
12+
import Statebox.Protocol.Store (StoreActions, StoreActionF(..))
13+
import Statebox.Store (Actions, get, put) as Store
14+
15+
data MultipleStoresActionF a
16+
= Transaction (Store.Actions TxId TxSum a)
17+
| ExecutionState (Store.Actions TxId ExecutionState a)
18+
19+
derive instance multipleStoresActionFunctor :: Functor MultipleStoresActionF
20+
21+
type MultipleStoresActions = Free MultipleStoresActionF
22+
23+
hoistToMultipleStores :: ∀ a. StoreActions a -> MultipleStoresActions a
24+
hoistToMultipleStores = hoistFree (case _ of
25+
GetTransaction key next -> Transaction (next <$> Store.get key)
26+
PutTransaction key value next -> Transaction (next <$ Store.put key value)
27+
GetExecutionState key next -> ExecutionState (next <$> Store.get key)
28+
UpdateExecutionState key value next -> ExecutionState (next <$ Store.put key value))
29+
30+
-- | This typeclass describes a natural transformation between `ma` and `m` (if they are functors).
31+
-- | It allows us to transform naturally instances of `ma` to instances of `m`
32+
class Embeddable ma m where
33+
embed :: ∀ a. ma a -> m a
34+
35+
instance embeddableTxSum
36+
:: Functor m
37+
=> Embeddable (StateT (Map String TxSum ) m)
38+
(StateT (Map String TxSum /\ e) m)
39+
where
40+
embed (StateT f) = StateT (\(transactionDictionary /\ e) -> (((\m -> m /\ e) <$> _) <$> _) $ f transactionDictionary)
41+
42+
instance embeddableExecutionState
43+
:: Functor m
44+
=> Embeddable (StateT ( Map String ExecutionState) m)
45+
(StateT (t /\ Map String ExecutionState) m)
46+
where
47+
embed (StateT f) = StateT (\(t /\ executionStateDictionary) -> (((\m -> t /\ m) <$> _) <$> _) $ f executionStateDictionary)
48+
49+
evalMultipleStoresActions
50+
:: ∀ m mb mc a
51+
. MonadRec m
52+
=> Embeddable mb m
53+
=> Embeddable mc m
54+
=> (∀ b. Store.Actions TxId TxSum b -> mb b)
55+
-> (∀ c. Store.Actions TxId ExecutionState c -> mc c)
56+
-> MultipleStoresActions a -> m a
57+
evalMultipleStoresActions evalTransactions evalExecutionStates = runFreeM case _ of
58+
Transaction transactionActions -> embed $ evalTransactions transactionActions
59+
ExecutionState executionStateActions -> embed $ evalExecutionStates executionStateActions
60+
61+
eval
62+
:: ∀ m mb mc a
63+
. MonadRec m
64+
=> Embeddable mb m
65+
=> Embeddable mc m
66+
=> (∀ b. Store.Actions TxId TxSum b -> mb b)
67+
-> (∀ c. Store.Actions TxId ExecutionState c -> mc c)
68+
-> StoreActions a -> m a
69+
eval evalTransactions evalExecutionStates = hoistToMultipleStores >>> evalMultipleStoresActions evalTransactions evalExecutionStates

Diff for: ‎stbx-rest-integration/test/Main.purs

+3-4
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ import Debug.Trace (spy)
88
import Effect.Aff (Fiber, launchAff)
99
import Effect (Effect)
1010
import Effect.Exception (Error)
11-
import Test.Spec (Spec, describe, it, pending)
11+
import Test.Spec (Spec, describe, it)
1212
import Test.Spec.Assertions (fail)
1313
import Test.Spec.Runner (runSpec)
1414
import Test.Spec.Reporter.Console (consoleReporter)
@@ -18,7 +18,7 @@ import Statebox.Client as Stbx
1818
import Statebox.Client (evalTransactionResponse, evalPostTransaction)
1919
import Statebox.Service.Error (TxError(..))
2020

21-
import Test.Common
21+
import Test.Common (succeed)
2222

2323
endpointUrl :: URL
2424
endpointUrl = "http://127.0.0.1:8080"
@@ -70,8 +70,7 @@ postExampleTransactionsSpec =
7070
getExampleTransactionsSpec :: Spec Unit
7171
getExampleTransactionsSpec =
7272
describe "Statebox transaction API HTTP service" do
73-
pending "TODO: GETting root transaction fails"
74-
-- requestTransactionSpec "root" "zFsGM27VMNWZne1SSkWnDQTzr6TdjmsKpbxGkJKKaEC8e"
73+
requestTransactionSpec "root" "zFsGM27VMNWZne1SSkWnDQTzr6TdjmsKpbxGkJKKaEC8e"
7574
requestTransactionSpec "wiring" "zFsGM27o59f9Lu8bWjNHBG7Wbq5iftQA6uDt14zRdjCrH"
7675
requestTransactionSpec "firing 0 (execution)" "zFsGM26E6xAuYMXox2zMGUChk3HmbEAMGXBiWG3UL7KF5"
7776
requestTransactionSpec "firing 1" "zFsGM28DqZKjjGbfCEsjsXTj8xJAqWaBXpDSc1CqR6ihi"

Diff for: ‎stbx-service-rest/spago.dhall

+2-1
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,8 @@
99
, "express"
1010
, "psci-support"
1111
, "stbx-core"
12-
, "stbx-tx-store"
12+
, "stbx-protocol"
13+
, "stbx-store"
1314
]
1415
, packages =
1516
./../packages.dhall

Diff for: ‎stbx-service-rest/src/Statebox/Service/Error.purs

+18
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import Foreign.Object (Object)
1616
import Statebox.Core (DecodeError(..)) as Stbx
1717
import Statebox.Core.Types (HexStr)
1818
import Statebox.Core.Transaction (HashStr)
19+
import Statebox.Protocol (ProcessError(..))
1920
import Statebox.Service.Status (Status(..), statusCode)
2021

2122
-- | Based on the `StateboxException`s thrown in https://github.com/statebox/cloud/blob/73158c3a779cbc8a6348aac60e2d0b21e907b2c1/services/tx/process-tx.js.
@@ -163,6 +164,23 @@ decodeTxError json
163164
instance decodeJsonTxError :: DecodeJson TxError where
164165
decodeJson = decodeTxError
165166

167+
--------------------------------------------------------------------------------
168+
169+
processErrorToTxError :: ProcessError -> TxError
170+
processErrorToTxError = case _ of
171+
NoUberRoot -> TxNoTxField -- TODO: wrong, not the correct error message!
172+
InitialPreviousShouldBeUberRoot txId -> RootNonexistPrev {previous: txId}
173+
WiringPreviousShouldBeInitial txId -> TxNoTxField -- TODO: wrong, not the correct error message!
174+
FiringInitialShouldBeCreatedOnlyOnce txId -> InitExecExists
175+
FiringInitialShouldHavePrevious txId -> InitNonexistPrev {previous: txId}
176+
FiringInitialPreviousShouldBeWiring txId -> InitNonexistPrev {previous: txId} -- TODO: wrong, not the correct error message!
177+
FiringInitialTransitionShouldBeInitial txId -> InitNonexistPrev {previous: txId} -- TODO: wrong, not the correct error message!
178+
FiringNormalShouldHaveExistingExecution txId executionId -> InvalidState -- TODO: wrong, not the correct error message!
179+
FiringNormalPreviousShouldMatchCurrentState txId executionId -> InvalidState
180+
FiringNormalExecutionShouldPointToExistingWiring txId executionId -> InvalidState -- TODO: wrong, not the correct error message!
181+
FiringNormalExecutionWiringShouldBeAWiring txId executionId -> InvalidState -- TODO: wrong, not the correct error message!
182+
FiringNormalTransitionShouldBeEnabled txId executionId -> TxNotEnabled
183+
166184

167185
--------------------------------------------------------------------------------
168186

0 commit comments

Comments
 (0)