|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE OverloadedStrings #-} |
| 3 | +{-# LANGUAGE TypeApplications #-} |
| 4 | + |
| 5 | +-- | Tests for how @SearchUtxos@ builds its response from a field mask. |
| 6 | +module Test.Cardano.Rpc.SearchUtxos where |
| 7 | + |
| 8 | +import Cardano.Api (TxIn) |
| 9 | +import Cardano.Api.Parser.Text qualified as P |
| 10 | +import Cardano.Api.Tx (parseTxIn) |
| 11 | +import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as U5c |
| 12 | +import Cardano.Rpc.Server.Internal.FieldMask |
| 13 | +import Cardano.Rpc.Server.Internal.UtxoRpc.Query |
| 14 | + ( paginateByTxIn |
| 15 | + , searchUtxosFieldMask |
| 16 | + , searchUtxosFill |
| 17 | + ) |
| 18 | +import Cardano.Rpc.Server.Internal.UtxoRpc.Type |
| 19 | + |
| 20 | +import RIO |
| 21 | + |
| 22 | +import Data.Map.Strict qualified as Map |
| 23 | +import Data.ProtoLens (defMessage) |
| 24 | +import Data.Text qualified as T |
| 25 | + |
| 26 | +import Test.Cardano.Rpc.RecordedQuery |
| 27 | + |
| 28 | +import Hedgehog as H |
| 29 | +import Hedgehog.Extras qualified as H |
| 30 | + |
| 31 | +import Proto.Google.Protobuf.FieldMask_Fields qualified as FieldMask (paths) |
| 32 | + |
| 33 | +hprop_field_mask_search_utxos_unselected_item_fields_are_not_evaluated :: Property |
| 34 | +hprop_field_mask_search_utxos_unselected_item_fields_are_not_evaluated = H.propertyOnce $ do |
| 35 | + let lazyFields = |
| 36 | + [ UtxoFields (utxoFieldsRef f) (error "forced") (error "forced") |
| 37 | + | f <- realFields |
| 38 | + ] |
| 39 | + (response, ran) <- H.evalNF $ build ["items.txo_ref"] lazyFields realToken |
| 40 | + ran === ["session", "page"] |
| 41 | + map (view U5c.txoRef) (response ^. U5c.items) === map utxoFieldsRef realFields |
| 42 | + H.assertWith response $ all (isNothing . view U5c.maybe'cardano) . view U5c.items |
| 43 | + H.assertWith response $ all ((== mempty) . view U5c.nativeBytes) . view U5c.items |
| 44 | + H.assertWith response $ isNothing . view U5c.maybe'ledgerTip |
| 45 | + H.assertWith response $ isNothing . view U5c.maybe'nextToken |
| 46 | + |
| 47 | +hprop_field_mask_search_utxos_ledger_tip_runs_only_the_tip_query :: Property |
| 48 | +hprop_field_mask_search_utxos_ledger_tip_runs_only_the_tip_query = H.propertyOnce $ do |
| 49 | + let (response, ran) = build ["ledger_tip"] realFields realToken |
| 50 | + ran === ["session", "ledgerTip"] |
| 51 | + response === (defMessage & U5c.ledgerTip .~ realTip) |
| 52 | + |
| 53 | +hprop_field_mask_search_utxos_next_token_runs_only_the_page_query :: Property |
| 54 | +hprop_field_mask_search_utxos_next_token_runs_only_the_page_query = H.propertyOnce $ do |
| 55 | + (response, ran) <- H.evalNF $ build ["next_token"] (error "forced") realToken |
| 56 | + ran === ["session", "page"] |
| 57 | + response ^. U5c.maybe'nextToken === realToken |
| 58 | + H.assertWith response $ null . view U5c.items |
| 59 | + H.assertWith response $ isNothing . view U5c.maybe'ledgerTip |
| 60 | + |
| 61 | +hprop_field_mask_search_utxos_items_and_next_token_share_one_page_query :: Property |
| 62 | +hprop_field_mask_search_utxos_items_and_next_token_share_one_page_query = H.propertyOnce $ do |
| 63 | + let (response, ran) = build ["items", "next_token"] realFields realToken |
| 64 | + ran === ["session", "page"] |
| 65 | + length (response ^. U5c.items) === 2 |
| 66 | + response ^. U5c.maybe'nextToken === realToken |
| 67 | + |
| 68 | +hprop_field_mask_search_utxos_nothing_selected_runs_no_query :: Property |
| 69 | +hprop_field_mask_search_utxos_nothing_selected_runs_no_query = H.propertyOnce $ do |
| 70 | + build ["bogus"] realFields realToken === (defMessage, []) |
| 71 | + |
| 72 | +hprop_field_mask_search_utxos_gated_paths_set_their_field :: Property |
| 73 | +hprop_field_mask_search_utxos_gated_paths_set_their_field = H.propertyOnce $ do |
| 74 | + responseFor ["ledger_tip"] ^. U5c.maybe'ledgerTip === Just realTip |
| 75 | + H.assertWith (responseFor ["ledger_tip"]) $ null . view U5c.items |
| 76 | + responseFor ["next_token"] ^. U5c.maybe'nextToken === realToken |
| 77 | + H.assertWith (responseFor ["next_token"]) $ null . view U5c.items |
| 78 | + map (view U5c.txoRef) (responseFor ["items.txo_ref"] ^. U5c.items) === map utxoFieldsRef realFields |
| 79 | + map (view U5c.nativeBytes) (responseFor ["items.native_bytes"] ^. U5c.items) |
| 80 | + === map utxoFieldsNativeBytes realFields |
| 81 | + map (view U5c.cardano) (responseFor ["items.cardano"] ^. U5c.items) |
| 82 | + === map utxoFieldsCardano realFields |
| 83 | + -- The whole items field selects every item field. |
| 84 | + map (view U5c.nativeBytes) (responseFor ["items"] ^. U5c.items) |
| 85 | + === map utxoFieldsNativeBytes realFields |
| 86 | + |
| 87 | +hprop_field_mask_search_utxos_select_all_sets_every_field :: Property |
| 88 | +hprop_field_mask_search_utxos_select_all_sets_every_field = H.propertyOnce $ do |
| 89 | + let (fullResponse, ran) = build [] realFields realToken |
| 90 | + expectedItems = |
| 91 | + [ defMessage |
| 92 | + & U5c.txoRef .~ utxoFieldsRef f |
| 93 | + & U5c.nativeBytes .~ utxoFieldsNativeBytes f |
| 94 | + & U5c.cardano .~ utxoFieldsCardano f |
| 95 | + | f <- realFields |
| 96 | + ] |
| 97 | + ran === ["session", "page", "ledgerTip"] |
| 98 | + fullResponse ^. U5c.items === expectedItems |
| 99 | + fullResponse ^. U5c.maybe'ledgerTip === Just realTip |
| 100 | + fullResponse ^. U5c.maybe'nextToken === realToken |
| 101 | + |
| 102 | +hprop_field_mask_search_utxos_nested_path_trims_cardano :: Property |
| 103 | +hprop_field_mask_search_utxos_nested_path_trims_cardano = H.propertyOnce $ do |
| 104 | + let trimmed = responseFor ["items.cardano.address"] |
| 105 | + expectedItems = |
| 106 | + [ defMessage & U5c.cardano . U5c.address .~ utxoFieldsCardano f ^. U5c.address |
| 107 | + | f <- realFields |
| 108 | + ] |
| 109 | + trimmed ^. U5c.items === expectedItems |
| 110 | + H.assertWith trimmed $ isNothing . view U5c.maybe'ledgerTip |
| 111 | + H.assertWith trimmed $ isNothing . view U5c.maybe'nextToken |
| 112 | + |
| 113 | +-- | The handler's own mask wiring: request paths select, an empty request selects all. |
| 114 | +hprop_field_mask_search_utxos_request_mask_selects_requested_paths :: Property |
| 115 | +hprop_field_mask_search_utxos_request_mask_selects_requested_paths = H.propertyOnce $ do |
| 116 | + let request = defMessage & U5c.fieldMask . FieldMask.paths .~ ["next_token"] |
| 117 | + fieldMask = searchUtxosFieldMask request |
| 118 | + H.assertWith fieldMask $ isSelected @"nextToken" |
| 119 | + H.assertWith fieldMask $ not . isSelected @"items" |
| 120 | + H.assertWith fieldMask $ not . isSelected @"ledgerTip" |
| 121 | + searchUtxosFieldMask defMessage === SelectAll |
| 122 | + |
| 123 | +-- | The fill passes the pagination token through unchanged whenever the mask selects it. |
| 124 | +hprop_field_mask_search_utxos_next_token_is_the_same_under_any_mask :: Property |
| 125 | +hprop_field_mask_search_utxos_next_token_is_the_same_under_any_mask = H.propertyOnce $ do |
| 126 | + let entries = Map.fromList [mkEntry i | i <- [0 .. 4 :: Int]] |
| 127 | + (page, token) = paginateByTxIn (const True) entries Nothing 2 |
| 128 | + respond paths = fst $ build paths (map snd page) token |
| 129 | + length page === 2 |
| 130 | + H.assertWith token isJust |
| 131 | + respond ["next_token"] ^. U5c.maybe'nextToken === token |
| 132 | + respond [] ^. U5c.maybe'nextToken === token |
| 133 | + length (respond ["items"] ^. U5c.items) === 2 |
| 134 | + where |
| 135 | + mkEntry i = |
| 136 | + ( mkTxIn $ T.replicate 64 "1" <> "#" <> T.pack (show i) |
| 137 | + , UtxoFields |
| 138 | + { utxoFieldsRef = defMessage & U5c.index .~ fromIntegral i |
| 139 | + , utxoFieldsNativeBytes = "native" |
| 140 | + , utxoFieldsCardano = defMessage & U5c.address .~ "address" |
| 141 | + } |
| 142 | + ) |
| 143 | + |
| 144 | +-- | The response for the mask paths from 'realFields' and 'realToken'. |
| 145 | +responseFor |
| 146 | + :: [Text] |
| 147 | + -- ^ Field mask paths, rooted at the response |
| 148 | + -> U5c.SearchUtxosResponse |
| 149 | +responseFor paths = fst $ build paths realFields realToken |
| 150 | + |
| 151 | +-- | Run the response fill for the mask paths, recording the session and each query it runs. |
| 152 | +build |
| 153 | + :: [Text] |
| 154 | + -- ^ Field mask paths, rooted at the response |
| 155 | + -> [UtxoFields] |
| 156 | + -- ^ The UTxO entries of the page that the recorded page query returns |
| 157 | + -> Maybe Text |
| 158 | + -- ^ The next page token that the recorded page query returns |
| 159 | + -> (U5c.SearchUtxosResponse, [Text]) |
| 160 | +build paths items nextToken = |
| 161 | + runRecordedFill paths $ |
| 162 | + searchUtxosFill (recorded "page" (items, nextToken)) (recorded "ledgerTip" realTip) |
| 163 | + |
| 164 | +mkTxIn :: Text -> TxIn |
| 165 | +mkTxIn = either error id . P.runParser parseTxIn |
| 166 | + |
| 167 | +realToken :: Maybe Text |
| 168 | +realToken = Just "next-token" |
0 commit comments