Skip to content

Commit ecfd461

Browse files
epostepost
authored
stbx-service-rest: Serve example transactions. #235 (WIP) (#236)
* stbx-service-rest: Serve (approximate) example data. #235 (WIP) * stbx-service-rest: Serve example data that works in the Studio. #235 (WIP) * stbx-service-rest: Restructure, simplify and clean up JSON tx decoding. #235 (WIP) * stbx-service-rest: Move transaction JSON encoders into 'Codec' module. #235 * Add forgotten 'Transaction.mapTx'. * Encode UberRoot transaction as JSON null for now. * stbx-service-rest: Shuffle JSON codec code around a bit. #235 * Rename LeTx to TransactionDictionaryValue. #235 #237 * stbx-example-data: Move example transactions from stbx-service-rest here. #235 * stbx-service-rest: Harmonise error status responses. #235
1 parent a961a41 commit ecfd461

File tree

10 files changed

+341
-62
lines changed

10 files changed

+341
-62
lines changed

‎stbx-client-rest/src/Statebox/Client.purs

Lines changed: 12 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -13,14 +13,16 @@ import Control.Coroutine.Aff (emit, close, produceAff, Emitter)
1313
import Control.Monad.Rec.Class (Step(Loop, Done), tailRecM)
1414
import Control.Monad.Free.Trans (hoistFreeT)
1515
import Data.Argonaut.Core (Json)
16-
import Data.Either (Either(..), either)
16+
import Data.Either (Either(..))
1717
import Data.Either.Nested (type (\/))
18+
import Data.Profunctor.Choice ((|||), (+++))
1819
import Data.HTTP.Method (Method(GET))
1920
import Effect.Aff.Class (class MonadAff, liftAff)
2021
import Effect.Aff (Aff)
2122

22-
import Statebox.Core.Transaction (HashTx, TxId, TxSum(..), evalTxSum, isUberRootHash, attachTxId)
23-
import Statebox.Core.Transaction.Codec (decodeTxSum, DecodingError)
23+
import Statebox.Core.Transaction (HashTx, Tx, TxId, TxSum(..), evalTxSum, isUberRootHash, attachTxId)
24+
import Statebox.Core.Transaction.Codec (decodeTxTxSum, DecodingError(..))
25+
2426

2527
-- | A convenience function for processing API responses.
2628
evalTransactionResponse
@@ -31,7 +33,7 @@ evalTransactionResponse
3133
-> ResponseFormatError \/ (DecodingError \/ HashTx)
3234
-> a
3335
evalTransactionResponse onResponseFormatError onDecodingError onTx =
34-
(onResponseFormatError `either` (onDecodingError `either` onTx))
36+
onResponseFormatError ||| onDecodingError ||| onTx
3537

3638
--------------------------------------------------------------------------------
3739

@@ -46,7 +48,12 @@ requestTransaction' apiBaseUrl hash =
4648
pure $ Right <<< Right $ UberRootTxInj
4749
else do
4850
res <- requestTransactionJson apiBaseUrl hash
49-
pure $ decodeTxSum <$> res.body
51+
let
52+
tx :: ResponseFormatError \/ DecodingError \/ TxSum
53+
tx = (DecodingError +++ _.decoded) <<< decodeTxTxSum <$> res.body
54+
pure tx
55+
56+
--------------------------------------------------------------------------------
5057

5158
requestTransactionJson :: URL -> TxId -> Aff (Response (ResponseFormatError \/ Json))
5259
requestTransactionJson apiBaseUrl hash =

‎stbx-core/src/Statebox/Core/Transaction.purs

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -12,10 +12,14 @@ type StatusStr = String
1212

1313
type Tx a =
1414
{ status :: StatusStr
15+
, hash :: TxId
1516
, hex :: String
1617
, decoded :: a
1718
}
1819

20+
mapTx :: ∀ a b. (a -> b) -> Tx a -> Tx b
21+
mapTx f x = x { decoded = f x.decoded }
22+
1923
type HashTx = { id :: TxId, tx :: TxSum }
2024

