deps: :jpm/module coordinates; the janet.* bridge autoloads jpm modules
The vendored spork/http is gone — jpm owns janet packages. In its place: - The janet.* bridge autoloads jpm-installed modules on first reference: janet.spork.http/server requires spork/http from the module path and caches its bindings (failures are negatively cached). Works for any module, in every mode, including inside net/server connection fibers. - deps.edn grows a :jpm/module coordinate: jolt-deps verifies the module is importable at resolve time, optionally running `jpm install` on the :jpm/install package once when it isn't, and otherwise fails with the install hint. Contributes no source roots. ring-app declares spork/http this way. Docs: README's interop section, docs/tools-deps.md (:jpm/module reference), and the ring-app README (including the jpm-version caveat for spork HEAD's .janet native sources, which older jpm rejects).
This commit is contained in:
Yogthos
parent
9aadbf42fd
commit
06e0899578
6 changed files with 106 additions and 556 deletions
13
README.md
13
README.md
|
|
@ -138,12 +138,13 @@ function expecting a tuple needs an explicit conversion. The `jolt.interop`,
|
||||||
|
|
||||||
This bridge is what makes networking (and everything else in Janet's stdlib)
|
This bridge is what makes networking (and everything else in Janet's stdlib)
|
||||||
available to ordinary Clojure — for example, `jolt.nrepl` (below) is plain
|
available to ordinary Clojure — for example, `jolt.nrepl` (below) is plain
|
||||||
Clojure over `janet.net/*`. Jolt also vendors
|
Clojure over `janet.net/*`. It also reaches any **jpm-installed module**:
|
||||||
[spork/http](https://janet-lang.org/spork/api/http.html) into its binary
|
the first reference to `janet.<module>/<name>` requires the module from the
|
||||||
(`vendor/spork/http.janet`, MIT), reachable as `janet.spork.http/*` — the
|
janet module path and caches its bindings — so after `jpm install spork`,
|
||||||
`jolt.http` client and the Ring adapter in
|
`janet.spork.http/*` just works. The `jolt.http` client and the Ring adapter
|
||||||
[examples/ring-app](https://github.com/jolt-lang/examples/tree/main/ring-app)
|
in [examples/ring-app](https://github.com/jolt-lang/examples/tree/main/ring-app)
|
||||||
are built on it. No `jpm install spork` required.
|
are built on spork/http this way, and a project can declare the requirement
|
||||||
|
in `deps.edn` with a `:jpm/module` coordinate (see docs/tools-deps.md).
|
||||||
|
|
||||||
```clojure
|
```clojure
|
||||||
(require '[jolt.interop :as j])
|
(require '[jolt.interop :as j])
|
||||||
|
|
|
||||||
|
|
@ -107,3 +107,23 @@ a regex feature like Unicode property classes (`\p{…}`).
|
||||||
- **Compiling deps into a binary image.** `uberscript` already produces a
|
- **Compiling deps into a binary image.** `uberscript` already produces a
|
||||||
standalone `.clj`; baking a project's dependencies directly into a custom
|
standalone `.clj`; baking a project's dependencies directly into a custom
|
||||||
executable image is a heavier variant that isn't implemented.
|
executable image is a heavier variant that isn't implemented.
|
||||||
|
|
||||||
|
## Janet dependencies: `:jpm/module`
|
||||||
|
|
||||||
|
A jolt project can depend on janet libraries. jpm owns their installation;
|
||||||
|
`deps.edn` declares the requirement and `jolt-deps` verifies it at resolve
|
||||||
|
time:
|
||||||
|
|
||||||
|
```clojure
|
||||||
|
:deps {janet/spork-http {:jpm/module "spork/http"
|
||||||
|
:jpm/install "spork"}}
|
||||||
|
```
|
||||||
|
|
||||||
|
- `:jpm/module` — the janet module path that must be importable.
|
||||||
|
- `:jpm/install` (optional) — the jpm package to install when it isn't;
|
||||||
|
`jolt-deps` runs `jpm install <name>` once, then re-checks. Without it the
|
||||||
|
resolve fails with the install hint.
|
||||||
|
|
||||||
|
A `:jpm/module` dep contributes no source roots. At runtime the `janet.*`
|
||||||
|
interop bridge autoloads the module on first reference
|
||||||
|
(`janet.spork.http/server`, …), so nothing else is needed.
|
||||||
|
|
|
||||||
|
|
@ -73,6 +73,26 @@
|
||||||
(get x :name))
|
(get x :name))
|
||||||
(string x)))
|
(string x)))
|
||||||
|
|
||||||
|
|
||||||
|
(defn- ensure-jpm-dep
|
||||||
|
"A :jpm/module dep declares a janet module installed through jpm (e.g.
|
||||||
|
spork/http). jolt-deps doesn't manage janet packages — jpm does — so this
|
||||||
|
just verifies the module is importable, optionally running `jpm install
|
||||||
|
<:jpm/install>` once when it isn't, and fails with the install hint
|
||||||
|
otherwise. Contributes no source roots; the janet.* bridge autoloads the
|
||||||
|
module at first use."
|
||||||
|
[lib spec]
|
||||||
|
(def mod (get spec :jpm/module))
|
||||||
|
(defn importable? [] ((protect (require mod)) 0))
|
||||||
|
(unless (importable?)
|
||||||
|
(when-let [pkg (get spec :jpm/install)]
|
||||||
|
(eprintf "jolt-deps: %s: jpm module %s missing — running `jpm install %s`"
|
||||||
|
(sym-name lib) mod pkg)
|
||||||
|
(os/execute ["jpm" "install" pkg] :p))
|
||||||
|
(unless (importable?)
|
||||||
|
(errorf "%s: janet module %s is not importable. Install it with `jpm install %s` (jolt-deps leaves janet packages to jpm)."
|
||||||
|
(sym-name lib) mod (or (get spec :jpm/install) mod)))))
|
||||||
|
|
||||||
(defn- merge-by-name [a b] # union of symbol-keyed dictionaries, b wins
|
(defn- merge-by-name [a b] # union of symbol-keyed dictionaries, b wins
|
||||||
(def out @{})
|
(def out @{})
|
||||||
(each m [a b] (when (dictionary? m) (eachp [k v] m (put out (sym-name k) v))))
|
(each m [a b] (when (dictionary? m) (eachp [k v] m (put out (sym-name k) v))))
|
||||||
|
|
@ -165,7 +185,8 @@
|
||||||
(and (deep= (get a :local/root) (get b :local/root))
|
(and (deep= (get a :local/root) (get b :local/root))
|
||||||
(deep= (get a :git/url) (get b :git/url))
|
(deep= (get a :git/url) (get b :git/url))
|
||||||
(deep= (get a :git/sha) (get b :git/sha))
|
(deep= (get a :git/sha) (get b :git/sha))
|
||||||
(deep= (get a :git/tag) (get b :git/tag))))
|
(deep= (get a :git/tag) (get b :git/tag))
|
||||||
|
(deep= (get a :jpm/module) (get b :jpm/module))))
|
||||||
(def queue @[])
|
(def queue @[])
|
||||||
(defn discover [lib spec base-dir]
|
(defn discover [lib spec base-dir]
|
||||||
(def k (sym-name lib))
|
(def k (sym-name lib))
|
||||||
|
|
@ -175,6 +196,8 @@
|
||||||
k (coord-str prev) (coord-str spec)))
|
k (coord-str prev) (coord-str spec)))
|
||||||
(do
|
(do
|
||||||
(put seen k spec)
|
(put seen k spec)
|
||||||
|
(when (and (dictionary? spec) (get spec :jpm/module))
|
||||||
|
(ensure-jpm-dep lib spec))
|
||||||
(def dir
|
(def dir
|
||||||
(cond
|
(cond
|
||||||
(and (dictionary? spec) (get spec :git/url))
|
(and (dictionary? spec) (get spec :git/url))
|
||||||
|
|
|
||||||
|
|
@ -13,20 +13,30 @@
|
||||||
# the janet/* interop bridge falls back to it inside env-less fibers.
|
# the janet/* interop bridge falls back to it inside env-less fibers.
|
||||||
(def- module-load-env (fiber/getenv (fiber/current)))
|
(def- module-load-env (fiber/getenv (fiber/current)))
|
||||||
|
|
||||||
# spork/http, VENDORED (vendor/spork/http.janet, MIT) so the jolt binary
|
# jpm-module autoload: a janet.<module>/<name> reference whose module isn't
|
||||||
# carries its own HTTP support: a direct import marshals the fns into the
|
# in the env is satisfied by requiring it from the jpm module path on first
|
||||||
# baked image — no runtime require, no env-bridge marshal hazards. Reaches
|
# use — (janet.spork.http/server ...) just works when spork is installed,
|
||||||
# the jolt layer as janet.spork.http/* via janet-bridge-extras, the second
|
# and the same goes for any jpm module. Loaded bindings are cached here
|
||||||
# lookup the janet.* bridge consults after the fiber env. The Ring adapter
|
# (and failures negatively cached, so a missing module errors fast).
|
||||||
# (examples/ring-app) and jolt.http build on it.
|
(def- janet-bridge-extras @{})
|
||||||
(import ../../vendor/spork/http :as vendored-spork-http)
|
(def- janet-bridge-failed @{})
|
||||||
(def- janet-bridge-extras
|
(defn- bridge-autoload
|
||||||
(let [t @{} pfx "vendored-spork-http/"]
|
"jname is spork.http/server-shaped: require spork/http, cache its public
|
||||||
(eachp [sym entry] (curenv)
|
bindings under the dotted prefix, return the one asked for (nil when the
|
||||||
(when (and (symbol? sym) (string/has-prefix? pfx sym) (table? entry))
|
module is missing or has no such binding)."
|
||||||
(put t (string "spork.http/" (string/slice sym (length pfx)))
|
[jname]
|
||||||
(get entry :value))))
|
(def slash (string/find "/" jname))
|
||||||
t))
|
(when slash
|
||||||
|
(def mod-ns (string/slice jname 0 slash))
|
||||||
|
(unless (get janet-bridge-failed mod-ns)
|
||||||
|
(def mod-path (string/replace-all "." "/" mod-ns))
|
||||||
|
(def r (protect (require mod-path)))
|
||||||
|
(if (r 0)
|
||||||
|
(eachp [sym entry] (r 1)
|
||||||
|
(when (and (symbol? sym) (table? entry) (not (get entry :private)))
|
||||||
|
(put janet-bridge-extras (string mod-ns "/" sym) (get entry :value))))
|
||||||
|
(put janet-bridge-failed mod-ns true))))
|
||||||
|
(in janet-bridge-extras jname))
|
||||||
|
|
||||||
(defn- sym-name?
|
(defn- sym-name?
|
||||||
[sym-s name-str]
|
[sym-s name-str]
|
||||||
|
|
@ -644,15 +654,16 @@
|
||||||
(let [jname (if (= ns "janet") name (string (string/slice ns 6) "/" name))
|
(let [jname (if (= ns "janet") name (string (string/slice ns 6) "/" name))
|
||||||
# worker fibers may carry no env (fiber/new without :e inherit)
|
# worker fibers may carry no env (fiber/new without :e inherit)
|
||||||
# — fall back to the env captured at module load
|
# — fall back to the env captured at module load
|
||||||
# three-step resolution: the runtime fiber's env (when it
|
# four-step resolution: the runtime fiber's env (when it
|
||||||
# has one), the evaluator's module env (worker/connection
|
# has one), the evaluator's module env (worker/connection
|
||||||
# fibers carry a foreign or empty env — net/server handler
|
# fibers carry a foreign or empty env — net/server handler
|
||||||
# fibers resolve janet/struct through here), then the
|
# fibers resolve janet/struct through here), the autoload
|
||||||
# vendored-module registry (spork.http/*, marshaled fns)
|
# cache, then a jpm-module require on first miss
|
||||||
entry (or (when-let [fe (fiber/getenv (fiber/current))]
|
entry (or (when-let [fe (fiber/getenv (fiber/current))]
|
||||||
(in fe (symbol jname)))
|
(in fe (symbol jname)))
|
||||||
(in module-load-env (symbol jname))
|
(in module-load-env (symbol jname))
|
||||||
(in janet-bridge-extras jname))]
|
(in janet-bridge-extras jname)
|
||||||
|
(bridge-autoload jname))]
|
||||||
(if (not (nil? entry))
|
(if (not (nil? entry))
|
||||||
(if (table? entry) (entry :value) entry)
|
(if (table? entry) (entry :value) entry)
|
||||||
(error (string "Unable to resolve Janet symbol: " jname))))
|
(error (string "Unable to resolve Janet symbol: " jname))))
|
||||||
|
|
|
||||||
|
|
@ -125,6 +125,32 @@
|
||||||
)
|
)
|
||||||
(rmrf gbase)
|
(rmrf gbase)
|
||||||
|
|
||||||
|
# --- :jpm/module deps: janet libraries installed through jpm -----------------
|
||||||
|
# Verification only (jpm owns installation): an importable module passes and
|
||||||
|
# contributes no roots; a missing one errors with the install hint. jpm/pm is
|
||||||
|
# always importable wherever jpm itself runs (CI included).
|
||||||
|
(do
|
||||||
|
(def jbase (string (or (os/getenv "TMPDIR") "/tmp") "/jolt-deps-jpm-" (os/time)))
|
||||||
|
(mkdirs (string jbase "/src"))
|
||||||
|
(spit (string jbase "/deps.edn")
|
||||||
|
`{:paths ["src"] :deps {janet/jpm-pm {:jpm/module "jpm/pm"}}}`)
|
||||||
|
(def cwd (os/cwd))
|
||||||
|
(os/cd jbase)
|
||||||
|
(def roots (deps/resolve-deps "deps.edn" (string jbase "/jpm_tree")))
|
||||||
|
(os/cd cwd)
|
||||||
|
(check "jpm module dep resolves" true (not (nil? roots)))
|
||||||
|
(check "jpm module contributes no roots" 1 (length roots))
|
||||||
|
|
||||||
|
(spit (string jbase "/deps.edn")
|
||||||
|
`{:paths ["src"] :deps {janet/nope {:jpm/module "no/such-module-xyz"}}}`)
|
||||||
|
(os/cd jbase)
|
||||||
|
(def r (protect (deps/resolve-deps "deps.edn" (string jbase "/jpm_tree"))))
|
||||||
|
(os/cd cwd)
|
||||||
|
(check "missing jpm module errors" false (r 0))
|
||||||
|
(check "error carries the install hint" true
|
||||||
|
(not (nil? (string/find "jpm install" (string (r 1))))))
|
||||||
|
(rmrf jbase))
|
||||||
|
|
||||||
(if (> fails 0)
|
(if (> fails 0)
|
||||||
(error (string "deps-resolve-test: " fails " failing check(s)"))
|
(error (string "deps-resolve-test: " fails " failing check(s)"))
|
||||||
(print "\nAll deps-resolve tests passed!"))
|
(print "\nAll deps-resolve tests passed!"))
|
||||||
|
|
|
||||||
531
vendor/spork/http.janet
vendored
531
vendor/spork/http.janet
vendored
|
|
@ -1,531 +0,0 @@
|
||||||
# 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