tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

e94897feaa8639a652f9dbe90fabfcd4d64590b4b69cf58141521ad43db06193.tri (4928B)

      1 !import base as B
      2 !import http as HTTP
      3 !import conversions as Convert
      4 !import arboricx_server as Store
      5 !import handlers as H
      6 !import io as HostIO
      7 !import io_storage as Storage
      8 !import handler_log as Log
      9 !import handler_artifacts as Artifacts
     10 !export request
     11 !export packageLookup
     12 !export stdoutLog
     13 !export writeLog
     14 !export router
     15 
     16 -- HTTP policy is separate from storage, logging, and the socket lifecycle.
     17 -- Outcomes carry a status beside the complete response so logging does not
     18 -- parse response bytes. Only completed application routes emit access events;
     19 -- parser/protocol rejections remain owned by the scoped HTTP transport.
     20 reply status bytes   = H.pure [status bytes]
     21 error status message = reply status (HTTP.errorResponse status message)
     22 
     23 load digest = do H.bind
     24   result <- Artifacts.load digest
     25   case result of
     26     ((t t), (bytes, t)) = reply 200 (HTTP.response 200 Store.bundleContentType bytes)
     27     (t, (["invalid-digest" message], t)) = error 400 message
     28     _ = error 404 "Artifact unavailable\n"
     29 
     30 publish bytes = do H.bind
     31   result <- Artifacts.publish bytes
     32   case result of
     33     ((t t), (digest, t)) = reply 201 (HTTP.createdResponse digest)
     34     _ = error 400 "Upload failed\n"
     35 
     36 -- Package storage is an explicit captured service: its identity is stable for
     37 -- this server. Contextual artifact overrides need no package-path authority.
     38 -- The HTTP parser supplies canonical target bytes, as in the original server.
     39 
     40 package lookup target = do H.bind
     41   result <- lookup target
     42   case result of
     43     ((t t), (bytes, t)) = reply 200 (HTTP.response 200 "application/vnd.arboricx.package-release" bytes)
     44     (t, (["invalid-package" message], t)) = error 400 message
     45     _ = error 404 "Package release not found"
     46 
     47 get lookup target = case Store.stripPrefix Store.packagePrefix target of
     48   (t suffix) = package lookup suffix
     49   _ = case Store.stripPrefix Store.bundleHashPrefix target of
     50     (t digest) = load digest
     51     _ = reply 404 HTTP.notFoundResponse
     52 
     53 route _      "GET"  "/"                 _ _    = reply 200 (HTTP.htmlResponse Store.htmlLandingPage)
     54 route _      "GET"  "/_arboricx/health" _ _    = reply 200 (HTTP.okResponse "OK\n")
     55 route lookup "GET"  target              _ _    = get lookup target
     56 route _      "POST" "/_arboricx/bundle" _ body = publish body
     57 route _      _      _                   _ _    = reply 404 HTTP.notFoundResponse
     58 
     59 request lookup method target headers body = H.label "registry-request" <| do H.bind
     60   outcome <- route lookup method target headers body
     61   case outcome of
     62     [status response] = do H.bind
     63       logged <- Log.info status
     64       case logged of
     65         ((t t), (t, t)) = H.pure response
     66         (t, (message, t)) = H.fail "application-failure" "logging" "emit" message
     67         _ = H.fail "application-failure" "logging" "emit" "Invalid logger reply"
     68     _ = H.fail "application-failure" "registry" "route" "Invalid route outcome"
     69 
     70 -- The captured package service remains independent of contextual artifact routes.
     71 packageLookup root limit target = case Store.packageTarget target of
     72   (t (name, version)) = H.liftIO (Storage.readBytes
     73     (Store.pathJoin (Store.pathJoin (Store.pathJoin root "packages") name) version) limit)
     74   _ = H.pure (B.err ["invalid-package" "Invalid package name/version"] t)
     75 
     76 -- Status-only ASCII logging. Ordinary write failures remain Results; publication
     77 -- precedes logging and remains visible if the logger fails.
     78 writeLog bytes = do HostIO.onOk
     79   writer <- HostIO.stdout
     80   HostIO.writeAll writer bytes
     81   HostIO.pure (B.ok t t)
     82 stdoutLog ["info" fields status] = case B.checkContract B.nat? status of
     83   ((t t), _) = H.liftIO (writeLog
     84     (B.append "registry status=" (B.append (Convert.showNumber status) "\n")))
     85   _ = H.pure (B.err "Invalid access-log status" t)
     86 stdoutLog _ = H.pure (B.err "Invalid access-log event" t)
     87 
     88 -- A supervised child contains request interpretation/logger failure without
     89 -- weakening native fail-fast semantics or retaining completed task tickets.
     90 -- Cancellation remains cancellation; a failure becomes a redacted HTTP response.
     91 -- The listener owns sockets and framing.
     92 router root limit sink method target headers body = HostIO.scope (_ : do HostIO.require
     93   spawned <- HostIO.spawn 1 1 [] (_ : H.runIO
     94     (request (packageLookup root limit) method target headers body
     95       |> Log.withContext [["method" method] ["target" target]]
     96       |> Artifacts.withFilesystem root limit
     97       |> Log.withSink sink))
     98   case spawned of
     99     [task ticket] = do HostIO.require
    100       outcome <- HostIO.join ticket
    101       case outcome of
    102         ["completed" response] = HostIO.pure response
    103         ["failed" _ _] = do HostIO.bind
    104           writeLog "registry request failed\n"
    105           HostIO.pure (HTTP.errorResponse 500 "Internal Server Error\n")
    106         ["cancelled" reason _] = HostIO.cancelled reason
    107         _ = HostIO.fail "Invalid registry task outcome"
    108     _ = HostIO.fail "Invalid registry spawn reply")