host: ring-core enablement part 2 — class tokens, vendored spork/http, reader-draining slurp
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).
This commit is contained in:
Yogthos
parent
7c26a182e8
commit
8212bc76f7
7 changed files with 679 additions and 31 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)"])
|
||||
|
|
|
|||
531
vendor/spork/http.janet
vendored
Normal file
531
vendor/spork/http.janet
vendored
Normal file
|
|
@ -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)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue