statebox · epost · Mar 5, 2020 · Feb 21, 2020 · Feb 21, 2020 · Feb 21, 2020
diff --git a/packages.dhall b/packages.dhall
@@ -8,8 +8,9 @@ let additions =
       , stbx-client-rest = ./stbx-client-rest/spago.dhall as Location
       , stbx-example-data = ./stbx-example-data/spago.dhall as Location
       , stbx-lang = ./stbx-lang/spago.dhall as Location
+      , stbx-protocol = ./stbx-protocol/spago.dhall as Location
       , stbx-service-rest = ./stbx-service-rest/spago.dhall as Location
-      , stbx-tx-store = ./stbx-tx-store/spago.dhall as Location
+      , stbx-store = ./stbx-store/spago.dhall as Location
       , studio = ./studio/spago.dhall as Location
       , studio-common = ./studio-common/spago.dhall as Location
       , vec = ./vec/spago.dhall as Location

diff --git a/stbx-core/src/Statebox/Core/Transaction/Codec.purs b/stbx-core/src/Statebox/Core/Transaction/Codec.purs
@@ -5,19 +5,19 @@ import Control.Alt ((<|>))
 import Data.Argonaut.Core (Json, jsonEmptyObject)
 import Data.Argonaut.Encode.Combinators ((:=), (~>))
 import Data.Argonaut.Encode.Class (encodeJson)
-import Data.Argonaut.Decode (decodeJson, (.:), (.:?))
+import Data.Argonaut.Decode (decodeJson, (.:), (.:?), (.!=))
 import Data.Argonaut.Decode.Class (decodeJArray)
-import Data.Lens (over)
-import Data.Profunctor.Choice (left)
 import Data.Either (Either(..))
 import Data.Either.Nested (type (\/))
+import Data.Lens (over)
 import Data.Maybe (maybe)
 import Data.NonEmpty (singleton)