2125
attachTxId :: TxId -> TxSum -> HashTx
@@ -80,11 +84,11 @@ instance showTxSum :: Show TxSum where
8084
(\x -> "(FiringTxInj " <> show x <> ")")
8185

8286
-- | `InitialTx` ('root') transactions are children of the virtual 'über-root', indicated by this hash.
83-
uberRootHash :: HashStr
87+
uberRootHash :: TxId
8488
uberRootHash = "z"
8589

86-
isUberRootHash :: HashStr -> Boolean
90+
isUberRootHash :: TxId -> Boolean
8791
isUberRootHash hash = hash == uberRootHash
8892

89-
getPrevious :: TxSum -> Maybe HashStr
93+
getPrevious :: TxSum -> Maybe TxId
9094
getPrevious = evalTxSum (const Nothing) (Just <<< _.previous) (Just <<< _.previous) (Just <<< _.previous)

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

Lines changed: 65 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -1,52 +1,58 @@
1-
21
module Statebox.Core.Transaction.Codec where
32

43
import Prelude
54
import Control.Alt ((<|>))
6-
import Data.Argonaut.Core (Json)
5+
import Data.Argonaut.Core (Json, jsonEmptyObject, jsonNull)
6+
import Data.Argonaut.Encode.Combinators ((:=), (:=?), (~>), (~>?))
7+
import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
78
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:), (.:?))
8-
import Data.Bifunctor (lmap)
9+
import Data.Profunctor.Choice (left)
910
import Data.Either (Either(..))
1011
import Data.Either.Nested (type (\/))
1112
import Data.Maybe (Maybe(..), maybe)
1213
import Foreign.Object (Object(..), lookup)
1314

14-
import Statebox.Core.Transaction (Tx, InitialTx, WiringTx, FiringTx, TxSum(..), HashStr)
15+
import Statebox.Core.Transaction (Tx, InitialTx, WiringTx, FiringTx, TxSum(..), HashStr, mapTx, evalTxSum)
1516
import Statebox.Core.Types (Firing)
1617

17-
18-
decodeTxSum :: Json -> DecodingError \/ TxSum
19-
decodeTxSum json =
20-
lmap DecodingError (decodeFiring json <|> decodeWiring json <|> decodeInitial json)
18+
decodeTxTxSum :: Json -> String \/ Tx TxSum
19+
decodeTxTxSum json =
20+
decodeFiring json <|> decodeWiring json <|> decodeInitial json
2121
where
22-
decodeInitial :: Json -> String \/ TxSum
23-
decodeInitial json = InitialTxInj <<< _.decoded <$> decodeJson json :: String \/ Tx InitialTx
22+
decodeInitial :: Json -> String \/ Tx TxSum
23+
decodeInitial = map (mapTx InitialTxInj) <<< decodeTxInitialTx
2424

25-
decodeWiring :: Json -> String \/ TxSum
26-
decodeWiring json = WiringTxInj <<< _.decoded <$> decodeJson json :: String \/ Tx WiringTx
25+
decodeWiring :: Json -> String \/ Tx TxSum
26+
decodeWiring = map (mapTx WiringTxInj) <<< decodeTxWiringTx
2727

28-
decodeFiring :: Json -> String \/ TxSum
29-
decodeFiring json = FiringTxInj <<< _.decoded <$> (decodeTxFiringTx =<< decodeJson json)
28+
decodeFiring :: Json -> String \/ Tx TxSum
29+
decodeFiring = map (mapTx FiringTxInj) <<< decodeTxFiringTx
3030

31-
newtype DecodingError = DecodingError String
31+
decodeTxInitialTx :: Json -> String \/ Tx InitialTx
32+
decodeTxInitialTx = decodeJson
3233

33-
instance eqDecodingError :: Eq DecodingError where
34-
eq (DecodingError x) (DecodingError y) = x == y
34+
decodeTxWiringTx :: Json -> String \/ Tx WiringTx
35+
decodeTxWiringTx = decodeJson
3536

