substrate-lang 0.10.1 → 0.10.2

package/build/compiler/program

@@ -4,11 +4,11 @@ syntax.32f3e40b61c7@0+0
 path.5a6286472cd4@0+0
 fs.01b8aab4a9a8@0+0
 reader.694b03770bf0@0+0
-roots.cefd10e93684@0+0
+roots.2f1ad1a79459@0+0
 running.0d25dbaec018@0+0
 core.f2defb75e00b@0+0
 ops.515b5e05f646@0+0
-checker.4dd4556dd421@0+0
+checker.1d67e1d4e91a@0+0
 leb128.15d814b7b4f2@0+0
 binary.2d43b43d1600@0+0
 serialize.b0d82f3d63d2@0+0
@@ -16,6 +16,6 @@ compile.5d8f6407af2a@0+0
 sha256.a6c32b04d799@0+0
 link.b826ea7c8f17@0+0
 macros.b269e0c42784@0+0
-expander.967ce443d379@0+0
+expander.34110a31a949@0+0
 prune.406215c3e4f8@0+0
-main.4fc52f204d54@0+0
+main.ca9b5089c24d@0+0

package/build/sub/program

@@ -3,46 +3,46 @@ process.7106571fa723@0+0
 path.5a6286472cd4@0+0
 path.6891ffea73ca@0+0
 fs.01b8aab4a9a8@0+0
-common.1edc613607a0@0+0
+common.7617940db2dc@0+0
 grants.c54776c0d7e3@0+0
 writer.00b7802cbe39@0+0
 syntax.32f3e40b61c7@0+0
 reader.694b03770bf0@0+0
-roots.cefd10e93684@0+0
+roots.2f1ad1a79459@0+0
 read.0b93933d62a2@0+0
-manifest.ef317480deb0@0+0
+manifest.da52a88c7af7@0+0
 git.dc4c0e757ebe@0+0
-files.ad0469fdf6fa@0+0
+files.5ae9d3cebeca@0+0
 sha256.a6c32b04d799@0+0
-hash.660682e4f491@0+0
-store.a24d7a25daa6@0+0
-map.f455cca6a42a@0+0
+hash.c57c141b4862@0+0
+store.048c77bb124d@0+0
+map.5c8084999550@0+0
 env.e5451da6e747@0+0
 events.bf5473ebf220@0+0
-build.459c5b9412bd@0+0
+build.eef7dfa467ec@0+0
 pack.e02836264f6a@0+0
-site.ae3913b0b0f4@0+0
-site.1732b58ec0e8@0+0
-fetch.7790d4943758@0+0
-stream.126e3bd5d626@0+0
-worker.762a9d642af0@0+0
 deflate.23f7c4679260@0+0
 inflate.59bb61f14001@0+0
 gzip.16e372eda1cf@0+0
+site.47fd989be8fb@0+0
+site.c908b1f6db12@0+0
+fetch.7790d4943758@0+0
+stream.126e3bd5d626@0+0
+worker.762a9d642af0@0+0
 tar.2a633861e654@0+0
-fetch.96b2d10f025e@0+0
-doc.ef9965d5d402@0+0
+fetch.3367ff4f88c0@0+0
+doc.dab689b811ca@0+0
 html.e9ed37f34977@0+0
-html.a23126eb949a@0+0
-text.1bc90482bd43@0+0
-root.f10a4906f460@0+0
-doc.0775df5de6fe@0+0
+html.803f73c35c4a@0+0
+text.b214933a4984@0+0
+root.78253db36643@0+0
+doc.92d6d82d99c1@0+0
 timer.f35eb62ae446@0+0
 chromium.3d5818f2707d@0+0
-test.9bd59c73f65e@0+0
+test.b529bf52ba3e@0+0
 utf8.e7216bd054e1@0+0
 json.55590d2f518a@0+0
 sha512.c24a792d7891@0+0
 base64.a26bdcf60a2d@0+0
-upgrade.39ee449b00d5@0+0
-sub.2e3092140706@0+0
+upgrade.7ec5651ed2e9@0+0
+sub.a618f89f2ec8@0+0