+import Data.Profunctor.Choice (left)
 import Data.Traversable (traverse)
 import Foreign.Object (Object, lookup)
 
 import Statebox.Core.Lenses (_wiring')
-import Statebox.Core.Transaction (Tx, InitialTx, WiringTx, FiringTx, TxSum(..), mapTx, evalTxSum)
+import Statebox.Core.Transaction (Tx, InitialTx, WiringTx, FiringTx, TxSum(..), mapTx, evalTxSum, uberRootHash)
 import Statebox.Core.Types (Net, Wiring, Firing)
 import Statebox.Core.Wiring as Wiring
 import Statebox.Core.Wiring (WiringRaw)
@@ -46,8 +46,14 @@ decodeTxFiringTx = decodeTxWith decodeFiringTx <=< decodeJson
 
 --------------------------------------------------------------------------------
 
+-- | A handcrafted decoder that ensures a field "previous": "z" is present in the result, even if "previous" is missing
+-- | from the JSON input. The "z" value is the `uberRootHash`.
 decodeInitialTx :: Json -> String \/ InitialTx
-decodeInitialTx = decodeJson
+decodeInitialTx = decodeJson >=> \x -> do
+  root     <- x .: "root"
+  -- if we encounter JSON without a "previous" field in the root's "decoded" payload, insert it artificially
+  previous <- x .:? "previous" .!=  uberRootHash
+  pure { root, previous }
 
 decodeWiringTx :: Json -> String \/ WiringTx
 decodeWiringTx = decodeJson >=> \x -> do

diff --git a/stbx-core/test/Statebox/Core.purs b/stbx-core/test/Statebox/Core.purs
@@ -2,22 +2,22 @@ module Test.Statebox.Core where
 
 import Prelude
 import Data.Either (Either(..))
-import Effect.Class (liftEffect)
-import Effect.Console (log)
 
 import Statebox.Core as Stbx
 
 import Test.Spec (Spec, describe, it)
 import Test.Spec.Assertions (shouldEqual)
 
-import Debug.Trace (spy)
-
 -- | We define this FFI value in order to load the FFI module, which imports (requires) stbx.js.
 foreign import requireStbxJs_HACK :: String
 
 suite :: Spec Unit
 suite = do
   describe "Stbx" do
+    it "should decode a root transaction from hex correctly" do
+      let eitherDecodedString = Stbx.decodeToJsonString "0a0022200a1e47756172616e746565642d456e7472616e63652d546f6b656e2e74657374"
+      eitherDecodedString `shouldEqual` Right "{\"root\":{\"message\":\"47756172616e746565642d456e7472616e63652d546f6b656e2e74657374\"}}"
+
     it "should decode a wiring transaction from hex correctly" do
       let eitherDecodedString = Stbx.decodeToJsonString "0a04deadbeef1a2c0a150a01611000100110001001100010001a01781a0179120f0a017a10011801180222017322017418001800"
       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 --git a/stbx-core/test/Statebox/Core/Transaction/Codec.purs b/stbx-core/test/Statebox/Core/Transaction/Codec.purs
@@ -2,21 +2,17 @@ module Test.Statebox.Core.Transaction.Codec where
 
 import Prelude
 
-import Data.Argonaut.Core (Json)
 import Data.Argonaut.Decode (decodeJson)
 import Data.Argonaut.Parser (jsonParser)
 import Data.Either.Nested (type (\/))
-import Data.Either (Either(..), either)
+import Data.Either (either)
 import Data.NonEmpty (singleton) as NonEmpty
 import Debug.Trace (spy)
-import Test.Spec (Spec, pending, describe, it)
+import Test.Spec (Spec, describe, it)
 import Test.Spec.Assertions (shouldEqual, fail)
-import Test.Spec.Reporter.Console (consoleReporter)
-import Test.Spec.Runner (run)
 
-import Statebox.Core.Transaction (TxSum(..), Tx, FiringTx, evalTxSum)
-import Statebox.Core.Types (Firing)
-import Statebox.Core.Transaction.Codec (decodeTxTxSum, decodeFiringTx, decodeTxFiringTx)
+import Statebox.Core.Transaction (FiringTx, Tx, TxSum, evalTxSum)
+import Statebox.Core.Transaction.Codec (decodeTxTxSum, decodeFiringTx)
 
 suite :: Spec Unit
 suite = do

diff --git a/stbx-protocol/spago.dhall b/stbx-protocol/spago.dhall
@@ -3,7 +3,7 @@
 , name =
     "stbx-protocol"
 , dependencies =
-    [ "stbx-core", "studio-common", "stbx-tx-store" ]
+    [ "stbx-core", "studio-common", "stbx-store" ]
 , packages =
     ./../packages.dhall
 }
diff --git a/stbx-protocol/src/Statebox/Protocol.purs b/stbx-protocol/src/Statebox/Protocol.purs
@@ -8,6 +8,7 @@ import Data.Maybe (Maybe(..), maybe)
 
 import Statebox.Core.Lenses (_firingExecution)
 import Statebox.Core.Transaction (FiringTx, HashStr, HashTx, InitialTx, TxId, TxSum(..), WiringTx, evalTxSum, isInitialTx, isUberRootHash)
+import Statebox.Protocol.ExecutionState (ExecutionState(..))
 import Statebox.Protocol.Fire (fire)
 import Statebox.Protocol.Store (getTransaction, putTransaction, getExecutionState, updateExecutionState) as Store
 import Statebox.Protocol.Store (StoreActions)
@@ -51,6 +52,21 @@ data ProcessError
   -- | The fired transition should be enabled.
   | FiringNormalTransitionShouldBeEnabled            TxId ExecutionId
 