36-
instance showDecodingError :: Show DecodingError where
37-
show = case _ of
38-
DecodingError e -> "(DecodingError " <> show e <> ")"
37+
decodeTxFiringTx :: Json -> String \/ Tx FiringTx
38+
decodeTxFiringTx = decodeTxWith decodeFiringTx' <=< decodeJson
39+
where
40+
decodeFiringTx' :: Json -> String \/ FiringTx
41+
decodeFiringTx' = decodeFiringTx <=< decodeJson
3942

4043
--------------------------------------------------------------------------------
4144

42-
decodeTxFiringTx :: Object Json -> String \/ Tx FiringTx
43-
decodeTxFiringTx x = do
44-
status <- x .: "status"
45-
hex <- x .: "hex"
46-
decoded <- getFieldWith decoder x "decoded"
47-
pure { status, hex, decoded }
48-
where
49-
decoder = decodeJson >=> decodeFiringTx
45+
-- | The 'body' of a `Tx` envelope is in the `decoded` field. This field (of type `a`) is
46+
-- | polymorphic, and you can specify a decoder for it.
47+
decodeTxWith :: ∀ a. (Json -> String \/ a) -> Object Json -> String \/ Tx a
48+
decodeTxWith aDecoder x = do
49+
status <- x .: "status"
50+
hash <- x .: "hash"
51+
hex <- x .: "hex"
52+
decoded <- getFieldWith aDecoder x "decoded"
53+
pure { status, hash, hex, decoded }
54+
55+
--------------------------------------------------------------------------------
5056

5157
decodeFiringTx :: Object Json -> String \/ FiringTx
5258
decodeFiringTx x = do
@@ -67,7 +73,7 @@ decodeFiring x = do
6773
--------------------------------------------------------------------------------
6874