package/package.json

@@ -1,6 +1,6 @@
 {
   "name": "substrate-lang",
-  "version": "0.10.1",
+  "version": "0.10.2",
   "description": "A Lisp for writing WebAssembly, and the substrate command that builds, runs and tests it",
   "license": "MIT",
   "repository": {

package/std/http/server.sub

@@ -22,10 +22,10 @@
 
 (provide http-server http-request http-check http-hook http-serve! http-server-close! http-server-shutdown!
          http-stop-on-signals! http-hook! http-unhook! http-log-access http-request-header http-request-server
-         http-request-gone? http-request-address http-request-https? http-request-deadline! http-add-header!
-         http-respond! http-header! http-length! http-write! http-send! http-send-text! http-send-stream! http-finish!
-         http-take! http-read-body! http-answer-text! http-redirect! http-trapped http-connect! http-connection-feed!
-         http-connection-close!)
+         http-request-gone? http-request-address http-request-https? http-accepts-gzip? http-request-deadline!
+         http-add-header! http-respond! http-header! http-length! http-write! http-send! http-send-text!
+         http-send-stream! http-finish! http-take! http-read-body! http-answer-text! http-redirect! http-trapped
+         http-connect! http-connection-feed! http-connection-close!)
 
 (const default-body-limit u32 1048576)
 (const most-dropped u64 262144)
@@ -630,8 +630,8 @@
     (unless (or (== (@ q i) #\.) (== (@ q i) #\0)) (return #f)))
   #t)
 
-;; accepts-gzip? reads Accept-Encoding: gzip, or else *, with a weight above 0.
-(define (accepts-gzip? [r (ptr http-request)]) -> bool
+;; http-accepts-gzip? reads Accept-Encoding: gzip, or else *, with a weight above 0.
+(define (http-accepts-gzip? [r (ptr http-request)]) -> bool
   (let ([v (http-request-header r "accept-encoding")] [i u32 0] [gzip i32 -1] [any i32 -1])
     (while (< i (-> v length))
       (let ([end i] [k i])
@@ -653,7 +653,7 @@
 
 (define (zip? [r (ptr http-request)]) -> bool
   (and (> (-> (http-request-server r) compress) 0) (-> r compressible) (not (-> r encoded)) (has-body? r)
-       (!= (-> r status) 206) (accepts-gzip? r)))
+       (!= (-> r status) 206) (http-accepts-gzip? r)))
 
 ;; One deflater for every whole answer and event, each done before the next begins; zipped holds its output.
 (define shared deflater)

package/std/http/static.sub

@@ -1,15 +1,17 @@
 ;; Files: http-send-file! answers with a file under the root, as Flask's send_from_directory does, and http-static! with
 ;; the file at the request's path, a directory's index.html, or a redirect adding a final slash. Answers carry
 ;; Last-Modified and an ETag, are 304 or 412 as preconditions require, hold one range when asked, and have Cache-Control
-;; no-cache unless cache gives another value for the path. A part that is . or .., or that starts with a dot other than
-;; .well-known, is not found. An empty root is the current directory.
+;; no-cache unless cache gives another value for the path. When a file has a gzipped copy beside it, named name.gz, a
+;; request that takes gzip gets the copy. A part that is . or .., or that starts with a dot other than .well-known, is
+;; not found. An empty root is the current directory. http-hashed-cache caches a path for a year when one of its
+;; directories is named by 16 hex digits, as in the sites that substrate site --release writes.
 (require-unqualified host/fs)
 (require-unqualified "http.sub")
 (require-unqualified "server.sub")
 (require-unqualified "conditional.sub")
 (require-unqualified "url.sub")
 
-(provide http-files http-static! http-send-file!)
+(provide http-files http-static! http-send-file! http-hashed-cache)
 
 (struct http-files [root string] [cache (fn (string) -> string)])
 
@@ -185,53 +187,87 @@
   (let ([value (if (== (-> files cache) 0) "" ((-> files cache) path))])
     (if (== (-> value length) 0) "no-cache" value)))
 
-(define (head-of! [r (ptr http-request)] [name string] [partial bool] [s (ptr span)] [size i64])
+(define (hex-digit? [c u8]) -> bool (or (and (>= c #\0) (<= c #\9)) (and (>= c #\a) (<= c #\f))))
+
+(define (hash-part? [part string]) -> bool
+  (when (!= (-> part length) 16) (return #f))
+  (for ([i u32 0]) (< i 16) (+= i 1) (unless (hex-digit? (@ part i)) (return #f)))
+  #t)
+
+(define (http-hashed-cache [path string]) -> string
+  (let ([start u32 0])
+    (for ([i u32 0]) (< i (-> path length)) (+= i 1)
+      (when (== (@ path i) #\/)
+        (when (hash-part? (slice path start i)) (return "public, max-age=31536000, immutable"))
+        (set! start (+ i 1))))
+    ""))
+
+(struct zipped [name string] [info fs-info] [found bool])
+
+(define (zipped! [z (ptr zipped)] [name string])
+  (let ([b (make-buffer)])
+    (buffer-add-string! (& b) name)
+    (buffer-add-string! (& b) ".gz")
+    (set! (-> z name) (buffer-string (& b)))
+    (set! (-> z found) (and (fs-stat (-> z name) (& (-> z info)) 0) (== (-> z info kind) fs-file)))))
+
+(define (head-of! [r (ptr http-request)] [name string] [encoded bool] [partial bool] [s (ptr span)] [size i64])
   (http-respond! r (if partial 206 200))
   (when partial (content-range! r s size))
-  (http-header! r "content-type" (content-type name)))
+  (http-header! r "content-type" (content-type name))
+  (when encoded (http-header! r "content-encoding" "gzip")))
 
 (define (failed! [r (ptr http-request)]) (http-answer-text! r 500 "cannot read the file"))
 
-(define (body! [r (ptr http-request)] [name string] [partial bool] [s (ptr span)] [size i64])
+(define (body! [r (ptr http-request)] [name string] [file string] [encoded bool] [partial bool] [s (ptr span)]
+               [size i64])
   (let ([n (- (-> s end) (-> s start))])
     (cond [(== (-> r method) "HEAD")
-           (head-of! r name partial s size)
+           (head-of! r name encoded partial s size)
            (http-length! r n)
            (http-finish! r)]
           [(<= size whole)
            (let ([f (slice u8)])
-             (if (not (fs-read-file name (& f) 0))
+             (if (not (fs-read-file file (& f) 0))
                  (failed! r)
                  (begin
-                   (head-of! r name partial s size)
+                   (head-of! r name encoded partial s size)
                    (http-send! r (slice f (cast u32 (-> s start)) (cast u32 (-> s end))))
                    (free (-> f items)))))]
           [else
-           (let ([h u32 0] [file u32 0])
-             (if (not (and (fs-open-file name fs-read-flag (& h) 0) (fs-read-stream h (-> s start) 0 (& file) 0)))
+           (let ([h u32 0] [stream u32 0])
+             (if (not (and (fs-open-file file fs-read-flag (& h) 0) (fs-read-stream h (-> s start) 0 (& stream) 0)))
                  (failed! r)
                  (begin
-                   (head-of! r name partial s size)
-                   (http-send-stream! r file n))))])))
+                   (head-of! r name encoded partial s size)
+                   (http-send-stream! r stream n))))])))
 
-;; send! answers with the file at name, whose path under the root is path.
+;; send! answers with the file at name, whose path under the root is path, or with its gzipped copy. When there is a
+;; copy, send! adds Vary itself and marks the answer encoded. The server then neither compresses it nor adds Vary again.
 (define (send! [r (ptr http-request)] [files (ptr http-files)] [name string] [path string] [info (ptr fs-info)])
-  (let ([size (-> info size)] [tag (make-buffer)] [s span] [partial i32 0])
-    (span! (& s) 0 size)
-    (etag! (& tag) info)
-    (http-add-header! r "cache-control" (cache-of files path))
-    (unless (http-conditional! r (buffer-string (& tag)) (-> info modified))
-      (set! partial (ranges! r size (buffer-string (& tag)) (-> info modified) (& s)))
-      (if (< partial 0)
-          (let ([all span])
-            (span! (& all) -1 0)
-            (http-respond! r 416)
-            (content-range! r (& all) size)
-            (http-header! r "content-type" "text/plain; charset=utf-8")
-            (http-send-text! r "range not satisfiable"))
-          (begin
-            (set! (-> r ranges) #t)
-            (body! r name (> partial 0) (& s) size))))
+  (let* ([z zipped] [tag (make-buffer)] [s span] [partial i32 0])
+    (zipped! (& z) name)
+    (let* ([encoded (and (-> z found) (http-accepts-gzip? r))] [sent (if encoded (& (-> z info)) info)]
+           [size (-> sent size)])
+      (span! (& s) 0 size)
+      (etag! (& tag) sent)
+      (http-add-header! r "cache-control" (cache-of files path))
+      (when (-> z found)
+        (http-add-header! r "vary" "accept-encoding")
+        (set! (-> r encoded) #t))
+      (unless (http-conditional! r (buffer-string (& tag)) (-> sent modified))
+        (set! partial (if encoded 0 (ranges! r size (buffer-string (& tag)) (-> sent modified) (& s))))
+        (if (< partial 0)
+            (let ([all span])
+              (span! (& all) -1 0)
+              (http-respond! r 416)
+              (content-range! r (& all) size)
+              (http-header! r "content-type" "text/plain; charset=utf-8")
+              (http-send-text! r "range not satisfiable"))
+            (begin
+              (set! (-> r ranges) (not encoded))
+              (body! r name (if encoded (-> z name) name) encoded (> partial 0) (& s) size)))))
+    (free (-> (-> z name) bytes))
     (buffer-free! (& tag))))
 
 (define (not-found! [r (ptr http-request)]) (http-answer-text! r 404 "not found"))

package/std/package/manifest.sub

@@ -6,7 +6,8 @@
 ;; The substrate clause gives the oldest substrate the package builds with. (substrate "0.10.0") also takes later 0.10
 ;; releases, and (substrate "1.2.0") takes later 1.x releases. Every clause but version is optional, and so are a path
 ;; dependency's hash and a site's html and files. A files part gives the program the files matching its paths, from its
-;; from directory, under the directory it names; * matches any text in a name and ** any directories. (browser) says
+;; from directory, under the directory it names; * matches any text in a name and ** any directories. (from name)
+;; takes them from the directory that name stands for in a require: a dependency, std, compiler or host. (browser) says
 ;; that the package's tests open browsers with std/test/browser.sub.
 (require-unqualified "read.sub")
 (require-unqualified host/fs)
@@ -16,7 +17,7 @@
          package-name? full-hash? version-before? version-compatible?)
 
 (struct dependency [name string] [path string] [url string] [hash string] [line u32] [column u32])
-(struct site-files [dir string] [from string] [patterns (slice string)])
+(struct site-files [dir string] [from string] [root string] [patterns (slice string)])
 (struct declared-site [name string] [program string] [html string] [files (slice site-files)] [line u32] [column u32])
 (struct manifest [name string] [version string] [major u32] [substrate string] [exports (slice string)]
                  [dependencies (slice dependency)] [tests (slice string)]
@@ -267,10 +268,14 @@
 (define (files-of [file string] [c (ptr data)] [a (ptr arena)] [f (ptr site-files)] [err (ptr buffer)]) -> bool
   (let* ([items (items-of c)] [k u32 2] [n u32 0] [ps (new a string (-> items length))])
     (set! (-> f from) "")
+    (set! (-> f root) "")
     (unless (and (>= (-> items length) 3) (string-of (& (@ items 1)) (& (-> f dir))) (starts? (-> f dir) "/"))
       (return (failed-at! err file c files-form)))
     (when (list-of? (& (@ items 2)) "from" 2)
-      (unless (string-of (& (@ (items-of (& (@ items 2))) 1)) (& (-> f from))) (return (failed-at! err file c files-form)))
+      (let ([given (& (@ (items-of (& (@ items 2))) 1))])
+        (set! (-> f root) (symbol-of given))
+        (unless (or (> (-> f root length) 0) (string-of given (& (-> f from))))
+          (return (failed-at! err file c files-form))))
       (set! k 3))
     (for ([i u32 k]) (< i (-> items length)) (+= i 1)
       (unless (and (string-of (& (@ items i)) (& (@ ps n))) (> (-> (@ ps n) length) 0))
@@ -284,7 +289,7 @@
   "a site is (name \"program.sub\" (html \"file.html\") (files \"/dir\" \"path\" ...) ...), and the parts after the program are optional")
 
 (define files-form string
-  "a site's files are (files \"/dir\" (from \"directory\") \"path\" ...), where from is optional, and in a path * matches any text in a name and ** matches any directories")
+  "a site's files are (files \"/dir\" (from \"directory\") \"path\" ...) or (files \"/dir\" (from name) \"path\" ...), where from is optional, and in a path * matches any text in a name and ** matches any directories")
 
 (define (module-name? [s string]) -> bool
   (let ([start u32 0])

package/std/package/site.sub

@@ -1,13 +1,20 @@
-;; Sites: directories that a static server can serve. A site holds index.html, the web host, the program, the assets
-;; listed in assets.list, and files.pack with the files the site declares. site-write! writes all of it except a
-;; program given as a file, which the caller builds into the site's program directory, as cmd/sub/site.sub and
-;; std/test/browser.sub do.
+;; Sites: directories that a static server can serve. A site holds index.html, the web host, the program, and
+;; files.pack with the files the site declares. It also holds the assets from beside the program, and assets.list lists
+;; them. The program reads the declared files as files and loads the assets by URL. site-write! writes all of it except
+;; a program given as a file. The caller builds that program into the site's program directory, as cmd/sub/site.sub and
+;; std/test/browser.sub do. Files from a name need the program's module map in compiler/roots, so both callers load it
+;; first. site-release! makes a written site a release (below).
+(require-unqualified compiler/macros)
+(require-unqualified compiler/roots)
 (require-unqualified host/fs)
+(require-unqualified std/crypto/sha256)
+(require-unqualified std/compress/deflate)
+(require-unqualified std/compress/gzip)
 (require-unqualified "manifest.sub")
 (require-unqualified "pack.sub")
 (require-unqualified "path.sub")
 
-(provide site-plan site-named? site-declared site-write!)
+(provide site-plan site-named? site-declared site-write! site-release!)
 
 (struct site-plan [name string] [program string] [html string] [files (slice site-files)] [base string])
 
@@ -36,6 +43,19 @@
 (define (written! [path string] [b (slice u8)])
   (let ([why error]) (unless (fs-write-file path b (& why)) (throw site-failed (error-text (& why))))))
 
+(define (strings-of [b (ptr buffer)]) -> (slice string)
+  (slice (cast (ptr string) (-> b bytes)) (/ (-> b length) (sizeof string))))
+
+(define (added! [b (ptr buffer)] [s string]) (buffer-add! b (slice (cast (ptr u8) (& s)) (sizeof string))))
+
+(define (sorted! [ps (slice string)])
+  (for ([i u32 1]) (< i (-> ps length)) (+= i 1)
+    (let ([s (@ ps i)] [j i])
+      (while (and (> j 0) (< s (@ ps (- j 1))))
+        (set! (@ ps j) (@ ps (- j 1)))
+        (-= j 1))
+      (set! (@ ps j) s))))
+
 (define (copy-tree! [from string] [to string] [base string] [files (ptr buffer)])
   (let ([names (names-in from)])
     (made! to)
@@ -110,9 +130,19 @@
         (set! start (+ i 1))))
     (slice (cast (ptr string) (-> out bytes)) (/ (-> out length) (sizeof string)))))
 
+(define (root-directory [p (ptr site-plan)] [name string]) -> string
+  (let ([dir datum '#f])
+    (try (set! dir (named-directory (string->datum (-> p program)) (string->datum name)))
+         [catch compile-error (message blamed loc) (set! dir '#f)])
+    (unless (string? dir)
+      (throw site-failed (joined (joined "site: (from " name) ") names nothing that the site's program can require")))
+    (datum->string dir)))
+
 (define (packed! [p (ptr site-plan)] [g (ptr site-files)] [files (ptr buffer)])
-  (let ([base (if (== (-> g from length) 0) (-> p base) (resolved-path (-> p base) (-> g from)))] [found (make-buffer)]
-        [err (make-buffer)])
+  (let ([base (cond [(> (-> g root length) 0) (root-directory p (-> g root))]
+                    [(== (-> g from length) 0) (-> p base)]
+                    [else (resolved-path (-> p base) (-> g from))])]
+        [found (make-buffer)] [err (make-buffer)])
     (for ([i u32 0]) (< i (-> g patterns length)) (+= i 1)
       (let ([before (-> found length)])
         (matched! base "" (parts-of (@ (-> g patterns) i)) 0 (& found))
@@ -143,14 +173,9 @@
     (let ([assets (joined-path (parent-of (-> p program)) "assets")] [found (make-buffer)])
       (when (== (kind-of assets) fs-directory)
         (copy-tree! assets (joined-path out "assets") "assets" (& found))
-        (let ([ps (cast (ptr string) (-> found bytes))] [n (/ (-> found length) (sizeof string))])
-          (for ([i u32 1]) (< i n) (+= i 1)
-            (let ([s (@ ps i)] [j i])
-              (while (and (> j 0) (< s (@ ps (- j 1))))
-                (set! (@ ps j) (@ ps (- j 1)))
-                (-= j 1))
-              (set! (@ ps j) s)))
-          (for ([i u32 0]) (< i n) (+= i 1)
+        (let ([ps (strings-of (& found))])
+          (sorted! ps)
+          (for ([i u32 0]) (< i (-> ps length)) (+= i 1)
             (buffer-add-string! (& list) (@ ps i))
             (buffer-add-byte! (& list) 10)))))
     (written! (joined-path out "assets.list") (buffer-bytes (& list)))
@@ -163,3 +188,172 @@
              (joined-path out "index.html"))
     (when (== (kind-of (-> p program)) fs-directory)
       (copy-tree! (-> p program) (joined-path out "program") "" (& files)))))
+
+;; ---- releases ----
+
+;; A release keeps index.html and the assets where they are. It moves the host, the program, files.pack and assets.list
+;; into a directory named by a hash of their paths and bytes, the first 16 hex digits of a SHA-256. Each asset also gets
+;; a copy in a directory named by its own hash, and assets.list gives each copy's path after a tab. A server can cache
+;; all of these for good, as http-hashed-cache in std/http/static.sub does. index.html loads the program from its new
+;; directory and preloads the program's files. A file gets a gzipped copy, name.gz, when gzip shrinks it to nine tenths
+;; of its size or less.
+
+;; site-release! makes the site written in out a release, or returns #f with the reason in err.
+(define (site-release! [out string] [err (ptr buffer)]) -> bool
+  (try (begin (site-released! out) #t)
+       [catch site-failed (why)
+        (buffer-add-string! err why)
+        #f]))
+
+(define (read! [path string]) -> (slice u8)
+  (let ([b (slice u8)] [why error])
+    (unless (fs-read-file path (& b) (& why)) (throw site-failed (error-text (& why))))
+    b))
+
+(define (renamed! [from string] [to string])
+  (let ([why error]) (unless (fs-rename from to (& why)) (throw site-failed (error-text (& why))))))
+
+(define (slashed [a string] [b string]) -> string (if (== (-> a length) 0) b (joined (joined a "/") b)))
+
+(define (walked! [dir string] [rel string] [into (ptr buffer)])
+  (let ([names (names-in dir)])
+    (for ([i u32 0]) (< i (-> names length)) (+= i 1)
+      (let ([f (joined-path dir (@ names i))] [r (slashed rel (@ names i))])
+        (if (== (kind-of f) fs-directory) (walked! f r into) (added! into r))))))
+
+(define (hex! [b (ptr buffer)] [bytes (slice u8)])
+  (let ([digits "0123456789abcdef"])
+    (for ([i u32 0]) (< i (-> bytes length)) (+= i 1)
+      (buffer-add-byte! b (@ digits (>> (cast u32 (@ bytes i)) 4)))
+      (buffer-add-byte! b (@ digits (bit-and (cast u32 (@ bytes i)) 15))))))
+
+(define (release-name [out string] [paths (slice string)]) -> string
+  (let ([s sha256] [digest (array u8 32)] [name (make-buffer)] [size (make-buffer)])
+    (sha256-init! (& s))
+    (for ([i u32 0]) (< i (-> paths length)) (+= i 1)
+      (let ([b (read! (joined-path out (@ paths i)))])
+        (set! (-> size length) 0)
+        (buffer-add-byte! (& size) 0)
+        (buffer-add-u32! (& size) (-> b length))
+        (sha256-add! (& s) (cast (slice u8) (@ paths i)))
+        (sha256-add! (& s) (buffer-bytes (& size)))
+        (sha256-add! (& s) b)
+        (free (-> b items))))
+    (sha256-end! (& s) (slice digest))
+    (hex! (& name) (slice (slice digest) 0 8))
+    (buffer-free! (& size))
+    (buffer-string (& name))))
+
+(define (found [s string] [part string]) -> i64
+  (for ([i u32 0]) (<= (+ i (-> part length)) (-> s length)) (+= i 1)
+    (when (== (slice s i (+ i (-> part length))) part) (return (cast i64 i))))
+  -1)
+
+(define (found-before [s string] [part string] [before u32]) -> i64
+  (let ([i before])
+    (while (> i 0)
+      (-= i 1)
+      (when (and (<= (+ i (-> part length)) before) (== (slice s i (+ i (-> part length))) part))
+        (return (cast i64 i))))
+    -1))
+
+(define (url-safe? [c u8]) -> bool
+  (or (and (>= c #\a) (<= c #\z)) (and (>= c #\A) (<= c #\Z)) (and (>= c #\0) (<= c #\9))
+      (== c 45) (== c 95) (== c 46) (== c 33) (== c 126) (== c 42) (== c 39) (== c 40) (== c 41)))
+
+;; url! escapes each part of a path as encodeURIComponent does in the web host (subhost-web.mjs).
+(define (url! [b (ptr buffer)] [path string])
+  (let ([digits "0123456789ABCDEF"])
+    (for ([i u32 0]) (< i (-> path length)) (+= i 1)
+      (let ([c (@ path i)])
+        (if (or (url-safe? c) (== c #\/))
+            (buffer-add-byte! b c)
+            (begin
+              (buffer-add-byte! b 37)
+              (buffer-add-byte! b (@ digits (>> (cast u32 c) 4)))
+              (buffer-add-byte! b (@ digits (bit-and (cast u32 c) 15)))))))))
+
+(define (link! [b (ptr buffer)] [name string] [path string])
+  (buffer-add-string! b "<link rel=\"preload\" href=\"")
+  (buffer-add-string! b name)
+  (buffer-add-byte! b #\/)
+  (url! b path)
+  (buffer-add-string! b "\" as=\"fetch\" crossorigin>\n"))
+
+(define (released-html! [out string] [name string] [fetched (slice string)])
+  (let* ([path (joined-path out "index.html")] [html (cast string (read! path))] [at (found html "host/web/start.mjs")]
+         [tag (if (< at 0) -1 (found-before html "<script" (cast u32 at)))] [b (make-buffer)])
+    (when (< tag 0)
+      (throw site-failed "site: index.html has no script that loads host/web/start.mjs, so it cannot be released"))
+    (buffer-add-string! (& b) (slice html 0 (cast u32 tag)))
+    (for ([i u32 0]) (< i (-> fetched length)) (+= i 1) (link! (& b) name (@ fetched i)))
+    (buffer-add-string! (& b) (slice html (cast u32 tag) (cast u32 at)))
+    (buffer-add-string! (& b) name)
+    (buffer-add-byte! (& b) #\/)
+    (buffer-add-string! (& b) (slice html (cast u32 at) (-> html length)))
+    (written! path (buffer-bytes (& b)))
+    (buffer-free! (& b))
+    (free (-> html bytes))))
+
+(define (zipped! [dir string] [d (ptr deflater)])
+  (let ([names (names-in dir)])
+    (for ([i u32 0]) (< i (-> names length)) (+= i 1)
+      (let ([name (@ names i)] [f (joined-path dir (@ names i))])
+        (cond [(== (kind-of f) fs-directory) (zipped! f d)]
+              [(or (== name ".site") (ends? name ".gz")) (begin)]
+              [else
+               (let ([b (read! f)] [z (make-buffer)])
+                 (gzip! d (& z) b "")
+                 (when (<= (* (cast u64 (-> z length)) 10) (* (cast u64 (-> b length)) 9))
+                   (written! (joined f ".gz") (buffer-bytes (& z))))
+                 (free (-> b items))
+                 (buffer-free! (& z)))])))))
+
+(define (hash-of [b (slice u8)]) -> string
+  (let ([digest (array u8 32)] [name (make-buffer)])
+    (sha256-of b (slice digest))
+    (hex! (& name) (slice (slice digest) 0 8))
+    (buffer-string (& name))))
+
+(define (hashed-assets! [out string])
+  (let ([listed (cast string (read! (joined-path out "assets.list")))] [b (make-buffer)] [start u32 0])
+    (for ([i u32 0]) (<= i (-> listed length)) (+= i 1)
+      (when (or (== i (-> listed length)) (== (@ listed i) 10))
+        (when (> i start)
+          (let* ([path (slice listed start i)] [bytes (read! (joined-path out path))] [hash (hash-of bytes)] [k i])
+            (while (and (> k start) (!= (@ listed (- k 1)) #\/)) (-= k 1))
+            (let ([dir (joined-path (joined-path out "assets") hash)] [name (slice listed k i)])
+              (made! dir)
+              (written! (joined-path dir name) bytes)
+              (buffer-add-string! (& b) path)
+              (buffer-add-byte! (& b) 9)
+              (buffer-add-string! (& b) (slashed "assets" (slashed hash name)))
+              (buffer-add-byte! (& b) 10))
+            (free (-> bytes items))))
+        (set! start (+ i 1))))
+    (written! (joined-path out "assets.list") (buffer-bytes (& b)))
+    (buffer-free! (& b))
+    (free (-> listed bytes))))
+
+(define (site-released! [out string])
+  (let ([paths (make-buffer)] [fetched (make-buffer)] [d deflater])
+    (hashed-assets! out)
+    (walked! (joined-path out "host") "host" (& paths))
+    (walked! (joined-path out "program") "program" (& paths))
+    (added! (& paths) "files.pack")
+    (added! (& paths) "assets.list")
+    (sorted! (strings-of (& paths)))
+    (let* ([name (release-name out (strings-of (& paths)))] [code (joined-path out name)])
+      (made! code)
+      (renamed! (joined-path out "host") (joined-path code "host"))
+      (renamed! (joined-path out "program") (joined-path code "program"))
+      (renamed! (joined-path out "files.pack") (joined-path code "files.pack"))
+      (renamed! (joined-path out "assets.list") (joined-path code "assets.list"))
+      (walked! (joined-path code "program") "program" (& fetched))
+      (added! (& fetched) "files.pack")
+      (added! (& fetched) "assets.list")
+      (sorted! (strings-of (& fetched)))
+      (released-html! out name (strings-of (& fetched)))
+      (deflater-init! (& d) 9)
+      (zipped! out (& d))
+      (deflater-free! (& d)))))