+instance showProcessError :: Show ProcessError where
+  show = case _ of
+    NoUberRoot                                                        -> "NoUberRoot"
+    InitialPreviousShouldBeUberRoot                  txId             -> "InitialPreviousShouldBeUberRoot "                  <> show txId
+    WiringPreviousShouldBeInitial                    txId             -> "WiringPreviousShouldBeInitial "                    <> show txId
+    FiringInitialShouldBeCreatedOnlyOnce             txId             -> "FiringInitialShouldBeCreatedOnlyOnce "             <> show txId
+    FiringInitialShouldHavePrevious                  txId             -> "FiringInitialShouldHavePrevious "                  <> show txId
+    FiringInitialPreviousShouldBeWiring              txId             -> "FiringInitialPreviousShouldBeWiring "              <> show txId
+    FiringInitialTransitionShouldBeInitial           txId             -> "FiringInitialTransitionShouldBeInitial"            <> show txId
+    FiringNormalShouldHaveExistingExecution          txId executionId -> "FiringNormalShouldHaveExistingExecution "          <> show txId <> " " <> show executionId
+    FiringNormalPreviousShouldMatchCurrentState      txId executionId -> "FiringNormalPreviousShouldMatchCurrentState "      <> show txId <> " " <> show executionId
+    FiringNormalExecutionShouldPointToExistingWiring txId executionId -> "FiringNormalExecutionShouldPointToExistingWiring " <> show txId <> " " <> show executionId
+    FiringNormalExecutionWiringShouldBeAWiring       txId executionId -> "FiringNormalExecutionWiringShouldBeAWiring "       <> show txId <> " " <> show executionId
+    FiringNormalTransitionShouldBeEnabled            txId executionId -> "FiringNormalTransitionShouldBeEnabled "            <> show txId <> " " <> show executionId
+
 processTxSum :: HashTx -> StoreActions (ProcessError \/ Unit)
 processTxSum hashTx = case hashTx.tx of
   UberRootTxInj           -> pure $ Left NoUberRoot
@@ -114,10 +130,10 @@ processInitialFiringTx hash firingTx = do
               (const $ pure $ Left $ FiringInitialTransitionShouldBeInitial hash)
               (\newMarking -> map Right $ do
                 Store.putTransaction hash $ FiringTxInj firingTx
-                Store.updateExecutionState hash $ { lastFiring: hash
-                                                  , wiring: firingTx.previous
-                                                  , marking: newMarking
-                                                  })
+                Store.updateExecutionState hash $ ExecutionState { lastFiring: hash
+                                                                 , wiring: firingTx.previous
+                                                                 , marking: newMarking
+                                                                 })
               (fire wiringTx.wiring mempty firingTx.firing)
             )
             (const $ pure $ Left $ FiringInitialPreviousShouldBeWiring hash)
@@ -130,7 +146,7 @@ processNormalFiringTx hash firingTx executionHash = do
     -- execution does not exist
     Nothing        -> pure $ Left $ FiringNormalShouldHaveExistingExecution hash executionHash
     -- execution does exist
-    Just execution -> do
+    Just (ExecutionState execution) -> do
       -- check if the previous transaction corresponds to the current state of the execution
       if firingTx.previous == execution.lastFiring
       then do
@@ -145,10 +161,10 @@ processNormalFiringTx hash firingTx executionHash = do
                 (const $ pure $ Left $ FiringNormalTransitionShouldBeEnabled hash executionHash)
                 (\newMarking -> map Right $ do
                   Store.putTransaction hash $ FiringTxInj firingTx
-                  Store.updateExecutionState executionHash { lastFiring: hash
-                                                           , wiring: execution.wiring
-                                                           , marking: newMarking
-                                                           })
+                  Store.updateExecutionState executionHash $ ExecutionState { lastFiring: hash
+                                                                            , wiring: execution.wiring
+                                                                            , marking: newMarking
+                                                                            })
                 (fire wiringTx.wiring execution.marking firingTx.firing))
               (const $ pure $ Left $ FiringNormalExecutionWiringShouldBeAWiring hash executionHash)
               transaction

diff --git a/stbx-protocol/src/Statebox/Protocol/ExecutionState.purs b/stbx-protocol/src/Statebox/Protocol/ExecutionState.purs
@@ -4,7 +4,7 @@ import Statebox.Core.Transaction (TxId)
 import Statebox.Core.Types (PID)
 import Data.Petrinet.Representation.Marking (MarkingF)
 