6975
-- Adapted `getField` that allows you to override the decoder, See [Argonaut.Decode.Combinators](from https://github.com/purescript-contrib/purescript-argonaut-codecs/blob/9a1c0e09ca523ba7a290461e5346b818059f3d2a/src/Data/Argonaut/Decode/Combinators.purs#L58).
70-
getFieldWith :: forall a. DecodeJson a => (Json -> String \/ a) -> Object Json -> String -> String \/ a
76+
getFieldWith :: ∀ a. (Json -> String \/ a) -> Object Json -> String -> String \/ a
7177
getFieldWith decoder o s =
7278
maybe
7379
(Left $ "Expected field " <> show s)
@@ -77,6 +83,35 @@ getFieldWith decoder o s =
7783
-- Duplicate of https://github.com/purescript-contrib/purescript-argonaut-codecs/blob/9a1c0e09ca523ba7a290461e5346b818059f3d2a/src/Data/Argonaut/Decode/Combinators.purs#L132.
7884
elaborateFailure :: ∀ a. String -> String \/ a -> String \/ a
7985
elaborateFailure s e =
80-
lmap msg e
86+
left msg e
8187
where
8288
msg m = "Failed to decode key '" <> s <> "': " <> m
89+
90+
--------------------------------------------------------------------------------
91+
92+
-- TODO This is no longer used in this module and should probably be moved into Client
93+
newtype DecodingError = DecodingError String
94+
95+
instance eqDecodingError :: Eq DecodingError where
96+
eq (DecodingError x) (DecodingError y) = x == y
97+
98+
instance showDecodingError :: Show DecodingError where
99+
show = case _ of
100+
DecodingError e -> "(DecodingError " <> show e <> ")"
101+
102+
--------------------------------------------------------------------------------
103+
104+
encodeTxSum :: TxSum -> Json
105+
encodeTxSum = evalTxSum
106+
(\_ -> jsonEmptyObject) -- TODO do we want to encode/decode this?
107+
(\i -> encodeJson i)
108+
(\w -> encodeJson w)
109+
(\f -> encodeJson f)
110+
111+
encodeTxWith :: forall a. (a -> Json) -> Tx a -> Json
112+
encodeTxWith encodeBody t =
113+
"status" := t.status
114+
~> "hash" := t.hash
115+
~> "hex" := t.hex
116+
~> "decoded" := encodeBody t.decoded
117+
~> jsonEmptyObject

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,7 @@ suite = do
5353
"""}"""
5454

5555
txFiringTxWithMessageField :: _ \/ (DecodingError \/ TxSum)
56-
txFiringTxWithMessageField = spy "txFiringTxWithMessageFieldStr" $ map decodeTxSum $ decodeJson =<< jsonParser txFiringTxWithMessageFieldStr
56+
txFiringTxWithMessageField = spy "txFiringTxWithMessageFieldStr" $ map decodeTxSum $ decodeJson =<< jsonParser txFiringTxWithMessageFieldStr
5757

5858
txFiringTxWithMessageField # either fail (either (fail <<< show) (evalTxSum
5959
(\ur -> fail "UberRootTxInj")

‎stbx-example-data/src/Transactions.purs

Lines changed: 152 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,157 @@
1-
module Transactions where
1+
module Statebox.Example.Transactions where
22

33
import Statebox.Core.Transaction (TxId)
44

55
transactionByJelle20190528 :: TxId
66
transactionByJelle20190528 = "zFsGM27HNS66qmGp1Y1STK48FUA1F12VHLRB51RGWNYWV"
7+
8+
transactionsUpTo_zFsGM27HNS66qmGp1Y1STK48FUA1F12VHLRB51RGWNYWV_JsonStr :: String
9+
transactionsUpTo_zFsGM27HNS66qmGp1Y1STK48FUA1F12VHLRB51RGWNYWV_JsonStr = """
10+
[
11+
{
12+
"status": "ok",
13+
"hex": "0a20dce4021c15fda2dfd9ec2ef4413b9e5a4ac5cbd8def33c0ca2c071f75a71464b122b0a20dce4021c1447c0b50a5ce982dd4e78650ca3cc642004b4408eac0264da1ca5b810051a05222bbbb222",
14+
"hash": "zFsGM27HNS66qmGp1Y1STK48FUA1F12VHLRB51RGWNYWV",
15+
"decoded": {
16+
"firing": {
17+
"execution": "zFsGM26E6xAuYMXox2zMGUChk3HmbEAMGXBiWG3UL7KF5",
18+
"message": "222bbbb222",
19+
"path": [5]
20+
},
21+
"previous": "zFsGM26F88jGH8HtpdSCBdgRWSVJEWbyDoH1HRRWXTZyC"
22+
}
23+
},
24+
{
25+
"status": "ok",
26+
"hex": "0a20dce4021cd649d3a9d1f69832f26739c1d81c873ca5f343ec2dd92d335adfc805122a0a20dce4021c1447c0b50a5ce982dd4e78650ca3cc642004b4408eac0264da1ca5b810011a04111aaa11",
27+
"hash": "zFsGM26F88jGH8HtpdSCBdgRWSVJEWbyDoH1HRRWXTZyC",
28+
"decoded": {
29+
"firing": {
30+
"execution": "zFsGM26E6xAuYMXox2zMGUChk3HmbEAMGXBiWG3UL7KF5",
31+
"message": "111aaa11",
32+
"path": [1]
33+
},
34+
"previous": "zFsGM28DqZKjjGbfCEsjsXTj8xJAqWaBXpDSc1CqR6ihi"
35+
}
36+
},
37+
{
38+
"status": "ok",
39+
"hex": "0a20dce4021c1447c0b50a5ce982dd4e78650ca3cc642004b4408eac0264da1ca5b812240a20dce4021c1447c0b50a5ce982dd4e78650ca3cc642004b4408eac0264da1ca5b81004",
40+
"hash": "zFsGM28DqZKjjGbfCEsjsXTj8xJAqWaBXpDSc1CqR6ihi",
41+
"decoded": {
42+
"firing": {
43+
"execution": "zFsGM26E6xAuYMXox2zMGUChk3HmbEAMGXBiWG3UL7KF5",
44+
"path": [4]
45+
},
46+
"previous": "zFsGM26E6xAuYMXox2zMGUChk3HmbEAMGXBiWG3UL7KF5"
47+
}
48+
},
49+
{
50+
"status": "ok",
51+
"hex": "0a20dce4021cacc5f351d54402799977d7e4f7b86805359aec724805c80ec0b4d546120710001a03aa0003",
52+
"hash": "zFsGM26E6xAuYMXox2zMGUChk3HmbEAMGXBiWG3UL7KF5",
53+
"decoded": {
54+
"firing": { "message": "aa0003", "path": [0] },
55+
"previous": "zFsGM27o59f9Lu8bWjNHBG7Wbq5iftQA6uDt14zRdjCrH"
56+
}
57+
},
58+
{
59+
"status": "ok",
60+
"hex": "0a20dce4021c8f117e89c479665f6d61ff650b150af375d6498b593da6afa8d2ca9f1afa010add010a0a70726976696c656467651001100010021000100210001006100010011000100310001003100010011000100210001004100010031000100510001004100010051000100110001005100010021000100510001006100010021000100610001003100010061000100510001000100310001a036275791a07666f7253616c651a05626c6f636b1a07756e626c6f636b1a047363616e1a086e6f74536f6c64321a0873686f774f7665721a076e6f74536f6c641a066e6f53686f771a04627579271a076275794261636b1a096e6f745265736f6c641a0663726561746512160a046d61696e10011801220a70726976696c656467651800",
61+
"hash": "zFsGM27o59f9Lu8bWjNHBG7Wbq5iftQA6uDt14zRdjCrH",
62+
"decoded": {
63+
"wiring": {
64+
"nets": [
65+
{
66+
"name": "priviledge",
67+
"partition": [
68+
1,
69+
0,
70+
2,
71+
0,
72+
2,
73+
0,
74+
6,
75+
0,
76+
1,
77+
0,
78+
3,
79+
0,
80+
3,
81+
0,
82+
1,
83+
0,
84+
2,
85+
0,
86+
4,
87+
0,
88+
3,
89+
0,
90+
5,
91+
0,
92+
4,
93+
0,
94+
5,
95+
0,
96+
1,
97+
0,
98+
5,
99+
0,
100+
2,
101+
0,
102+
5,
103+
0,
104+
6,
105+
0,
106+
2,
107+
0,
108+
6,
109+
0,
110+
3,
111+
0,
112+
6,
113+
0,
114+
5,
115+
0,
116+
0,
117+
3,
118+
0
119+
],
120+
"names": [
121+
"buy",
122+
"forSale",
123+
"block",
124+
"unblock",
125+
"scan",
126+
"notSold2",
127+
"showOver",
128+
"notSold",
129+
"noShow",
130+
"buy'",
131+
"buyBack",
132+
"notResold",
133+
"create"
134+
]
135+
}
136+
],
137+
"diagrams": [
138+
{ "name": "main", "width": 1, "pixels": [1], "names": ["priviledge"] }
139+
],
140+
"labels": [0]
141+
},
142+
"previous": "zFsGM27VMNWZne1SSkWnDQTzr6TdjmsKpbxGkJKKaEC8e"
143+
}
144+
},
145+
{
146+
"status": "ok",
147+
"hex": "0a0022200a1e47756172616e746565642d456e7472616e63652d546f6b656e2e74657374",
148+
"hash": "zFsGM27VMNWZne1SSkWnDQTzr6TdjmsKpbxGkJKKaEC8e",
149+
"decoded": {
150+
"root": {
151+
"message": "47756172616e746565642d456e7472616e63652d546f6b656e2e74657374"
152+
},
153+
"previous": "z"
154+
}
155+
}
156+
]
157+
"""

‎stbx-service-rest/packages.dhall

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,11 @@ let additions =
1717
(../stbx-client-rest/spago.dhall).dependencies
1818
"../stbx-client-rest"
1919
"development"
20+
, stbx-example-data =
21+
mkPackage
22+
(../stbx-example-data/spago.dhall).dependencies
23+
"../stbx-example-data"
24+
"development"
2025
, express =
2126
mkPackage
2227
[ "aff"

‎stbx-service-rest/spago.dhall

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@
1111
, "psci-support"
1212
, "stbx-core"
1313
, "stbx-client-rest"
14+
, "stbx-example-data"
1415
]
1516
, packages =
1617
./packages.dhall

0 commit comments

Comments
 (0)