06944982576cd127727cf48915b1842237308ac7e1b517b3b21a8846fd577dc3.tri (7448B)
1 !import base as B 2 !import io as IO 3 !import http as HTTP 4 !import socket as Socket 5 !import conversions as Convert 6 !import arboricx_server as Store 7 !import handlers as H 8 !import io_v2 as V2 9 !import io_v2_storage as Storage 10 !import handler_log as Log 11 !import handler_artifacts as Artifacts 12 !export request 13 !export packageLookup 14 !export stdoutLog 15 !export router 16 !export serve 17 !export main 18 !export packageLookupV2 19 !export stdoutLogV2 20 !export writeLogV2 21 !export routerV2 22 23 -- HTTP policy is separate from storage, logging, and the socket lifecycle. 24 -- Outcomes carry a status beside the complete response so logging does not 25 -- parse response bytes. Only completed application routes emit access events; 26 -- parser/protocol rejections remain owned by HTTP.httpHandlerIO. 27 reply status bytes = H.pure [status bytes] 28 error status message = reply status (HTTP.errorResponse status message) 29 30 load digest = do H.bind 31 result <- Artifacts.load digest 32 case result of 33 ((t t), (bytes, t)) = reply 200 (HTTP.response 200 Store.bundleContentType bytes) 34 (t, (["invalid-digest" message], t)) = error 400 message 35 _ = error 404 "Artifact unavailable\n" 36 37 publish bytes = do H.bind 38 result <- Artifacts.publish bytes 39 case result of 40 ((t t), (digest, t)) = reply 201 (HTTP.createdResponse digest) 41 _ = error 400 "Upload failed\n" 42 43 -- Package storage is an explicit captured service: its identity is stable for 44 -- this server. Contextual artifact overrides need no package-path authority. 45 -- The HTTP parser supplies canonical target bytes, as in the original server. 46 packageLookup root target = case Store.packageTarget target of 47 (t (name, version)) = H.liftIO (IO.readFile 48 (Store.pathJoin (Store.pathJoin (Store.pathJoin root "packages") name) version)) 49 _ = H.pure (B.err ["invalid-package" "Invalid package name/version"] t) 50 51 package lookup target = do H.bind 52 result <- lookup target 53 case result of 54 ((t t), (bytes, t)) = reply 200 (HTTP.response 200 "application/vnd.arboricx.package-release" bytes) 55 (t, (["invalid-package" message], t)) = error 400 message 56 _ = error 404 "Package release not found" 57 58 get lookup target = case Store.stripPrefix Store.packagePrefix target of 59 (t suffix) = package lookup suffix 60 _ = case Store.stripPrefix Store.bundleHashPrefix target of 61 (t digest) = load digest 62 _ = reply 404 HTTP.notFoundResponse 63 64 route _ "GET" "/" _ _ = reply 200 (HTTP.htmlResponse Store.htmlLandingPage) 65 route _ "GET" "/_arboricx/health" _ _ = reply 200 (HTTP.okResponse "OK\n") 66 route lookup "GET" target _ _ = get lookup target 67 route _ "POST" "/_arboricx/bundle" _ body = publish body 68 route _ _ _ _ _ = reply 404 HTTP.notFoundResponse 69 70 request lookup method target headers body = H.label "registry-request" <| do H.bind 71 outcome <- route lookup method target headers body 72 case outcome of 73 [status response] = do H.bind 74 logged <- Log.info status 75 case logged of 76 ((t t), (t, t)) = H.pure response 77 (t, (message, t)) = H.fail "application-failure" "logging" "emit" message 78 _ = H.fail "application-failure" "logging" "emit" "Invalid logger reply" 79 _ = H.fail "application-failure" "registry" "route" "Invalid route outcome" 80 81 -- Do not interpolate untrusted target strings into a line-oriented log. 82 -- Context remains structured for replacement sinks. No shared IO.get/put state 83 -- is used: concurrent requests each install their own lexical context. 84 stdoutLog ["info" fields status] = case B.checkContract B.nat? status of 85 ((t t), _) = H.liftIO <| do IO.bind 86 written <- IO.putStr (B.append "registry status=" (B.append (Convert.showNumber status) "\n")) 87 case written of 88 t = IO.pure (B.ok t t) 89 (t, (message, t)) = IO.pure (B.err message t) 90 _ = IO.pure (B.err "Invalid host logging reply" t) 91 _ = H.pure (B.err "Invalid access-log status" t) 92 stdoutLog _ = H.pure (B.err "Invalid access-log event" t) 93 94 -- Interpretation failures (including failed logging) become redacted HTTP 500s. 95 -- They do not abort the listener or bypass ordinary respond-and-close behavior. 96 router root sink method target headers body = do IO.bind 97 result <- H.runIO (request (packageLookup root) method target headers body 98 |> Log.withContext [["method" method] ["target" target]] 99 |> Artifacts.withFilesystem root 100 |> Log.withSink sink) 101 case result of 102 ((t t), (response, t)) = IO.pure response 103 _ = do IO.bind 104 IO.putStr "registry request failed\n" 105 IO.pure (HTTP.errorResponse 500 "Internal Server Error\n") 106 107 -- Same ordinary Result cleanup/scheduling policy as Store.arboricxServer. 108 -- No stronger exception, cancellation, or shutdown guarantees are implied. 109 serve root sink address port = let 110 failed message = IO.pure (B.err message t) 111 opened server = let 112 rejected message = IO.finally (failed message) (Socket.closeSocket_ server) 113 ready _ = Socket.serveForever server (HTTP.httpHandlerIO (router root sink)) 114 in IO.onResult_ (do IO.onOk_ 115 Socket.bindSocket server address port 116 Socket.listen server 128) 117 rejected ready 118 in IO.onResult_ Socket.socket failed opened 119 120 -- Startup installs stable storage identity and an explicit logging sink. 121 -- Initialization/bind/listen failures still exit nonzero at the host boundary. 122 main = IO.io (IO.onResult_ 123 (do IO.onOk_ 124 Store.ensureStore "./store" 125 serve "./store" stdoutLog "0.0.0.0" 8080) 126 IO.abortIO 127 IO.pure) 128 129 -- The captured package service remains independent of contextual artifact routes. 130 packageLookupV2 root limit target = case Store.packageTarget target of 131 (t (name, version)) = H.liftIO (Storage.readBytes 132 (Store.pathJoin (Store.pathJoin (Store.pathJoin root "packages") name) version) limit) 133 _ = H.pure (B.err ["invalid-package" "Invalid package name/version"] t) 134 135 -- Status-only ASCII logging. Ordinary write failures remain Results; publication 136 -- precedes logging and is never rolled back when the logger fails. 137 writeLogV2 bytes = do V2.onOk 138 writer <- V2.stdout 139 V2.writeAll writer bytes 140 V2.pure (B.ok t t) 141 stdoutLogV2 ["info" fields status] = case B.checkContract B.nat? status of 142 ((t t), _) = H.liftIO (writeLogV2 143 (B.append "registry status=" (B.append (Convert.showNumber status) "\n"))) 144 _ = H.pure (B.err "Invalid access-log status" t) 145 stdoutLogV2 _ = H.pure (B.err "Invalid access-log event" t) 146 147 -- A supervised child contains request interpretation/logger failure without 148 -- weakening native fail-fast semantics or retaining completed task tickets. 149 -- Cancellation remains cancellation; a failure becomes a redacted HTTP response. 150 -- Socket ownership and framing are the listener's responsibility, not this router. 151 routerV2 root limit sink method target headers body = V2.scope (_ : do V2.require 152 spawned <- V2.spawn 1 1 [] (_ : H.runIOV2 153 (request (packageLookupV2 root limit) method target headers body 154 |> Log.withContext [["method" method] ["target" target]] 155 |> Artifacts.withFilesystemV2 root limit 156 |> Log.withSink sink)) 157 case spawned of 158 [task ticket] = do V2.require 159 outcome <- V2.join ticket 160 case outcome of 161 ["completed" response] = V2.pure response 162 ["failed" _ _] = do V2.bind 163 writeLogV2 "registry request failed\n" 164 V2.pure (HTTP.errorResponse 500 "Internal Server Error\n") 165 ["cancelled" reason _] = V2.cancelled reason 166 _ = V2.fail "Invalid registry task outcome" 167 _ = V2.fail "Invalid registry spawn reply")