server.tri (9478B)
1 !import base * 2 !import io as IO 3 !import io_storage as Storage 4 !import effects as E 5 !import arboricx_server as Server 6 !import http as HTTP 7 !export * 8 9 -- Adapt the actual GET /_arboricx/bundle/hash/HASH request path, not a toy 10 -- publication protocol. Reuse production hash validation, paths, target parsing, 11 -- and complete HTTP response construction. No socket/framing changes. 12 -- Ops 6/7 are raw file-read Result and completion-log Result, respectively. 13 -- This is an isolated experiment: production server source is not modified. 14 15 -- Malformed hashes never reach storage; read failures 16 -- become redacted HTTP 404, and Result remainders are intentionally discarded here. 17 readBundle reader hash = case (checkContract Server.bundleHashC hash) of 18 ((t t), (value, _)) = (E.seq (reader value) (reply : case reply of 19 ((t t), (bytes, _)) = E.ret (ok bytes t) 20 (t, (message, _)) = E.ret (err 404 "Artifact unavailable\n") 21 _ = E.ret (err 404 "Invalid read result"))) 22 (t, (diagnostic, _)) = E.ret (err 400 diagnostic) 23 _ = E.ret (err 400 "Invalid hash contract result") 24 25 replyStatus ((t t), _) = 200 26 replyStatus (t, (status, _)) = status 27 replyStatus _ = 500 28 renderReply ((t t), (bytes, _)) = Server.bundleResponse bytes 29 renderReply (t, (status, message)) = HTTP.errorResponse status message 30 renderReply _ = HTTP.errorResponse 500 "Invalid bundle result" 31 32 -- Completion logging is an experimental addition, not existing server behavior. 33 -- A logger failure is terminal, not silently swallowed or reported as success. 34 logReply action = (E.seq action (reply : case reply of 35 ((t t), (1, t)) = E.ret 1 36 (t, (message, t)) = E.stop message 37 _ = E.stop "Invalid completion-log response")) 38 39 -- A: construct a request-specific bundle once; close over it in the router. 40 -- Leaf services retain identity; request context is captured in the logger. 41 storeService backend hash = E.request backend 6 hash 42 loggerService context event = logReply (E.request 30 7 [context event]) 43 serveA [reader logger] hash = (do E.seq 44 reply <- readBundle reader hash 45 logger [hash (replyStatus reply)] 46 E.ret (renderReply reply)) 47 serveA _ _ = E.stop "Missing request services" 48 routeA dependencies "GET" target = case (Server.stripPrefix Server.bundleHashPrefix target) of 49 (t hash) = serveA dependencies hash 50 _ = E.ret HTTP.notFoundResponse 51 routeA _ _ _ = E.ret HTTP.notFoundResponse 52 makeRouter backend context = routeA [(storeService backend) (loggerService context)] 53 54 -- H: the router has no service arguments. Context and storage are installed at 55 -- the request boundary; deeper code emits logical requests through these APIs. 56 readCurrent hash = E.request 1 6 hash 57 logCurrent event = logReply (E.request 3 7 event) 58 serveH hash = (do E.seq 59 reply <- readBundle readCurrent hash 60 logCurrent [hash (replyStatus reply)] 61 E.ret (renderReply reply)) 62 routeH "GET" target = case (Server.stripPrefix Server.bundleHashPrefix target) of 63 (t hash) = serveH hash 64 _ = E.ret HTTP.notFoundResponse 65 routeH _ _ = E.ret HTTP.notFoundResponse 66 withContext context action = E.scope 3 (op arg : E.request 30 op [context arg]) action 67 requestScope backend context action = withContext context (E.cRoute 1 backend action) 68 69 -- The same request entrypoint supports ordinary, overridden, and pinned-store 70 -- modes. A reconstructs a router to change its context/store configuration. 71 -- H wraps the callback's computation. Neither changes the business functions. 72 selectA 0 context = makeRouter 11 context 73 selectA 1 context = makeRouter 12 context 74 selectA 2 context = makeRouter 11 context 75 selectA _ context = makeRouter 11 context 76 selectH 0 context action = requestScope 11 context action 77 selectH 1 context action = requestScope 11 context (E.cRoute 1 12 action) 78 selectH 2 context action = requestScope 12 context (E.cRoute 1 11 action) 79 selectH _ context action = requestScope 11 context action 80 81 aRequest mode context method target script = E.run (selectA mode context method target) script 82 cRequest mode context method target script = E.runC (selectH mode context (routeH method target)) script 83 dRequest mode context method target script = E.runD (selectH mode context (routeH method target)) script 84 85 -- A pinned health/audit component fetched in the SAME request as a contextual 86 -- component. Pin only storage; both inherit that request's logging context. 87 -- The service version shares its context logger while selecting the reader. 88 dualA context target = (let 89 logger = loggerService context 90 pinned = routeA [(storeService 11) logger] 91 contextual = routeA [(storeService 12) logger] 92 in do E.seq 93 first <- pinned "GET" target 94 second <- contextual "GET" target 95 E.ret [first second]) 96 dualH target = (do E.seq 97 first <- E.cRoute 1 11 (routeH "GET" target) 98 second <- routeH "GET" target 99 E.ret [first second]) 100 aDual context target script = E.run (dualA context target) script 101 cDual context target script = E.runC (requestScope 12 context (dualH target)) script 102 dDual context target script = E.runD (requestScope 12 context (dualH target)) script 103 104 -- Explicit sequential log state is threaded through the test interpreter. 105 -- Reads use scoped IO and a 64-KiB budget; no native state or grant flags. 106 -- These raw reads test dependency selection, not content-address authentication. 107 backend root alternate events [11 6 hash] = IO.bind 108 (Storage.readBytes (Server.bundleObjectPath root hash) 65536) 109 (reply : IO.pure [reply events]) 110 backend root alternate events [12 6 hash] = IO.bind 111 (Storage.readBytes (Server.bundleObjectPath alternate hash) 65536) 112 (reply : IO.pure [reply events]) 113 backend _ _ events [30 7 event] = IO.pure [(ok 1 t) (pair event events)] 114 backend _ _ events event = IO.pure [(err [95 event] t) events] 115 116 -- Unfused baseline retains its own action/continuation traversal; C feeds its 117 -- normalized tree through this evaluator. D retains fused lexical dispatch. 118 executeAdapter adapter state action stack = let 119 finish reply = IO.pure [reply state] 120 resume value [] = finish (ok value t) 121 resume value [k | rest] = executeAdapter adapter state (k value) rest 122 resume _ _ = finish (err [94] t) 123 in case action of 124 (100, value) = resume value stack 125 (101, (first, k)) = executeAdapter adapter state first (pair k stack) 126 (102, (event, k)) = IO.bind (adapter state event) (result : case result of 127 [reply nextState] = executeAdapter adapter nextState (k reply) stack 128 _ = IO.fail "Invalid test adapter state reply") 129 (103, diagnostic) = finish (err diagnostic t) 130 _ = finish (err [94] t) 131 withRecordedLogs action = IO.io (IO.bind action (result : case result of 132 [reply events] = IO.pure [reply (reverse events)] 133 _ = IO.fail "Invalid test interpreter state reply")) 134 aFilesystem root alternate mode context target = withRecordedLogs (executeAdapter (backend root alternate) [] (selectA mode context "GET" target) []) 135 cFilesystem root alternate mode context target = withRecordedLogs (executeAdapter (backend root alternate) [] (E.normalize (selectH mode context (routeH "GET" target)) [] []) []) 136 dFilesystem root alternate mode context target = withRecordedLogs (E.executeDStateIO (backend root alternate) [] (selectH mode context (routeH "GET" target)) [] []) 137 138 -- A failed native logger still records its attempted event in source state. 139 -- Failure stops the application, not the test's observation of that state. 140 failingBackend _ _ events [30 7 event] = IO.pure [(err "log unavailable" t) (pair event events)] 141 failingBackend root alternate events event = backend root alternate events event 142 aFilesystemLogFailure root alternate mode context target = withRecordedLogs 143 (executeAdapter (failingBackend root alternate) [] (selectA mode context "GET" target) []) 144 cFilesystemLogFailure root alternate mode context target = withRecordedLogs 145 (executeAdapter (failingBackend root alternate) [] (E.normalize (selectH mode context (routeH "GET" target)) [] []) []) 146 dFilesystemLogFailure root alternate mode context target = withRecordedLogs 147 (E.executeDStateIO (failingBackend root alternate) [] (selectH mode context (routeH "GET" target)) [] []) 148 149 -- Request-boundary setup is paid for EACH request in these benchmarks, including 150 -- its context installation. Complete response bytes are returned for observation, 151 -- not discarded (which would skip lazy HTTP rendering). This differs from the clock benchmark's one scope. 152 requestsA [] target = E.ret [] 153 requestsA [context | rest] target = (do E.seq 154 response <- makeRouter 11 context "GET" target 155 responses <- requestsA rest target 156 E.ret (pair response responses)) 157 requestsA _ _ = E.stop [94] 158 requestsH [] target = E.ret [] 159 requestsH [context | rest] target = (do E.seq 160 response <- requestScope 11 context (routeH "GET" target) 161 responses <- requestsH rest target 162 E.ret (pair response responses)) 163 requestsH _ _ = E.stop [94] 164 aRequests contexts target script = E.run (requestsA contexts target) script 165 cRequests contexts target script = E.runC (requestsH contexts target) script 166 dRequests contexts target script = E.runD (requestsH contexts target) script 167 aRequestsIO root alternate contexts target = withRecordedLogs (executeAdapter (backend root alternate) [] (requestsA contexts target) []) 168 cRequestsIO root alternate contexts target = withRecordedLogs (executeAdapter (backend root alternate) [] (E.normalize (requestsH contexts target) [] []) []) 169 dRequestsIO root alternate contexts target = withRecordedLogs (E.executeDStateIO (backend root alternate) [] (requestsH contexts target) [] [])