equivalent.tri (8771B)
1 !import base as B 2 !import test_state as State 3 !import test_observe as Observe 4 !import handlers as H 5 !import handler_log as Log 6 !import handler_artifacts as Artifacts 7 !import handler_get_demo as Get 8 !import handler_fixture as Existing 9 !import arboricx_server as Server 10 !import http as HTTP 11 !export * 12 13 -- Comparison fixture, compiled ONLY by handler_costs.py. Its temporary workspace 14 -- exposes the existing private contracts without changing their bodies. No 15 -- validation switches below are part of the production libraries. 16 -- Profile [API-digest body-bytes context-list event-shape sink-reply]. The adapter 17 -- digest/path check and service Result-envelope check are NEVER switched off. 18 choose 0 _ disabled = disabled 19 choose _ enabled _ = enabled 20 labels = ["bundle-get"] 21 22 -- Same contract callback protocol/diagnostics as H.checkedRequest, sequenced 23 -- directly with host IO rather than interpreted requests. Contract successes 24 -- retain transformed values and require an empty remainder. 25 checked kind service operation contexts contract value next = case B.checkContract contract value of 26 ((t t), (validated, t)) = next validated 27 (t, (message, _)) = State.pure (B.err (H.diagnostic kind service operation message contexts) t) 28 _ = State.pure (B.err (H.diagnostic (B.append kind "-contract") service operation value contexts) t) 29 30 -- This fixture uses explicit lambda grouping (not a different pipe precedence). 31 checkedInvoke service operation inputC outputC argument implementation next = 32 checked "invalid-request" service operation labels inputC argument (checkedArgument : do State.bind 33 reply <- implementation checkedArgument 34 checked "invalid-response" service operation labels outputC reply next) 35 36 -- Envelope-only control for isolating deep byte-list validation. This is NOT an 37 -- admissible production load contract: it deliberately trusts successful bytes. 38 loadEnvelope value{((t t), (bytes, t))} rest = B.contractOk value rest 39 loadEnvelope value{(t, (message, t))} rest = B.contractOk value rest 40 loadEnvelope _ rest = B.contractErr "expected artifact-load Result with empty remainder" rest 41 42 load api body digest reader next = let 43 emit checkedDigest = checkedInvoke "artifacts" "load" B.anyC 44 (choose body Artifacts.loadReplyC loadEnvelope) checkedDigest reader next 45 in case api of 46 0 = emit digest 47 _ = case B.checkContract Server.bundleHashC digest of 48 ((t t), (checkedDigest, t)) = emit checkedDigest 49 (t, (message, _)) = next (B.err ["invalid-digest" message] t) 50 _ = State.pure (B.err (H.diagnostic "invalid-contract" "artifacts" "load" digest labels) t) 51 52 status ((t t), _) = 200 53 status (t, (["invalid-digest" message], t)) = 400 54 status _ = 404 55 render ((t t), (bytes, t)) = HTTP.response 200 "application/vnd.arboricx.bundle" bytes 56 render (t, (["invalid-digest" message], t)) = HTTP.badRequestResponse message 57 render _ = HTTP.errorResponse 404 "Artifact unavailable\n" 58 59 -- Sink boundary uses the SAME event contract as Log.withSink, while the caller 60 -- uses that contract before decoration just like Log.emit. Context is validated 61 -- once per request before entering the bundle-get diagnostic label. 62 logWith events replies fields payload sink next = let 63 eventC = choose events Log.eventC B.anyC 64 replyC = choose replies Log.replyC B.anyC 65 deliver [level inner message] = case B.checkContract eventC [level (B.append fields inner) message] of 66 ((t t), (event, t)) = State.bind (sink event) 67 (reply : checked "invalid-response" "logging" "emit" labels replyC reply next) 68 (t, (message, _)) = State.pure (B.err (H.diagnostic "invalid-request" "logging" "emit" message labels) t) 69 _ = State.pure (B.err (H.diagnostic "invalid-request-contract" "logging" "emit" payload labels) t) 70 deliver _ = State.pure (B.err (H.diagnostic "invalid-request" "logging" "emit" payload labels) t) 71 in checked "invalid-request" "logging" "emit" labels eventC ["info" [] payload] deliver 72 73 one [api body context events replies] fields digest reader sink = let 74 finish reply logged = case logged of 75 ((t t), _) = State.pure (B.ok (render reply) t) 76 (t, (message, _)) = State.pure (B.err (H.diagnostic "application-failure" "logging" "emit" message labels) t) 77 _ = State.pure (B.err (H.diagnostic "application-failure" "logging" "emit" "invalid logger reply" labels) t) 78 go checkedFields = load api body digest reader (reply : logWith events replies checkedFields [digest (status reply)] sink (finish reply)) 79 in case B.checkContract (choose context (B.listOf B.anyC) B.anyC) fields of 80 ((t t), (checkedFields, t)) = go checkedFields 81 _ = State.pure (B.err (H.diagnostic "invalid-request" "logging" "context" "context must be a proper list" []) t) 82 one _ _ _ _ _ = State.pure (B.err "invalid benchmark profile" t) 83 84 -- Identical raw filesystem boundary to Artifacts.withFilesystem; it cannot be 85 -- disabled by a profile. Invalid raw digests never become filesystem paths. 86 reader root digest = case B.checkContract Server.bundleHashC digest of 87 ((t t), (checkedDigest, t)) = State.lift (Existing.readArtifact root checkedDigest) 88 (t, (message, _)) = State.pure (B.err ["invalid-digest" message] t) 89 _ = State.pure (B.err (H.diagnostic "invalid-contract" "artifacts" "load" digest labels) t) 90 record event = do State.bind 91 events <- State.current 92 State.replace (B.pair event events) 93 State.pure (B.ok t t) 94 95 many profile root digest [] = State.pure (B.ok [] t) 96 many profile root digest [context | rest] = do State.bind 97 reply <- one profile [["request" context]] digest (reader root) record 98 case reply of 99 ((t t), (response, t)) = do State.bind 100 following <- many profile root digest rest 101 case following of 102 ((t t), (responses, t)) = State.pure (B.ok (B.pair response responses) t) 103 _ = State.pure following 104 _ = State.pure reply 105 many _ _ _ _ = State.pure (B.err "invalid benchmark contexts" t) 106 ioEquivalent profile root digest contexts = State.io <| do State.bind 107 State.replace [] 108 reply <- many profile root digest contexts 109 events <- State.current 110 case reply of 111 ((t t), (responses, t)) = State.pure (B.ok [responses (B.reverse events)] t) 112 _ = State.pure reply 113 114 ioDirect = Existing.ioDirectMany 115 ioLibraryCapture = Existing.ioMany 116 ioLibrarySink = Existing.ioSinkMany 117 118 -- Independent negative controls record attempted operations and compare both 119 -- the execution Result and trace, not just the final HTTP success output. 120 probeRead reply digest = do State.bind 121 events <- State.current 122 State.replace (B.pair ["read" digest] events) 123 State.pure reply 124 probeLog reply event = do State.bind 125 events <- State.current 126 State.replace (B.pair ["log" event] events) 127 State.pure reply 128 withTrace action = State.io <| do State.bind 129 State.replace [] 130 reply <- action 131 events <- State.current 132 State.pure [reply (B.reverse events)] 133 directProbe fields digest readReply logReply = withTrace 134 (one [1 1 1 1 1] fields digest (probeRead readReply) (probeLog logReply)) 135 handlerProbe fields digest readReply logReply = withTrace <| Observe.run 136 (Log.withSink (event : H.bind (H.request "test.trace" "record" ["log" event]) (_ : H.pure logReply)) 137 (Log.withContext fields 138 (H.handle "artifacts" (op arg : H.bind (H.request "test.trace" "record" ["read" arg]) 139 (_ : H.pure readReply)) (Get.getBundle digest)))) 140 141 rawReader root digest = State.io (reader root digest) 142 143 -- Explicitly unsafe profiles exist only in this fixture. Counterexamples in 144 -- the runner prove which invariant an omission abandons; they are not APIs. 145 directProbeProfile profile fields digest readReply logReply = withTrace 146 (one profile fields digest (probeRead readReply) (probeLog logReply)) 147 148 -- Batched validator probes preserve nonempty contract remainders as well as 149 -- accepted trees. Python constructs expectations independently of predicates. 150 validateOctets values = B.map (value : Artifacts.byteC value 7) values 151 validateByteLists values = B.map (value : Artifacts.bytesC value 7) values 152 validateHex values = B.map Server.bundleHexByte? values 153 validateHashes values = B.map (value : Server.bundleHashC value 7) values 154 155 neverReturns value = neverReturns value 156 -- These deliberately divergent suffixes must remain unobserved. The subprocess 157 -- guard turns accidental forcing into a bounded test failure, not a hung suite. 158 hashDemand _ = [ 159 (Server.bundleHashC (B.append "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" (B.pair (neverReturns t) (neverReturns t))) 7) 160 (Server.bundleHashC (B.pair 47 (neverReturns t)) 7)] 161 162 validateLengths values = B.map HTTP.httpBodyLength values 163 validateReferenceLengths values = B.map B.length values 164 lengthDemand _ = [(HTTP.httpBodyLength [(neverReturns t)]) 165 (HTTP.httpBodyLength (B.pair (neverReturns t) (t t)))]