-type ExecutionState =
+newtype ExecutionState = ExecutionState
   { lastFiring :: TxId
   , wiring     :: TxId
   , marking    :: Marking

diff --git a/stbx-protocol/src/Statebox/Protocol/Store/TransactionExecutionStateHandler.purs b/stbx-protocol/src/Statebox/Protocol/Store/TransactionExecutionStateHandler.purs
@@ -0,0 +1,69 @@
+module Statebox.Protocol.Store.TransactionExecutionStateHandler where
+
+import Prelude
+import Control.Monad.Free (Free, hoistFree, runFreeM)
+import Control.Monad.Rec.Class (class MonadRec)
+import Control.Monad.State.Trans (StateT(..))
+import Data.Map (Map)
+import Data.Tuple.Nested (type (/\), (/\))
+
+import Statebox.Core.Transaction (TxSum, TxId)
+import Statebox.Protocol.ExecutionState (ExecutionState)
+import Statebox.Protocol.Store (StoreActions, StoreActionF(..))
+import Statebox.Store (Actions, get, put) as Store
+
+data MultipleStoresActionF a
+  = Transaction    (Store.Actions TxId TxSum          a)
+  | ExecutionState (Store.Actions TxId ExecutionState a)
+
+derive instance multipleStoresActionFunctor :: Functor MultipleStoresActionF
+
+type MultipleStoresActions = Free MultipleStoresActionF
+
+hoistToMultipleStores :: ∀ a. StoreActions a -> MultipleStoresActions a
+hoistToMultipleStores = hoistFree (case _ of
+  GetTransaction       key       next -> Transaction    (next <$> Store.get key)
+  PutTransaction       key value next -> Transaction    (next <$  Store.put key value)
+  GetExecutionState    key       next -> ExecutionState (next <$> Store.get key)
+  UpdateExecutionState key value next -> ExecutionState (next <$  Store.put key value))
+
+-- | This typeclass describes a natural transformation between `ma` and `m` (if they are functors).
+-- | It allows us to transform naturally instances of `ma` to instances of `m`
+class Embeddable ma m where
+  embed :: ∀ a. ma a -> m a
+
+instance embeddableTxSum
+  :: Functor m
+  => Embeddable (StateT (Map String TxSum     ) m)
+                (StateT (Map String TxSum /\ e) m)
+  where
+    embed (StateT f) = StateT (\(transactionDictionary /\ e) -> (((\m -> m /\ e) <$> _) <$> _) $ f transactionDictionary)
+
+instance embeddableExecutionState
+  :: Functor m
+  => Embeddable (StateT (     Map String ExecutionState) m)
+                (StateT (t /\ Map String ExecutionState) m)
+ where
+    embed (StateT f) = StateT (\(t /\ executionStateDictionary) -> (((\m -> t /\ m) <$> _) <$> _) $ f executionStateDictionary)
+
+evalMultipleStoresActions
+  :: ∀ m mb mc a
+   . MonadRec      m
+  => Embeddable mb m
+  => Embeddable mc m
+  => (∀ b. Store.Actions TxId TxSum          b -> mb b)
+  -> (∀ c. Store.Actions TxId ExecutionState c -> mc c)
+  -> MultipleStoresActions                   a -> m  a
+evalMultipleStoresActions evalTransactions evalExecutionStates = runFreeM case _ of
+  Transaction    transactionActions    -> embed $ evalTransactions    transactionActions
+  ExecutionState executionStateActions -> embed $ evalExecutionStates executionStateActions
+
+eval
+  :: ∀ m mb mc a
+   . MonadRec      m
+  => Embeddable mb m
+  => Embeddable mc m
+  => (∀ b. Store.Actions TxId TxSum          b -> mb b)
+  -> (∀ c. Store.Actions TxId ExecutionState c -> mc c)
+  -> StoreActions                            a -> m  a
+eval evalTransactions evalExecutionStates = hoistToMultipleStores >>> evalMultipleStoresActions evalTransactions evalExecutionStates
diff --git a/stbx-rest-integration/test/Main.purs b/stbx-rest-integration/test/Main.purs
@@ -8,7 +8,7 @@ import Debug.Trace (spy)
 import Effect.Aff (Fiber, launchAff)
 import Effect (Effect)
 import Effect.Exception (Error)
-import Test.Spec (Spec, describe, it, pending)
+import Test.Spec (Spec, describe, it)
 import Test.Spec.Assertions (fail)
 import Test.Spec.Runner (runSpec)
 import Test.Spec.Reporter.Console (consoleReporter)
@@ -18,7 +18,7 @@ import Statebox.Client as Stbx
 import Statebox.Client (evalTransactionResponse, evalPostTransaction)
 import Statebox.Service.Error (TxError(..))
 
-import Test.Common
+import Test.Common (succeed)
 
 endpointUrl :: URL
 endpointUrl = "http://127.0.0.1:8080"
@@ -70,8 +70,7 @@ postExampleTransactionsSpec =
 getExampleTransactionsSpec :: Spec Unit
 getExampleTransactionsSpec =
   describe "Statebox transaction API HTTP service" do
-    pending "TODO: GETting root transaction fails"
-    -- requestTransactionSpec "root"                 "zFsGM27VMNWZne1SSkWnDQTzr6TdjmsKpbxGkJKKaEC8e"
+    requestTransactionSpec "root"                 "zFsGM27VMNWZne1SSkWnDQTzr6TdjmsKpbxGkJKKaEC8e"
     requestTransactionSpec "wiring"               "zFsGM27o59f9Lu8bWjNHBG7Wbq5iftQA6uDt14zRdjCrH"
     requestTransactionSpec "firing 0 (execution)" "zFsGM26E6xAuYMXox2zMGUChk3HmbEAMGXBiWG3UL7KF5"
     requestTransactionSpec "firing 1"             "zFsGM28DqZKjjGbfCEsjsXTj8xJAqWaBXpDSc1CqR6ihi"

diff --git a/stbx-service-rest/spago.dhall b/stbx-service-rest/spago.dhall
@@ -9,7 +9,8 @@
     , "express"
     , "psci-support"
     , "stbx-core"
-    , "stbx-tx-store"
+    , "stbx-protocol"
+    , "stbx-store"
     ]
 , packages =
     ./../packages.dhall

