From 8212bc76f79f067db2fbaecf5495912c162c9eb4 Mon Sep 17 00:00:00 2001 From: Yogthos Date: Thu, 11 Jun 2026 19:50:52 -0400 Subject: [PATCH] =?UTF-8?q?host:=20ring-core=20enablement=20part=202=20?= =?UTF-8?q?=E2=80=94=20class=20tokens,=20vendored=20spork/http,=20reader-d?= =?UTF-8?q?raining=20slurp?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Class names evaluate to their canonical class-name STRINGS (the same values class returns), so a (defmulti m (comp class :body)) matches (defmethod m String ...) — ring.util.request dispatches exactly this way. Constructor sugar and the new special form resolve the actual ctor from the registry when given a token; dispatch-only names (InputStream, File, ISeq, ...) are interned for defmethod position. nil is a legal multimethod dispatch value now (sentinel-keyed: janet tables drop nil keys) — ring keys body-string's no-body case on it. spork/http is VENDORED (vendor/spork/http.janet, MIT) and baked into the image, reaching the jolt layer as janet.spork.http/* through the janet.* bridge — whose lookup is now a chain (runtime fiber env, module env, the vendored registry), which also fixes janet/* resolution inside net/server connection fibers (they carry a foreign env). jolt.http is rewritten over the spork client (its old net/request never existed; also fixes its own get shadowing clojure.core/get). Also: slurp accepts opts and DRAINS reader shims (ring middleware slurps request bodies), clojure.string/replace takes fn replacements with Clojure's match-or-groups argument, .indexOf int needles are char codes, .getBytes on the String surface, and ^bytes-style return hints on param vectors parse (the fn macro unwraps the with-meta form). Suite steady at 4715/5348; conformance x3 green; deps-conformance medley + cuerdas green (the stuartsierra/dependency failure predates this change). --- src/jolt/api.janet | 6 +- src/jolt/core.janet | 12 +- src/jolt/evaluator.janet | 100 ++++-- src/jolt/jolt/http.clj | 23 +- src/jolt/regex.janet | 15 +- test/spec/host-interop-spec.janet | 23 ++ vendor/spork/http.janet | 531 ++++++++++++++++++++++++++++++ 7 files changed, 679 insertions(+), 31 deletions(-) create mode 100644 vendor/spork/http.janet diff --git a/src/jolt/api.janet b/src/jolt/api.janet index c4c4ee5..08851da 100644 --- a/src/jolt/api.janet +++ b/src/jolt/api.janet @@ -281,7 +281,11 @@ # non-ctx value, so check the shape, not just the throw. (when (and (r 0) (ctx? (r 1))) (r 1))))] - (or loaded + (or (when loaded + # per-PROCESS wiring an image restore skips: the renderer's + # print-method hook lives in module state, not the marshaled ctx + (install-print-method-cb! loaded) + loaded) (let [ctx (init opts) tmp (string path "." (os/getpid) ".tmp")] # Atomic publish so concurrent cold starts never see a torn image. diff --git a/src/jolt/core.janet b/src/jolt/core.janet index a9d8e36..50cf35b 100644 --- a/src/jolt/core.janet +++ b/src/jolt/core.janet @@ -1729,7 +1729,17 @@ (defn core-current-time-ms [] (* 1000 (os/clock :monotonic))) # Host IO (host-classified in the spec): path-based slurp/spit, *out* flush. -(defn core-slurp [path] (string (slurp path))) +# Opts (:encoding ...) are accepted and ignored — everything is UTF-8 here. +# Reader shims (java.io.StringReader / PushbackReader / anything carrying +# :s + :pos) DRAIN instead of opening a file: Ring middleware slurps request +# bodies, and the jolt Ring adapter hands those over as StringReaders. +(defn core-slurp [src & opts] + (cond + (and (table? src) (string? (get src :s)) (number? (get src :pos))) + (let [s (src :s) p (src :pos)] + (put src :pos (length s)) + (string/slice s p)) + (string (slurp src)))) (defn core-spit [path content & opts] (def append? (do (var a false) (var i 0) diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index b4c6af0..56f0da4 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -13,17 +13,20 @@ # the janet/* interop bridge falls back to it inside env-less fibers. (def- module-load-env (fiber/getenv (fiber/current))) -# spork/http (pure-janet, jpm-installed) reaches the jolt layer as -# janet.spork.http/* through the janet.* bridge below — the Ring adapter -# (examples/ring-app) builds its server on it. SOFT: jolt works without -# spork; only code touching janet.spork.http/* needs it installed. -(let [r (protect (require "spork/http"))] - (when (r 0) - (eachp [sym entry] (r 1) - (when (and (symbol? sym) (table? entry)) - # root-env: the bridge resolves against the RUNTIME fiber env (which - # protos to the root env), not this module's env - (put root-env (symbol "spork.http/" sym) entry))))) +# spork/http, VENDORED (vendor/spork/http.janet, MIT) so the jolt binary +# carries its own HTTP support: a direct import marshals the fns into the +# baked image — no runtime require, no env-bridge marshal hazards. Reaches +# the jolt layer as janet.spork.http/* via janet-bridge-extras, the second +# lookup the janet.* bridge consults after the fiber env. The Ring adapter +# (examples/ring-app) and jolt.http build on it. +(import ../../vendor/spork/http :as vendored-spork-http) +(def- janet-bridge-extras + (let [t @{} pfx "vendored-spork-http/"] + (eachp [sym entry] (curenv) + (when (and (symbol? sym) (string/has-prefix? pfx sym) (table? entry)) + (put t (string "spork.http/" (string/slice sym (length pfx))) + (get entry :value)))) + t)) (defn- sym-name? [sym-s name-str] @@ -513,14 +516,46 @@ # ctor fns are interned as clojure.core vars at init (install-stateful-fns!). (def class-ctors @{}) (defn register-class-ctor! [nm f] (put class-ctors nm f)) +# Class names evaluate to their CANONICAL NAME STRING — the same value +# core-class returns — so (defmethod m String ...) keys match a +# (defmulti m (comp class :body)) dispatch (ring.util.request does this). +# `new` resolves the actual constructor from class-ctors by short name. +(def- class-canonical-names + @{"String" "java.lang.String" "Number" "java.lang.Number" + "Boolean" "java.lang.Boolean" "Long" "java.lang.Long" + "Integer" "java.lang.Integer" "Double" "java.lang.Double" + "InputStream" "java.io.InputStream" "OutputStream" "java.io.OutputStream" + "File" "java.io.File" "Reader" "java.io.Reader" "Writer" "java.io.Writer" + "ISeq" "clojure.lang.ISeq" "Keyword" "clojure.lang.Keyword" + "Symbol" "clojure.lang.Symbol" "MapEntry" "clojure.lang.MapEntry" + "StringReader" "java.io.StringReader" "StringWriter" "java.io.StringWriter" + "StringBuilder" "java.lang.StringBuilder" + "StringTokenizer" "java.util.StringTokenizer" + "Charset" "java.nio.charset.Charset" "Base64" "java.util.Base64"}) +(defn- class-value-for + "The value a class-name symbol evaluates to: its canonical name string." + [nm] + (or (get class-canonical-names nm) + # qualified already, or unknown: the name itself is the token + nm)) +(defn- ctor-for-class-token + "Constructor fn for a class token (a canonical-name string): try the full + name, then the short name after the last dot." + [tok] + (or (in class-ctors tok) + (let [parts (string/split "." tok)] + (in class-ctors (last parts))))) # java.lang.String method surface for clj-compat interop: (.toLowerCase s), # (.indexOf s x), ... — the methods portable cljc libraries actually call. # Case mapping is ASCII (the whole engine is byte-based); indexOf returns -1 # on miss, as on the JVM. (defn- str-needle [x] - (if (and (struct? x) (= :jolt/char (get x :jolt/type))) - (string/from-bytes (x :ch)) + (cond + (and (struct? x) (= :jolt/char (get x :jolt/type))) (string/from-bytes (x :ch)) + # (.indexOf s 61): an int needle is a char CODE on the JVM, not its decimal + # text (ring-codec splits k=v pairs this way) + (number? x) (string/from-bytes (math/trunc x)) (string x))) # java.lang.Number surface (ring-codec: (.byteValue (Integer/valueOf s 16))). (def- number-methods @@ -609,16 +644,23 @@ (let [jname (if (= ns "janet") name (string (string/slice ns 6) "/" name)) # worker fibers may carry no env (fiber/new without :e inherit) # — fall back to the env captured at module load - entry (in (or (fiber/getenv (fiber/current)) module-load-env) - (symbol jname))] + # three-step resolution: the runtime fiber's env (when it + # has one), the evaluator's module env (worker/connection + # fibers carry a foreign or empty env — net/server handler + # fibers resolve janet/struct through here), then the + # vendored-module registry (spork.http/*, marshaled fns) + entry (or (when-let [fe (fiber/getenv (fiber/current))] + (in fe (symbol jname))) + (in module-load-env (symbol jname)) + (in janet-bridge-extras jname))] (if (not (nil? entry)) (if (table? entry) (entry :value) entry) (error (string "Unable to resolve Janet symbol: " jname)))) # syntax-quote ns-qualifies bare class names inside macros # (selmer.util/StringBuilder); class names never belong to an ns — # fall back to the constructor / statics shims before giving up. - (if-let [ctor (in class-ctors name)] - ctor + (if (or (in class-ctors name) (get class-canonical-names name)) + (class-value-for name) (error (string "Unable to resolve symbol: " ns "/" name)))))) # Use :jolt/not-found sentinel to distinguish nil binding from absent binding (let [local (get bindings name :jolt/not-found-1) @@ -1090,7 +1132,8 @@ (def v-box @[nil]) (def mm-fn (fn [& args] - (let [dv (apply dispatch-fn args) + (let [dv* (apply dispatch-fn args) + dv (if (nil? dv*) :jolt/nil-sentinel dv*) method (get methods dv)] (if method (apply method args) @@ -1173,7 +1216,9 @@ (put v :jolt/methods @{}) v))) (def methods (or (get mm-var :jolt/methods) (let [m @{}] (put mm-var :jolt/methods m) m))) - (put methods dispatch-val impl) + # nil is a legal dispatch value (ring's body-string keys a method on it); + # janet tables can't hold nil keys, so it rides the sentinel + (put methods (if (nil? dispatch-val) :jolt/nil-sentinel dispatch-val) impl) (let [dc (get mm-var :jolt/dispatch-cache)] (when dc (each k (keys dc) (put dc k nil)))) mm-var) @@ -1330,6 +1375,7 @@ mm-var)) (ns-intern core "remove-method-setup" (fn [mm-sym dval] + (def dval (if (nil? dval) :jolt/nil-sentinel dval)) (def mm-var (mm-var-of mm-sym false)) (when mm-var (let [methods (get mm-var :jolt/methods)] @@ -1352,6 +1398,7 @@ (or (and mm-var (get mm-var :jolt/prefers)) {}))) (ns-intern core "get-method-setup" (fn [mm-sym dval] + (def dval (if (nil? dval) :jolt/nil-sentinel dval)) (def mm-var (mm-var-of mm-sym false)) (when mm-var (let [methods (get mm-var :jolt/methods)] @@ -1444,8 +1491,13 @@ # read, with-in-str, and line-seq are Clojure over these (core/50-io.clj). # The loader's registered source roots (the closest thing to a classpath) — # io/resource searches these for relative resource paths. - # registered constructor shims (StringReader., StringBuilder., ...) - (eachp [nm f] class-ctors (ns-intern core nm f)) + # registered constructor shims: the NAME evaluates to the canonical class + # string (so class-dispatch defmultis match); `new` finds the ctor fn. + (eachp [nm f] class-ctors (ns-intern core nm (class-value-for nm))) + # dispatch-only type names (no ctor): InputStream, File, ISeq, ... + (eachp [nm canon] class-canonical-names + (unless (or (in class-ctors nm) (ns-find core nm)) + (ns-intern core nm canon))) (ns-intern core "__source-roots" (fn [] (tuple ;(get (ctx :env) :source-paths)))) (ns-intern core "__stdin-read-line" @@ -2011,7 +2063,8 @@ # compiles as a plain (do …); no special-form arm. "new" (let [type-sym (in form 1) args (map |(eval-form ctx bindings $) (tuple/slice form 2)) - ctor (eval-form ctx bindings type-sym)] + ctor (eval-form ctx bindings type-sym) + ctor (if (string? ctor) (or (ctor-for-class-token ctor) ctor) ctor)] (apply ctor args)) "." (let [target (eval-form ctx bindings (in form 1)) member-raw (in form 2) @@ -2126,6 +2179,9 @@ (let [type-name (string/slice sym-name 0 (- (length sym-name) 1)) type-sym {:jolt/type :symbol :ns (first-form :ns) :name type-name} ctor (eval-form ctx bindings type-sym) + # class names evaluate to canonical-name STRINGS now; the + # constructor itself comes from the ctor registry + ctor (if (string? ctor) (or (ctor-for-class-token ctor) ctor) ctor) args (map |(eval-form ctx bindings $) (tuple/slice form 1))] (apply ctor args)) (let [v (resolve-var ctx bindings first-form)] diff --git a/src/jolt/jolt/http.clj b/src/jolt/jolt/http.clj index cbbceb1..2eb61ec 100644 --- a/src/jolt/jolt/http.clj +++ b/src/jolt/jolt/http.clj @@ -1,12 +1,25 @@ ; Jolt Standard Library: jolt.http -; HTTP client using Janet's net/ module. +; HTTP client over spork/http (janet.spork.http/*; requires `jpm install spork`). +; Responses come back as {:status int :headers map :body string}. + +(defn- response->map [r] + ;; clojure.core/get explicitly: this ns defines an http `get` that shadows it + {:status (clojure.core/get r :status) + :body (str (or (janet.spork.http/read-body r) "")) + :headers (reduce (fn [m kv] (assoc m (str (nth kv 0)) (str (nth kv 1)))) + {} + (janet/pairs (or (clojure.core/get r :headers) (janet/struct))))}) + +(defn- header-struct [headers] + (apply janet/struct + (mapcat (fn [kv] [(str (key kv)) (str (val kv))]) (seq (or headers {}))))) (defn get [url & {:keys [headers]}] - (let [result (net/request url :get headers {})] - {:status (result :status) :body (result :body) :headers (result :headers)})) + (response->map + (janet.spork.http/request "GET" url :headers (header-struct headers)))) (defn post [url body & {:keys [headers]}] - (let [result (net/request url :post headers body)] - {:status (result :status) :body (result :body) :headers (result :headers)})) + (response->map + (janet.spork.http/request "POST" url :body body :headers (header-struct headers)))) diff --git a/src/jolt/regex.janet b/src/jolt/regex.janet index 3d1e8dc..7180c14 100644 --- a/src/jolt/regex.janet +++ b/src/jolt/regex.janet @@ -414,6 +414,17 @@ (do (buffer/push-string buf (string/from-bytes c)) (++ i))))) (string buf)) +(defn- replacement-for + "One match's replacement text. A string replacement gets $N expansion; a FN + replacement (Clojure: fn of the match — string, or [whole g1 ...] when the + pattern has groups) is called and its result used literally." + [replacement g ngroups] + (cond + (string? replacement) (expand-replacement replacement g) + (or (function? replacement) (cfunction? replacement)) + (string (replacement (groups->result g ngroups))) + (string replacement))) + (defn re-replace-all [re s replacement] (def re (re-pattern re)) (def buf @"") (var pos 0) (var last 0) @@ -421,7 +432,7 @@ (def g (match-at re s pos)) (if (and g (> (length (in g 0)) 0)) (do (buffer/push-string buf (string/slice s last pos)) - (buffer/push-string buf (if (string? replacement) (expand-replacement replacement g) replacement)) + (buffer/push-string buf (replacement-for replacement g (re :ngroups))) (set pos (+ pos (length (in g 0)))) (set last pos)) (++ pos))) @@ -439,6 +450,6 @@ (if done (let [[p g] done] (string (string/slice s 0 p) - (if (string? replacement) (expand-replacement replacement g) replacement) + (replacement-for replacement g (re :ngroups)) (string/slice s (+ p (length (in g 0)))))) s)) diff --git a/test/spec/host-interop-spec.janet b/test/spec/host-interop-spec.janet index 952bd64..e78faf4 100644 --- a/test/spec/host-interop-spec.janet +++ b/test/spec/host-interop-spec.janet @@ -163,3 +163,26 @@ "(do (defprotocol Ps (ps [x])) (extend-protocol Ps Map (ps [m] :map) Object (ps [o] :obj)) (ps (sorted-map 1 2)))"] ["reduce over reified IReduceInit" "42" "(reduce + 0 (reify clojure.lang.IReduceInit (reduce [_ f init] (f (f init 40) 2))))"]) + +# ring-core enablement, part 2: class-name symbols evaluate to canonical +# class-name strings (so class-dispatch defmultis match), ctor sugar still +# constructs, type-hinted param vectors parse, slurp drains reader shims, +# str/replace takes fn replacements, and int needles are char codes. +(defspec "host-interop / class tokens & readers" + ["class name evaluates to canonical string" "\"java.lang.String\"" "String"] + ["dispatch-only class name" "\"java.io.InputStream\"" "InputStream"] + ["(class x) matches the token" "true" "(= String (class \"abc\"))"] + ["defmulti on class dispatches" ":str" + "(do (defmulti cm (fn [x] (class x))) (defmethod cm String [x] :str) (cm \"a\"))"] + ["defmethod on nil dispatch value" ":nil" + "(do (defmulti cn (fn [x] (class x))) (defmethod cn nil [x] :nil) (defmethod cn String [x] :str) (cn nil))"] + ["ctor sugar still constructs" "\"x\"" "(.toString (StringBuilder. \"x\"))"] + ["return-hinted defn parses" "7" "(do (defn- hb ^bytes [b] b) (hb 7))"] + ["hinted multi-arity parses" ":two" "((fn ([x] :one) (^String [x y] :two)) 1 2)"] + ["slurp drains a StringReader" "\"a=1\"" "(slurp (StringReader. \"a=1\"))"] + ["slurp accepts :encoding opts" "\"b\"" "(slurp (StringReader. \"b\") :encoding \"UTF-8\")"] + ["replace with fn replacement is literal" "\"$0\"" + "(do (require (quote [clojure.string :as s9])) (s9/replace \"x\" #\".\" (fn [m] \"$0\")))"] + ["replace fn gets group vector" "\"v=k\"" + "(do (require (quote [clojure.string :as s9])) (s9/replace \"k=v\" #\"(\\w+)=(\\w+)\" (fn [[_ k v]] (str v \"=\" k))))"] + ["indexOf int needle is a char code" "1" "(.indexOf \"a=b\" 61)"]) diff --git a/vendor/spork/http.janet b/vendor/spork/http.janet new file mode 100644 index 0000000..7349776 --- /dev/null +++ b/vendor/spork/http.janet @@ -0,0 +1,531 @@ +# Vendored from janet-lang/spork (MIT license) @ 3bdcf58 +# for the janet.spork.http/* bridge — see evaluator.janet. Do not edit here. +### +### http.janet +### +### Pure Janet HTTP/1.1 parser, client, and server. +### + +(def- chunk-size (* 16 4096)) + +(defn- pre-pop + "Remove n bytes from front of buffer" + [buf n] + (buffer/blit buf buf 0 n) + (buffer/popn buf n)) + +(def- http-grammar + ~{:request-status (* :method :ws :path :ws "HTTP/1." :d :any-ws :rn) + :response-status (* "HTTP/1." :d :ws (/ ':d+ ,scan-number) + :ws '(some :printable) :rn) + :ws (some (set " \t")) + :any-ws (any (set " \t")) + :rn "\r\n" + :method '(some (range "AZ")) + :path-chr (range "az" "AZ" "09" "!!" "$9" ":;" "==" "?@" "~~" "__") + :path '(some :path-chr) + :printable (range "\x20~" "\t\t") + :headers (* (any :header) :rn) + # lower case header names since http headers are case-insensitive + :header-name (/ '(some (range "\x219" ";~")) ,string/ascii-lower) + :header-value '(any :printable) + :header (* :header-name ":" :any-ws :header-value :rn)}) + +(def request-peg + "PEG for parsing HTTP requests" + (peg/compile + (table/to-struct + (merge {:main ~(* :request-status :headers)} + http-grammar)))) + +(def response-peg + "PEG for parsing HTTP responses" + (peg/compile + (table/to-struct (merge + {:main ~(* :response-status :headers)} + http-grammar)))) + +(defn- accum-key-values + "Accumulate key-value pairs based on arg index (even = key, odd = value) into a table and combine + duplicate keys into arrays of values (rather than overwriting). Used for both query strings and headers." + [& args] + (def tab @{}) + (loop [i :range [0 (length args) 2] + :let [k (get args i) v (get args (+ 1 i))]] + (if-let [item (in tab k)] + (if (array? item) + (array/push item v) + (put tab k @[item v])) + (put tab k v))) + tab) + +(defn- read-header + "Read an HTTP header from a stream." + [conn buf peg key1 key2] + (var head nil) + (var last-index 0) + (forever + (when-let [end (string/find "\r\n\r\n" buf last-index)] + (set head + (if-let [matches (peg/match peg buf)] + (let [[a b] matches + headers (accum-key-values ;(array/remove matches 0 2))] + @{:headers headers + :connection conn + :buffer (pre-pop buf (+ 4 end)) + :head-size (+ 4 end) + key1 a + key2 b}) + :error)) + (break)) + (set last-index (max 0 (- (length buf) 4))) + (unless (:read conn chunk-size buf) + (set head :error) + (break))) + head) + + +(def query-string-grammar + "Grammar that parses a query string (sans url path and ? character) and returns a table." + (peg/compile + ~{:qchar (+ (* "%" (/ (number (* :h :h) 16) ,string/from-bytes)) (* "+" (constant " "))) + :kchar (+ :qchar (* (not (set "&=;")) '1)) + :vchar (+ :qchar (* (not (set "&;")) '1)) + :key (accumulate (some :kchar)) + :value (accumulate (any :vchar)) + :entry (* :key (+ (* "=" :value) (constant true)) (+ (set ";&") -1)) + :main (/ (any :entry) ,accum-key-values)})) + +(defn read-request + ``Read an HTTP request header from a connection. Returns a table with the following keys: + * `:headers` - table mapping header names to header values. Header names are lowercase. + * `:connection` - the connection stream for the header. + * `:buffer` - the buffer instance that may contain extra bytes. + * `:head-size` - the number of bytes used by the header. + * `:method` - the HTTP method used. + * `:path` - the path of the resource requested. + + The following keys are also present, but omitted if the user passes a truthy parameter to `no-query`. + * `:route` - path of the resource requested without query string. + * `:query-string` - segment of HTTP path after first ? character. + * `:query` - the query string parsed into a table. Supports a single string value + for every string key, and any query parameters that aren't given a value are mapped to true. + + Note that data is read in chunks and any data after the header terminator is + stored in `:buffer`.`` + [conn buf &opt no-query] + (def head (read-header conn buf request-peg :method :path)) + (if (= :error head) (break head)) + + # Parse query string separately + (unless no-query + (def fullpath (get head :path)) + (def qloc (string/find "?" fullpath)) + (def path (if qloc (string/slice fullpath 0 qloc) fullpath)) + (def qs (if qloc (string/slice fullpath (inc qloc)) nil)) + (put head :route path) + (put head :query-string qs) + (when qs + (when-let [m (peg/match query-string-grammar qs)] + (put head :query (first m))))) + + head) + +(defn read-response + ``Read an HTTP response header from a connection. Returns a table with the following keys: + * `:headers` - table mapping header names to header values. Header names are lowercase. + * `:connection` - the connection stream for the header. + * `:buffer` - the buffer instance that may contain extra bytes. + * `:head-size` - the number of bytes used by the header. + * `:status` - the HTTP status code. + * `:message` - the HTTP status message. + + Note that data is read in chunks and any data after the header terminator is + stored in `:buffer`.`` + [conn buf] + (read-header conn buf response-peg :status :message)) + +(def status-messages + "Mapping of HTTP status codes to their status message." + {100 "Continue" + 101 "Switching Protocols" + 102 "Processing" + 200 "OK" + 201 "Created" + 202 "Accepted" + 203 "Non-Authoritative Information" + 204 "No Content" + 205 "Reset Content" + 206 "Partial Content" + 207 "Multi-Status" + 208 "Already Reported" + 226 "IM Used" + 300 "Multiple Choices" + 301 "Moved Permanently" + 302 "Found" + 303 "See Other" + 304 "Not Modified" + 305 "Use Proxy" + 307 "Temporary Redirect" + 308 "Permanent Redirect" + 400 "Bad Request" + 401 "Unauthorized" + 402 "Payment Required" + 403 "Forbidden" + 404 "Not Found" + 405 "Method Not Allowed" + 406 "Not Acceptable" + 407 "Proxy Authentication Required" + 408 "Request Timeout" + 409 "Conflict" + 410 "Gone" + 411 "Length Required" + 412 "Precondition Failed" + 413 "Payload Too Large" + 414 "URI Too Long" + 415 "Unsupported Media Type" + 416 "Range Not Satisfiable" + 417 "Expectation Failed" + 421 "Misdirected Request" + 422 "Unprocessable Entity" + 423 "Locked" + 424 "Failed Dependency" + 426 "Upgrade Required" + 428 "Precondition Required" + 429 "Too Many Requests" + 431 "Request Header Fields Too Large" + 451 "Unavailable For Legal Reasons" + 500 "Internal Server Error" + 501 "Not Implemented" + 502 "Bad Gateway" + 503 "Service Unavailable" + 504 "Gateway Timeout" + 505 "HTTP Version Not Supported" + 506 "Variant Also Negotiates" + 507 "Insufficient Storage" + 508 "Loop Detected" + 510 "Not Extended" + 511 "Network Authentication Required"}) + +(defn- write-body + "Write the body of an HTTP request, adding Content-Length header + or Transfer-Encoding: chunked" + [conn buf body] + (cond + (nil? body) + (do + (buffer/push buf "\r\n") + (:write conn buf)) + + (bytes? body) + (do + (buffer/format buf "Content-Length: %d\r\n\r\n%V" (length body) body) + (:write conn buf)) + + # default - iterate chunks + (do + (buffer/format buf "Transfer-Encoding: chunked\r\n\r\n") + (each chunk body + (assert (bytes? chunk) "expected byte chunk") + (buffer/format buf "%x\r\n%V\r\n" (length chunk) chunk) + (:write conn buf) + (buffer/clear buf)) + (buffer/format buf "0\r\n\r\n") + (:write conn buf))) + (buffer/clear buf)) + +(defn- read-until + "Read single bytes from connection into buffer until the provided byte + sequence is found within it. The buffer need not be empty. Returns the number + of bytes from the start of the buffer until the substring." + [conn buf needle &opt start-index] + (default start-index 0) + (when-let [pos (peg/find needle buf start-index)] + (break pos)) + (prompt :exit + (forever + (unless (:read conn 1 buf) + (error "end of stream")) + (when-let [pos (peg/find needle buf start-index)] + (return :exit pos))))) + +(defn read-body + "Given a request, read the HTTP body from the connection. Returns the body as a buffer. + If the request has no body, returns nil." + [req] + (when-let [body (in req :body)] (break body)) + (def headers (in req :headers)) + + # In place content + (when-let [cl (in headers "content-length")] + (def {:buffer buf + :connection conn} req) + (def content-length (scan-number cl)) + (def remaining (- content-length (length buf))) + (when (pos? remaining) + (:chunk conn remaining buf)) + (put req :body buf) + (break buf)) + + # event stream aka SSE + (when (-?>> (in headers "content-type") + (string/has-prefix? "text/event-stream")) + (def {:buffer buf + :connection conn} req) + (read-until conn buf "\n\n") + (put req :body buf) + (break buf)) + + # Chunked encoding + # TODO: The specification can have multiple transfer encodings so this + # precise string matching may not work for every case. + (when (= (in headers "transfer-encoding") "chunked") + (def {:buffer buf + :connection conn} req) + (def body (buffer/new chunk-size)) + (var i 0) + (forever + (def chunk-length-end-pos (read-until conn buf "\r\n" i)) + (var chunk-length (scan-number (slice buf i chunk-length-end-pos) 16)) + (when (zero? chunk-length) + (read-until conn buf "\r\n" (+ 2 chunk-length-end-pos)) + (break)) + # If there's any data already read, blit that over first. + (let [leftover-start (+ chunk-length-end-pos 2) + leftover (- (length buf) leftover-start) + blit-amount (min leftover chunk-length)] # prevent overreading + (unless (zero? blit-amount) + (buffer/blit body buf -1 leftover-start (+ leftover-start blit-amount)) + (-= chunk-length blit-amount)) + (set i (+ leftover-start blit-amount))) + (if (= i (length buf)) + # Basic case: the buffer has been exhausted and hereonout we can read + # from the socket directly. + (do + (:chunk conn chunk-length body) + (unless (:read conn 2 buf) # trailing CRLF (not included in chunk length proper) + (error "end of stream")) + # Clear buffer out. We ain't gonna need it no more. + (buffer/clear buf) + (set i 0)) + # Alternatively, the pre-read data in the buffer was plentiful and we + # just managed to copy an entire chunk out of it. Just increment past + # the CRLF, if it's not already there, and proceed to loop again. + (set i (+ (read-until conn buf "\r\n" i) 2)))) + (put req :body body) + (break body)) + + # no body, just return nil + nil) + +(defn send-response + ``Send an HTTP response over a connection. Will automatically use chunked + encoding if body is not a byte sequence. `response` should be a table + with the following keys: + + * `:headers` - optional headers to write + * `:status` - integer status code to write + * `:body` - optional byte sequence or iterable (for chunked body) + for returning contents. The iterable can be lazy, i.e. for streaming + data.`` + [conn response &opt buf] + (default buf @"") + (def status (get response :status 200)) + (def message (in status-messages status)) + (buffer/format buf "HTTP/1.1 %d %s\r\n" status message) + (def headers (get response :headers {})) + + (eachp [k v] headers + # Values can be lists when representing duplicate headers (e.g.: multiple "Set-Cookie" entries) + (if (or (tuple? v) (array? v)) + (each ve v (buffer/format buf "%V: %V\r\n" k ve)) + (buffer/format buf "%V: %V\r\n" k v))) + + (write-body conn buf (in response :body))) + +### +### Server Middleware +### + +(defn- bytes-to-mw + [b] + (fn mw [&] {:status 200 :body b})) + +(defn middleware + "Coerce any type to http middleware" + [x] + (case (type x) + :function x + :number (let [msg (get status-messages x)] + (assert msg (string "unknown http status code when making middleware: " x)) + (fn mw [&] {:status x :body msg})) + :string (bytes-to-mw x) + :buffer (bytes-to-mw x) + (fn mw [&] x))) + +(defn router + "Creates a router middleware. A router will dispatch to different routes based on + the URL path." + [routes] + (fn router-mw [req] + (def r (or + (get routes (get req :route)) + (get routes :default))) + (if r ((middleware r) req) {:status 404 :body "Not Found"}))) + +(defn logger + "Creates a logging middleware. The logger middleware prints URL route, return status, and elapsed request time." + [nextmw] + (fn logger-mw [req] + (def {:path path + :method method} req) + (def start-clock (os/clock)) + (def ret (nextmw req)) + (def end-clock (os/clock)) + (def elapsed (string/format "%.3f" (* 1000 (- end-clock start-clock)))) + (def status (or (get ret :status) 200)) + (print method " " status " " path " elapsed " elapsed "ms") + (flush) + ret)) + +(def cookie-grammar + "Grammar to parse a cookie header to a series of keys and values." + (peg/compile + {:content '(some (if-not (set "=;") 1)) + :eql "=" + :sep '(between 1 2 (set "; ")) + :main '(some (* (<- :content) :eql (<- :content) (? :sep)))})) + +(defn cookies + "Parses cookies into the table under :cookies key" + [nextmw] + (fn cookie-mw [req] + (-> req + (put :cookies + (or (-?>> [:headers "cookie"] + (get-in req) + (peg/match cookie-grammar) + (apply table)) + {})) + nextmw))) + +### +### Server boilerplate +### + +(defn server-handler + ``A simple connection handler for an HTTP server. + When a connection is accepted. Call this with a handler + function to handle the connect. The handler will be called + with one argument, the request table, which will contain the + following keys: + * `:head-size` - number of bytes in the http header. + * `:headers` - table mapping header names to header values. + * `:connection` - the connection stream for the header. + * `:buffer` - the buffer instance that may contain extra bytes. + * `:path` - HTTP path. + * `:method` - HTTP method, as a string.`` + [conn handler] + (def handler (middleware handler)) + (defer (:close conn) + + # Get request header + (def buf (buffer/new chunk-size)) + (def req (read-request conn buf)) + + # Handle bad request + (when (= :error req) + (send-response conn {:status 400} (buffer/clear buf)) + (break)) + + # Add some extra keys to the request + (put req :connection conn) + + # Do something with request header + (def response (handler req)) + + # Now send back response + (send-response conn response @""))) + +(defn server + "Makes a simple http server. By default it binds to 0.0.0.0:8000, + returns a new server stream. + Simply wraps http/server-handler with a net/server." + [handler &opt host port] + (default host "0.0.0.0") + (default port 8000) + (defn new-handler + [conn] + (server-handler conn handler)) + (net/server host port new-handler)) + +### +### HTTP Client +### + +(def- url-peg-source + ~{:main (* (+ :https :http) :fqdn :port :path) + :https (* (constant "https") "https://") + :http (* (constant "http") "http://") + :fqdn '(some (range "az" "AZ" "09" ".." "--")) + :port (+ (* ":" ':d+) (constant nil)) + :path-chr (range "az" "AZ" "09" "!!" "$9" ":;" "==" "?@" "~~" "__") + :path (+ '(some :path-chr) (constant "/"))}) + +(def url-grammar + "Grammar to parse a URL into scheme, domain, port, and path. Supports + both http:// and https:// protocols. Returns [scheme host port path]." + (peg/compile url-peg-source)) + +(defn request + ``Make an HTTP request to a server. + Returns a table containing response information. + * `:head-size` - number of bytes in the http header + * `:headers` - table mapping header names to header values. Header names are lowercase. + * `:connection` - the connection stream for the header. + * `:buffer` - the buffer instance that may contain extra bytes. + * `:status` - HTTP status code as an integer. + * `:message` - HTTP status message. + * `:body` - Bytes of the response body. + + Options: + * `:body` - Request body content + * `:headers` - Request headers table + * `:stream-factory` - Function to create connection stream. Defaults to net/connect. + Signature: (stream-factory host port stream-opts) + * `:stream-opts` - Options table passed to stream-factory`` + [method url &keys + {:body body + :headers headers + :stream-factory stream-factory + :stream-opts stream-opts}] + (def x (peg/match url-grammar url)) + (assert x (string "invalid url: " url)) + (def [scheme host raw-port path] x) + # Default port based on scheme + (def port (or raw-port (if (= scheme "https") "443" "80"))) + (def buf @"") + (buffer/format buf "%s %s HTTP/1.1\r\nHost: %s:%s\r\n" method path host port) + (when headers + (eachp [k v] headers + (buffer/format buf "%s: %s\r\n" k v))) + + # Use custom stream-factory or default to net/connect + (let [make-conn (or stream-factory net/connect) + conn (if stream-opts + (make-conn host port stream-opts) + (make-conn host port))] + (with [conn conn] + + # Make request + (write-body conn buf body) + + # Parse response pure janet + (def res (read-response conn buf)) + (when (= :error res) (error res)) + # HEAD responses have no body per HTTP spec, skip read-body + (unless (= method "HEAD") + (read-body res)) + + # TODO - handle redirects with Location header + res)))