httpEffects.tri (2785B)
1 !import prelude * 2 !import io * 3 !import native_math as Nat 4 !export * 5 6 -- Test-only, fuel-bounded interpreter. It never calls the host IO driver. 7 -- Scripts specify each primitive tag and its reply; complete payloads are traced. Bind/Pure are 8 -- interpreted normally; unexpected, missing or leftover effects cannot pass an 9 -- independent expected final tree. Trace records attempted effects in order. 10 finished label value trace script = pair label (pair value (pair (reverse trace) script)) 11 12 drive 0 action _ script trace = finished "fuel" action trace script 13 drive fuel (0, value) [] script trace = finished "done" value trace script 14 drive fuel (0, value) [next | stack] script trace = drive (Nat.subtract fuel 1) (next value) stack script trace 15 drive fuel (1, (action, next)) stack script trace = drive (Nat.subtract fuel 1) action (pair next stack) script trace 16 drive _ action{2, _} _ script trace = finished "abort" action (pair action trace) script 17 drive fuel action{tag, _} stack [(expected, reply) | script] trace = (let 18 matched ^expected = drive (Nat.subtract fuel 1) (pure reply) stack script (pair action trace) 19 matched _ = finished "unexpected" action (pair action trace) (pair (pair expected reply) script) 20 in matched tag) 21 drive _ action _ script trace = finished "unscripted" action (pair action trace) script 22 23 run action script = drive 512 action [] script [] 24 body function headers initial script = run (function 7 headers initial) script 25 exact function count initial script = run (function 7 count initial) script 26 more function count reversed script = run (function 7 count reversed) script 27 receive function delimiter limit script = run (function 7 delimiter limit) script 28 respond function response script = run (function 7 response) script 29 30 renderHeaders [(name, value) | rest] = append name (append ":" (append value (append ";" (renderHeaders rest)))) 31 renderHeaders _ = "" 32 route method target headers body = (append "HTTP/1.1 200 OK\r\nX: test\r\n\r\n" 33 (append method (append "|" (append target (append "|" (append (renderHeaders headers) (append "|" body))))))) 34 -- Private scripted primitive 999 records all router arguments before replying. 35 -- The following pure result is the router's byte response, not a Result wrapper. 36 routeIO method target headers body = (do bind 37 pair 999 (pair method (pair target (pair headers body))) 38 pure (route method target headers body)) 39 routeAbort _ _ _ _ = abortIO "router aborted" 40 handler function script = run (function route 7 []) script 41 handlerIO function script = run (function routeIO 7 []) script 42 handlerAbort function script = run (function routeAbort 7 []) script 43 44 bindProbe script = (run (do bind 45 first <- pure "x" 46 reply <- pair 999 first 47 pure reply) script) 48 fuelProbe script = drive 0 (pure 0) [] script []