library.tri (10791B)
1 !import arboricx_handlers as Registry 2 !import io_artifacts as Upload 3 !import test_observe as Observe 4 !import io_storage as Storage 5 !import base as B 6 !import io as IO 7 !import handlers as H 8 !import handler_log as Log 9 !import handler_artifacts as Artifacts 10 !import handler_testing as Test 11 !import handler_get_demo as Get 12 !import arboricx_server as Server 13 !import http as HTTP 14 !export * 15 16 constant value _ _ = H.pure value 17 route service target action = H.handle service (op arg : H.forward target op arg) action 18 read = H.request "store" "read" 7 19 20 pureValue = H.runPure (H.pure 42) 21 handled = H.runPure (H.handle "store" (constant 8) read) 22 override = H.runPure (H.handle "store" (constant 8) (H.handle "store" (constant 9) read)) 23 restore = H.runPure (H.handle "store" (constant 8) (do H.bind 24 first <- H.handle "store" (constant 9) read 25 second <- read 26 H.pure [first second])) 27 lexical = H.runPure <| H.handle "other" (constant 8) 28 (route "store" "other" (H.handle "other" (constant 9) read)) 29 noReentry = H.runPure (H.handle "store" (constant 8) (route "store" "store" read)) 30 missing = H.runPure (H.label "request-42" read) 31 labelRestore = H.runPure <| do H.bind 32 H.label "finished" (H.pure 0) 33 read 34 labelNested = H.runPure (H.label "outer" (H.label "inner" read)) 35 escaped = H.runPure (H.handle "store" (constant 8) (do H.bind 36 action <- H.handle "store" (constant 9) (H.pure read) 37 action)) 38 malformed = H.runPure (B.pair 999 t) 39 40 -- Pure evaluation must never execute the host bridge. 41 noIO = H.runPure (H.label "pure-only" (H.liftIO (IO.fail "MUST NOT PRINT"))) 42 invalidRequest = H.runPure (H.checkedRequest "math" "id" B.nat? B.nat? (t t)) 43 invalidResponse = H.runPure (H.handle "math" (constant (t t)) (H.checkedRequest "math" "id" B.nat? B.nat? 1)) 44 brokenC _ _ = t 45 brokenContract = H.runPure (H.checkedRequest "math" "id" brokenC B.anyC 1) 46 -- Transformed contract values must be used, not the original request/reply. 47 replaceC value _ rest = B.contractOk value rest 48 transformed = H.runPure (H.handle "math" (op arg : H.pure arg) 49 (H.checkedRequest "math" "id" (replaceC 10) (replaceC 20) 1)) 50 51 logging = do H.bind 52 Log.info "started" 53 Log.warn "finished" 54 H.pure 42 55 captured = logging |> Log.withContext [["request" 7]] |> Log.capture |> H.runPure 56 nestedContext = logging |> Log.withContext [["inner" 2]] |> Log.withContext [["outer" 1]] |> Log.capture |> H.runPure 57 nestedCapture = logging |> Log.capture |> Log.capture |> H.runPure 58 captureOrder = logging |> Log.capture |> Log.withContext [["outside" 9]] |> H.runPure 59 captureFailure = H.label "failure-scope" (H.fail "example" "store" "read" "failed") |> Log.capture |> H.runPure 60 captureForward = H.runPure (H.handle "store" (constant 8) (Log.capture (do H.bind 61 Log.info "before" 62 value <- H.label "read-scope" read 63 Log.info "after" 64 H.pure value))) 65 captureMissing = H.runPure (H.label "outer" (Log.capture (H.label "inner" read))) 66 invalidContext = H.runPure (Log.withContext (t t) logging) 67 badLogReply = H.runPure (Log.withSink (_ : H.pure 0) (Log.info "x")) 68 logFailure = H.runPure (Log.withSink (_ : H.pure (B.err "offline" t)) (Log.info "x")) 69 discard = logging |> Log.discard |> H.runPure 70 unknownLog = H.runPure (Log.discard (H.request "logging" "unknown" [])) 71 72 scripted script = Test.run script (H.label "scripted" read) 73 scriptedCapture script = Test.run script (Log.capture (H.label "inside" read)) 74 artifactLoad digest script = Test.run script (Artifacts.load digest) 75 artifactNamed digest script = Test.run script (Artifacts.loadFrom "source" digest) 76 artifactPublish bytes script = Test.run script (Artifacts.publish bytes) 77 78 -- Test observer wraps source diagnostics as Results; production uses terminal 79 -- v2 outcomes. See observe.tri, not the retired v1 H.runIO contract. 80 ioLoad root digest = IO.io (Observe.result (Artifacts.withFilesystem root 1048576 (Artifacts.load digest))) 81 ioRawLoad root digest = IO.io (Observe.result (Artifacts.withFilesystem root 1048576 (H.request "artifacts" "load" digest))) 82 ioPublish root bytes = IO.io (Observe.result (Artifacts.withFilesystem root 1048576 (Artifacts.publish bytes))) 83 ioNamed root digest = IO.io (Observe.result (Artifacts.withFilesystemFor "source" root 1048576 (Artifacts.loadFrom "source" digest))) 84 ioCapture root digest = IO.io (Observe.result (Artifacts.withFilesystem root 1048576 (Log.capture (do H.bind 85 reply <- Artifacts.load digest 86 Log.info "loaded" 87 H.pure reply)))) 88 ioFailure root digest = IO.io (Observe.result (H.label "request" (Artifacts.withFilesystem root 1048576 (H.fail "example" "artifacts" "load" digest)))) 89 90 getRequest digest script = Test.run script (Log.capture (Log.withContext [["request" 7]] (Get.getBundle digest))) 91 ioGet root digest = IO.io (Observe.result (Log.capture (Log.withContext [["request" 7]] (Artifacts.withFilesystem root 1048576 (Get.getBundle digest))))) 92 getDemo = Get.main 93 ioPrepare root = IO.io (Observe.result (Artifacts.prepareFilesystem root)) 94 rawBadLog = H.runPure (Log.capture (H.label "raw" (H.request "logging" "emit" 0))) 95 transformedScript script = Test.run script (H.checkedRequest "math" "id" (replaceC 10) (replaceC 20) 1) 96 badRemainderC value _ = B.contractOk value 7 97 badInputContract = H.runPure (H.checkedRequest "math" "id" badRemainderC B.anyC 1) 98 badOutputContract = H.runPure (H.handle "math" (constant 1) (H.checkedRequest "math" "id" B.anyC badRemainderC 1)) 99 100 -- Full-response benchmark. The direct baseline is successful GETs only; it 101 -- constructs the same context events without the handler/contract layer. 102 manyGet digest [] = H.pure [] 103 manyGet digest [context | rest] = do H.bind 104 response <- Log.withContext [["request" context]] (Get.getBundle digest) 105 responses <- manyGet digest rest 106 H.pure (B.pair response responses) 107 manyGet _ _ = H.fail "invalid-request" "benchmark" "contexts" t 108 ioMany root digest contexts = IO.io <| Observe.result 109 (Log.capture (Artifacts.withFilesystem root 1048576 (manyGet digest contexts))) 110 readStatus ((t t), _) = 200 111 readStatus _ = 404 112 directMany root digest [] = IO.pure [[] []] 113 directMany root digest [context | rest] = do IO.bind 114 loaded <- readArtifact root digest 115 response <- IO.pure (case loaded of 116 ((t t), (bytes, t)) = Server.bundleResponse bytes 117 _ = HTTP.errorResponse 404 "Artifact unavailable\n") 118 following <- directMany root digest rest 119 case following of 120 [responses logs] = IO.pure [(B.pair response responses) (B.pair ["info" [["request" context]] [digest (readStatus loaded)]] logs)] 121 _ = IO.pure t 122 directMany _ _ _ = IO.pure t 123 ioDirectMany root digest contexts = IO.io (IO.bind (directMany root digest contexts) (value : IO.pure (B.ok value t))) 124 -- A real sink records attempts through the explicit test observer, distinct 125 -- from Log.capture's production boundary transformer. 126 recordLog event = H.bind (H.request "test.trace" "record" event) (_ : H.pure (B.ok t t)) 127 ioSinkMany root digest contexts = IO.io (IO.bind 128 (Observe.run (Log.withSink recordLog 129 (Artifacts.withFilesystem root 1048576 (manyGet digest contexts))) []) 130 (observed : case observed of 131 [((t t), (responses, t)) events] = IO.pure (B.ok [responses (B.reverse events)] t) 132 [failure _] = IO.pure failure 133 _ = IO.fail "Invalid sink observation")) 134 -- Direct comparison shares the real authenticated filesystem adapter, not just 135 -- raw reads with fewer obligations. The observer adds an execution Result only. 136 readArtifact root digest = IO.bind 137 (Observe.result (Artifacts.withFilesystem root 1048576 (H.request "artifacts" "load" digest))) 138 (reply : case reply of 139 ((t t), (domain, t)) = IO.pure domain 140 _ = IO.fail "Invalid artifact adapter observation") 141 142 -- Application policy checked independently of the real socket smoke. Exact 143 -- scripts check effects; capture checks request-local logging context. 144 registryRequest method target body packageReply script = Test.run script 145 (Log.capture (Log.withContext [["method" method] ["target" target]] 146 (Registry.request (_ : H.pure packageReply) method target [] body))) 147 148 registryStdout = IO.io (Observe.result (Registry.stdoutLog ["info" [] 200])) 149 150 writeChunks [] = H.pure (B.ok t t) 151 writeChunks [chunk | rest] = do H.bind 152 written <- Upload.write chunk 153 case written of 154 ((t t), (t, t)) = writeChunks rest 155 _ = H.pure written 156 writeChunks _ = H.fail "invalid-request" "test" "chunks" t 157 streamChunks root expected chunks = IO.io (Observe.result (Artifacts.publishStream root expected (writeChunks chunks))) 158 streamAbandon root = IO.io (Observe.result (Artifacts.publishStream root 1 (do H.bind 159 Upload.write [65] 160 H.pure (B.err "stopped" t)))) 161 streamProtocolFailure root = IO.io (Observe.result (Artifacts.publishStream root 1 (H.fail "test-failure" "test" "producer" t))) 162 streamFalseAck root = IO.io (Observe.result (Artifacts.publishStream root 1 163 (H.handle "artifact-stream" (_ _ : H.pure (B.ok t t)) (Upload.write [65])))) 164 streamIgnoreFailure root = IO.io (Observe.result (Artifacts.publishStream root 1 (do H.bind 165 Upload.write [256] 166 H.pure (B.ok t t)))) 167 unforcedForever value = unforcedForever value 168 lazyIOLabel value = IO.io (Observe.result (H.label (unforcedForever value) (H.liftIO (IO.pure 7)))) 169 lazyFailedContinuation value = IO.io (Observe.result 170 (H.bind (H.fail "test-failure" "test" "producer" t) (_ : unforcedForever value))) 171 172 -- Independent helper controls use divergent unselected callbacks and payloads. 173 rejectedRemainderC _ _ = B.err "declined" 7 174 malformedReplacementC _ _ = B.contractOk 99 7 175 rejectedLazyC _ _ = B.err (unforcedForever 0) (unforcedForever 1) 176 truthyReplyC value _ = B.pair (t (t t)) (B.pair value t) 177 checkAccepted = H.runPure (H.checkWith (replaceC 10) (unforcedForever 0) 178 (unforcedForever 1) (unforcedForever 2) H.pure) 179 checkRejected = H.runPure (H.checkWith rejectedRemainderC (unforcedForever 0) 180 (message : H.pure [message 12]) (unforcedForever 1) (unforcedForever 2)) 181 checkMalformed = H.runPure (H.checkWith malformedReplacementC 7 182 (unforcedForever 1) H.pure (unforcedForever 2)) 183 checkMalformedLazy = H.runPure (H.checkWith brokenC (unforcedForever 0) 184 (unforcedForever 1) (_ : H.pure 13) (unforcedForever 2)) 185 checkTruthy = H.runPure (H.checkWith truthyReplyC 42 186 (unforcedForever 1) H.pure (unforcedForever 2)) 187 requestStopped script = Test.run script (H.label "checked" 188 (H.checkRequest "math" "id" B.nat? (t t) (unforcedForever 0))) 189 inputBeforeReply script = Test.run script (H.label "checked" 190 (H.checkedRequest "math" "id" B.nat? (unforcedForever 0) (t t))) 191 outputAfterReply script = Test.run script (H.label "checked" 192 (H.checkedRequest "math" "id" B.anyC badRemainderC 17)) 193 sinkStopped = H.runPure (H.label "sink" (Log.withSink (unforcedForever 0) 194 (H.request "logging" "emit" 0))) 195 checkRejectedLazy = H.runPure (H.checkWith rejectedLazyC (unforcedForever 0) 196 (_ : H.pure 14) (unforcedForever 1) (unforcedForever 2))