diff --git a/stbx-service-rest/src/Statebox/Service/Error.purs b/stbx-service-rest/src/Statebox/Service/Error.purs
@@ -16,6 +16,7 @@ import Foreign.Object (Object)
 import Statebox.Core (DecodeError(..)) as Stbx
 import Statebox.Core.Types (HexStr)
 import Statebox.Core.Transaction (HashStr)
+import Statebox.Protocol (ProcessError(..))
 import Statebox.Service.Status (Status(..), statusCode)
 
 -- | 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
 instance decodeJsonTxError :: DecodeJson TxError where
   decodeJson = decodeTxError
 
+--------------------------------------------------------------------------------
+
+processErrorToTxError :: ProcessError -> TxError
+processErrorToTxError = case _ of
+  NoUberRoot                                                        -> TxNoTxField -- TODO: wrong, not the correct error message!
+  InitialPreviousShouldBeUberRoot                  txId             -> RootNonexistPrev {previous: txId}
+  WiringPreviousShouldBeInitial                    txId             -> TxNoTxField -- TODO: wrong, not the correct error message!
+  FiringInitialShouldBeCreatedOnlyOnce             txId             -> InitExecExists
+  FiringInitialShouldHavePrevious                  txId             -> InitNonexistPrev {previous: txId}
+  FiringInitialPreviousShouldBeWiring              txId             -> InitNonexistPrev {previous: txId} -- TODO: wrong, not the correct error message!
+  FiringInitialTransitionShouldBeInitial           txId             -> InitNonexistPrev {previous: txId} -- TODO: wrong, not the correct error message!
+  FiringNormalShouldHaveExistingExecution          txId executionId -> InvalidState -- TODO: wrong, not the correct error message!
+  FiringNormalPreviousShouldMatchCurrentState      txId executionId -> InvalidState
+  FiringNormalExecutionShouldPointToExistingWiring txId executionId -> InvalidState -- TODO: wrong, not the correct error message!
+  FiringNormalExecutionWiringShouldBeAWiring       txId executionId -> InvalidState -- TODO: wrong, not the correct error message!
+  FiringNormalTransitionShouldBeEnabled            txId executionId -> TxNotEnabled
+
 
 --------------------------------------------------------------------------------