substrate-lang 0.9.3 → 0.10.0

package/std/encoding/wire.sub

@@ -3,9 +3,9 @@
 
 (provide wire wire-error)
 
-(struct wire-error [message string] [offset u32])
+(struct wire-error [error error] [offset u32])
 
-(struct wire-reader [bytes (slice u8)] [at u32] [error wire-error])
+(struct wire-reader [bytes (slice u8)] [at u32] [message string] [offset u32])
 
 ;; ---- writing ----
 
@@ -28,12 +28,12 @@
 (define (start! [r (ptr wire-reader)] [bytes (slice u8)])
   (set! (-> r bytes) bytes)
   (set! (-> r at) 0)
-  (set! (-> r error message) "")
-  (set! (-> r error offset) 0))
+  (set! (-> r message) "")
+  (set! (-> r offset) 0))
 
 (define (fail! [r (ptr wire-reader)] [message string]) -> bool
-  (set! (-> r error message) message)
-  (set! (-> r error offset) (-> r at))
+  (set! (-> r message) message)
+  (set! (-> r offset) (-> r at))
   #f)
 
 (define (refuse! [r (ptr wire-reader)] [at u32] [message string]) -> bool
@@ -45,7 +45,9 @@
 (define (end! [r (ptr wire-reader)]) -> bool (or (== (left r) 0) (fail! r "bytes follow the message")))
 
 (define (read-failed [r (ptr wire-reader)] [err (ptr wire-error)]) -> bool
-  (when (!= err 0) (set! (@ err) (-> r error)))
+  (unless (== err 0)
+    (error-fail! (& (-> err error)) error-invalid (-> r message))
+    (set! (-> err offset) (-> r offset)))
   #f)
 
 (define (take-byte! [r (ptr wire-reader)] [to (ptr u8)]) -> bool
@@ -96,11 +98,9 @@
     (unless (take-count! r (& n)) (return #f))
     (let ([s (slice (-> r bytes) (-> r at) (+ (-> r at) n))])
       (unless (utf-8? s) (return (refuse! r start "a string is not UTF-8")))
-      (let ([p (cast (ptr u8) (arena-alloc a n))])
-        (memcpy p (-> s items) n)
-        (set! (@ to) (cast string (slice p n)))
-        (+= (-> r at) n)
-        #t))))
+      (set! (@ to) (cast string (copy a s)))
+      (+= (-> r at) n)
+      #t)))
 
 ;; ---- the wire form ----
 
@@ -210,7 +210,7 @@
              #`(let ([#,present #f])
                  (unless (take-flag! r (& #,present) "an option's tag is neither 0 nor 1") (return #f))
                  (if #,present
-                     (let ([#,q (cast (ptr #,u) (arena-alloc a (sizeof #,u)))])
+                     (let ([#,q (new a #,u)])
                        #,(read-code (cadr type) #`(@ #,q) where)
                        (set! #,p #,q))
                      (set! #,p 0))))]
@@ -218,9 +218,9 @@
            (let ([n (derive-fresh 'n)] [items (derive-fresh 'items)] [i (derive-fresh 'i)] [u (type-syntax (cadr type))])
              #`(let ([#,n u32 0])
                  (unless (take-count! r (& #,n)) (return #f))
-                 (let ([#,items (cast (ptr #,u) (arena-alloc a (* #,n (sizeof #,u))))])
+                 (let ([#,items (new a #,u #,n)])
                    (for ([#,i u32 0]) (< #,i #,n) (+= #,i 1) #,(read-code (cadr type) #`(@ #,items #,i) where))
-                   (set! #,p (slice #,items #,n)))))]
+                   (set! #,p #,items))))]
           [(== (car type) 'array)
            (let ([i (derive-fresh 'i)])
              #`(for ([#,i u32 0]) (< #,i #,(literal (caddr type))) (+= #,i 1)

package/std/http/checks.sub

@@ -200,12 +200,12 @@
 
 ;; The table starts with 64 buckets and doubles, up to most, when three quarters full.
 (define (grow! [l (ptr http-limit)] [size u32])
-  (let ([old (-> l buckets)] [n (-> l size)] [new (cast (ptr bucket) (calloc size (sizeof bucket)))])
+  (let ([old (-> l buckets)] [n (-> l size)] [more (-> (new 0 bucket size) items)])
     (for ([i u32 0]) (< i n) (+= i 1)
       (let ([b (& (@ old i))])
-        (when (-> b used) (memcpy (slot new size (slice (cast (ptr u8) (-> b key)) (-> b length))) b (sizeof bucket)))))
+        (when (-> b used) (memcpy (slot more size (slice (cast (ptr u8) (-> b key)) (-> b length))) b (sizeof bucket)))))
     (free old)
-    (set! (-> l buckets) new)
+    (set! (-> l buckets) more)
     (set! (-> l size) size)))
 
 (define (bucket-of [l (ptr http-limit)] [key (slice u8)]) -> (ptr bucket)

package/std/http/conditional.sub

@@ -53,13 +53,11 @@
 (define (second-of [ms f64]) -> f64 (* (floor (/ ms 1000.0)) 1000.0))
 
 (define (http-conditional! [r (ptr http-request)] [etag string] [modified f64]) -> bool
-  (let* ([a (& (-> r arena))] [copy (cast (ptr u8) (arena-alloc a (-> etag length)))]
-         [read? (or (== (-> r method) "GET") (== (-> r method) "HEAD"))]
+  (let* ([a (& (-> r arena))] [read? (or (== (-> r method) "GET") (== (-> r method) "HEAD"))]
          [if-match (http-request-header r "if-match")] [if-none-match (http-request-header r "if-none-match")]
          [unmodified (date-of r "if-unmodified-since")] [since (date-of r "if-modified-since")]
          [changed (second-of modified)] [status i32 0])
-    (memcpy copy (-> etag bytes) (-> etag length))
-    (set! (-> r etag) (cast string (slice copy (-> etag length))))
+    (set! (-> r etag) (copy a etag))
     (set! (-> r modified) modified)
     (cond [(> (-> if-match length) 0) (unless (matches? if-match etag #t) (set! status 412))]
           [(and (>= unmodified 0.0) (> modified 0.0) (> changed unmodified)) (set! status 412)])

package/std/http/cookie.sub

@@ -3,16 +3,14 @@
 (require-unqualified "http.sub")
 (require-unqualified "server.sub")
 
-(provide http-cookie http-request-cookie http-set-cookie! http-same-site-lax http-same-site-strict
-         http-same-site-none)
+(provide http-cookie http-request-cookie http-set-cookie! http-same-site http-same-site-default http-same-site-lax
+         http-same-site-strict http-same-site-none)
 
-(const http-same-site-lax i32 1)
-(const http-same-site-strict i32 2)
-(const http-same-site-none i32 3)
+(enum http-same-site http-same-site-default http-same-site-lax http-same-site-strict http-same-site-none)
 
-;; max-age is in seconds: 0 leaves it out, and below 0 ends the cookie now. same-site 0 leaves it out.
+;; max-age is in seconds: 0 leaves it out, and below 0 ends the cookie now. http-same-site-default leaves SameSite out.
 (struct http-cookie [name string] [value string] [path string] [domain string] [max-age i64] [secure bool]
-  [http-only bool] [same-site i32])
+  [http-only bool] [same-site http-same-site])
 
 (define separators string "()<>@,;:\\\"/[]?={}")
 

package/std/http/form.sub

@@ -10,11 +10,11 @@
 
 (struct http-upload [filename string] [type string] [bytes (slice u8)])
 
-(struct form-error [message string] [field string])
+(struct form-error [error error] [field string])
 
 (define (refuse! [err (ptr form-error)] [message string] [field string]) -> bool
   (unless (== err 0)
-    (set! (-> err message) message)
+    (error-fail! (& (-> err error)) error-invalid message)
     (set! (-> err field) field))
   #f)
 
@@ -111,11 +111,11 @@
              (check! (cadr type) name)
              (let ([e (type-syntax (cadr type))])
                (if (upload? (cadr type))
-                   #`(let ([#,q (cast (ptr http-upload) (arena-alloc a (sizeof http-upload)))])
+                   #`(let ([#,q (new a http-upload)])
                        (set! #,p (if (file parts #,key 0 #,q) #,q 0)))
                    #`(let ([#,s string])
                        (if (text pairs parts #,key 0 (& #,s))
-                           (let ([#,q (cast (ptr #,e) (arena-alloc a (sizeof #,e)))])
+                           (let ([#,q (new a #,e)])
                              #,(value-code (cadr type) s #`(@ #,q) key)
                              (set! #,p #,q))
                            (set! #,p 0)))))]
@@ -123,17 +123,14 @@
              (check! (cadr type) name)
              (let ([e (type-syntax (cadr type))])
                (if (upload? (cadr type))
-                   #`(let* ([#,n (files parts #,key)]
-                            [#,items (cast (ptr http-upload) (arena-alloc a (* #,n (sizeof http-upload))))])
-                       (for ([#,k u32 0]) (< #,k #,n) (+= #,k 1) (file parts #,key #,k (+ #,items #,k)))
-                       (set! #,p (slice #,items #,n)))
-                   #`(let* ([#,n (texts pairs parts #,key)]
-                            [#,items (cast (ptr #,e) (arena-alloc a (* #,n (sizeof #,e))))]
-                            [#,s string])
+                   #`(let* ([#,n (files parts #,key)] [#,items (new a http-upload #,n)])
+                       (for ([#,k u32 0]) (< #,k #,n) (+= #,k 1) (file parts #,key #,k (& (@ #,items #,k))))
+                       (set! #,p #,items))
+                   #`(let* ([#,n (texts pairs parts #,key)] [#,items (new a #,e #,n)] [#,s string])
                        (for ([#,k u32 0]) (< #,k #,n) (+= #,k 1)
                          (text pairs parts #,key #,k (& #,s))
                          #,(value-code (cadr type) s #`(@ #,items #,k) key))
-                       (set! #,p (slice #,items #,n)))))]
+                       (set! #,p #,items))))]
             [(== type 'bool)
              #`(let ([#,s string])
                  (if (text pairs parts #,key 0 (& #,s))

package/std/http/http.sub

@@ -18,18 +18,11 @@
 (struct http-head [line buffer] [names (ptr string)] [values (ptr string)] [room u32] [count u32]
   [method string] [target string] [version string] [status i32] [reason string])
 
-(const state-head i32 0)
-(const state-length i32 1)
-(const state-chunk-size i32 2)
-(const state-chunk-data i32 3)
-(const state-chunk-end i32 4)
-(const state-trailers i32 5)
-(const state-until-close i32 6)
-(const state-stopped i32 7)
-(const state-refused i32 8)
-(const state-no-body i32 9)
-
-(struct http-parser [head http-head] [line buffer] [state i32] [remaining i64] [excess i64] [user (ptr void)]
+(enum parser-state
+  state-head state-length state-chunk-size state-chunk-data state-chunk-end state-trailers state-until-close
+  state-stopped state-refused state-no-body)
+
+(struct http-parser [head http-head] [line buffer] [state parser-state] [remaining i64] [excess i64] [user (ptr void)]
   [on-head (fn ((ptr http-parser)))] [on-body (fn ((ptr http-parser) (slice u8)))] [on-end (fn ((ptr http-parser)))])
 
 ;; ---- text ----
@@ -102,14 +95,14 @@
         (when (and (< i n) (== (@ value i) #\=))
           (+= i 1)
           (if (and (< i n) (== (@ value i) #\"))
-              (let ([p (cast (ptr u8) (arena-alloc a (- n i)))] [k u32 0])
+              (let ([p (new a u8 (- n i))] [k u32 0])
                 (+= i 1)
                 (while (and (< i n) (!= (@ value i) #\"))
                   (when (and (== (@ value i) #\\) (< (+ i 1) n)) (+= i 1))
                   (set! (@ p k) (@ value i))
                   (+= k 1)
                   (+= i 1))
-                (set! found (cast string (slice p k))))
+                (set! found (cast string (slice p 0 k))))
               (begin
                 (set! start i)
                 (while (and (< i n) (!= (@ value i) #\;)) (+= i 1))
@@ -201,22 +194,22 @@
 
 ;; to becomes a copy of from with its own text and room for just its headers, which http-head-free! frees.
 (define (http-head-copy! [to (ptr http-head)] [from (ptr http-head)])
-  (let ([old (-> from line bytes)] [new (ptr u8) 0] [n (-> from count)])
+  (let ([old (-> from line bytes)] [text (ptr u8) 0] [n (-> from count)])
     (set! (-> to line) (make-buffer))
     (buffer-add! (& (-> to line)) (buffer-bytes (& (-> from line))))
-    (set! new (-> to line bytes))
-    (set! (-> to names) (cast (ptr string) (malloc (* n (sizeof string)))))
-    (set! (-> to values) (cast (ptr string) (malloc (* n (sizeof string)))))
+    (set! text (-> to line bytes))
+    (set! (-> to names) (-> (new 0 string n) items))
+    (set! (-> to values) (-> (new 0 string n) items))
     (set! (-> to room) n)
     (for ([i u32 0]) (< i (-> from count)) (+= i 1)
-      (set! (@ (-> to names) i) (moved (@ (-> from names) i) old new))
-      (set! (@ (-> to values) i) (moved (@ (-> from values) i) old new)))
+      (set! (@ (-> to names) i) (moved (@ (-> from names) i) old text))
+      (set! (@ (-> to values) i) (moved (@ (-> from values) i) old text)))
     (set! (-> to count) (-> from count))
-    (set! (-> to method) (moved (-> from method) old new))
-    (set! (-> to target) (moved (-> from target) old new))
-    (set! (-> to version) (moved (-> from version) old new))
+    (set! (-> to method) (moved (-> from method) old text))
+    (set! (-> to target) (moved (-> from target) old text))
+    (set! (-> to version) (moved (-> from version) old text))
     (set! (-> to status) (-> from status))
-    (set! (-> to reason) (moved (-> from reason) old new))))
+    (set! (-> to reason) (moved (-> from reason) old text))))
 
 (define (moved [s string] [old (ptr u8)] [new (ptr u8)]) -> string
   (if (== (-> s length) 0) "" (cast string (slice (+ new (- (cast u32 (-> s bytes)) (cast u32 old))) (-> s length)))))

package/std/http/multipart.sub

@@ -11,9 +11,7 @@
 (define (multipart-boundary [a (ptr arena)] [content-type string]) -> string
   (if (http-media-type? content-type "multipart/form-data") (http-media-parameter a content-type "boundary") ""))
 
-(define (refused [why (ptr string)] [message string]) -> bool
-  (set! (@ why) message)
-  #f)
+(define (refused [err (ptr error)] [message string]) -> bool (error-fail! err error-invalid message))
 
 (define (at? [body (slice u8)] [i u32] [s string]) -> bool
   (and (<= (+ i (-> s length)) (-> body length)) (== (cast string (slice body i (+ i (-> s length)))) s)))
@@ -27,10 +25,10 @@
     -1))
 
 (define (joined [a (ptr arena)] [front string] [back string]) -> string
-  (let ([p (cast (ptr u8) (arena-alloc a (+ (-> front length) (-> back length))))])
-    (memcpy p (-> front bytes) (-> front length))
-    (memcpy (+ p (-> front length)) (-> back bytes) (-> back length))
-    (cast string (slice p (+ (-> front length) (-> back length))))))
+  (let ([p (new a u8 (+ (-> front length) (-> back length)))])
+    (memcpy (-> p items) (-> front bytes) (-> front length))
+    (memcpy (+ (-> p items) (-> front length)) (-> back bytes) (-> back length))
+    (cast string p)))
 
 (define (base-name [s string]) -> string
   (let ([i (-> s length)])
@@ -66,28 +64,28 @@
                     [(http-same? name "content-type") (set! (-> part type) (http-trimmed value))])))
           (set! start (+ i 1)))))))
 
-;; A body's named parts, in the arena; #f with the reason in why when the body is malformed.
+;; A body's named parts, in the arena.
 (define (multipart-parse [a (ptr arena)] [body (slice u8)] [boundary string] [to (ptr (slice multipart-part))]
-                         [why (ptr string)]) -> bool
+                         [err (ptr error)]) -> bool
   (set! (@ to) 0)
   (when (or (== (-> boundary length) 0) (> (-> boundary length) 70))
-    (return (refused why "the boundary is missing or longer than 70 bytes")))
+    (return (refused err "the boundary is missing or longer than 70 bytes")))
   (let* ([dash (joined a "--" boundary)] [delimiter (joined a "\r\n" dash)] [n (-> body length)]
          [first (if (at? body 0 dash) 0 (find body delimiter 0))]
          [at u32 0] [items (ptr multipart-part) 0] [count u32 0] [room u32 0])
-    (when (< first 0) (return (refused why "the body has no boundary")))
+    (when (< first 0) (return (refused err "the body has no boundary")))
     (set! at (+ (cast u32 first) (if (at? body 0 dash) 0 2) (-> dash length)))
     (while #t
       (when (at? body at "--") (break))
       (while (and (< at n) (or (== (@ body at) 32) (== (@ body at) 9))) (+= at 1))
-      (unless (at? body at "\r\n") (return (refused why "a boundary's line goes on past it")))
+      (unless (at? body at "\r\n") (return (refused err "a boundary's line goes on past it")))
       (+= at 2)
       (let* ([empty (at? body at "\r\n")] [end (if empty (cast i64 at) (find body "\r\n\r\n" at))]
              [part multipart-part] [start u32 0] [next i64 0])
-        (when (< end 0) (return (refused why "a part's head does not end")))
+        (when (< end 0) (return (refused err "a part's head does not end")))
         (set! start (+ (cast u32 end) (if empty 2 4)))
         (set! next (find body delimiter start))
-        (when (< next 0) (return (refused why "the body ends inside a part")))
+        (when (< next 0) (return (refused err "the body ends inside a part")))
         (set! (-> part name) "")
         (set! (-> part filename) "")
         (set! (-> part type) "")
@@ -97,7 +95,7 @@
         (when (> (-> part name length) 0)
           (when (== count room)
             (set! room (if (== room 0) 4 (* 2 room)))
-            (let ([more (cast (ptr multipart-part) (arena-alloc a (* room (sizeof multipart-part))))])
+            (let ([more (-> (new a multipart-part room) items)])
               (when (> count 0) (memcpy more items (* count (sizeof multipart-part))))
               (set! items more)))
           (set! (@ items count) part)

package/std/http/route.sub

@@ -18,20 +18,20 @@
 (define (route-rest [a (ptr arena)] [segments (slice string)] [i u32]) -> string
   (let ([n u32 0] [at u32 0])
     (for ([k u32 i]) (< k (-> segments length)) (+= k 1) (+= n (+ (-> (@ segments k) length) 1)))
-    (let ([p (cast (ptr u8) (arena-alloc a n))])
+    (let ([p (new a u8 n)])
       (for ([k u32 i]) (< k (-> segments length)) (+= k 1)
         (when (> k i)
           (set! (@ p at) #\/)
           (+= at 1))
-        (memcpy (+ p at) (-> (@ segments k) bytes) (-> (@ segments k) length))
+        (memcpy (+ (-> p items) at) (-> (@ segments k) bytes) (-> (@ segments k) length))
         (+= at (-> (@ segments k) length)))
-      (cast string (slice p at)))))
+      (cast string (slice p 0 at)))))
 
 (define (route-slashed [a (ptr arena)] [segments (slice string)]) -> (slice string)
-  (let* ([n (-> segments length)] [items (cast (ptr string) (arena-alloc a (* (+ n 1) (sizeof string))))])
+  (let* ([n (-> segments length)] [items (new a string (+ n 1))])
     (for ([i u32 0]) (< i n) (+= i 1) (set! (@ items i) (@ segments i)))
     (set! (@ items n) "")
-    (slice items (+ n 1))))
+    items))
 
 (define (route-moved! [r (ptr http-request)] [path string])
   (let ([b (make-buffer)] [target (-> r target)])
@@ -76,8 +76,9 @@
     (buffer-add-string! (& b) "field ")
     (buffer-add-string! (& b) (-> err field))
     (buffer-add-string! (& b) ": ")
-    (buffer-add-string! (& b) (-> err message))
+    (buffer-add-string! (& b) (error-text (& (-> err error))))
     (http-answer-text! r 400 (buffer-string (& b)))
+    (error-free! (& (-> err error)))
     (buffer-free! (& b))))
 
 (define (route-json-refused! [r (ptr http-request)] [err (ptr json-error)])
@@ -87,8 +88,9 @@
     (buffer-add-byte! (& b) #\:)
     (write-digits (& b) (-> err column) 10)
     (buffer-add-string! (& b) ": ")
-    (buffer-add-string! (& b) (-> err message))
+    (buffer-add-string! (& b) (error-text (& (-> err error))))
     (http-answer-text! r 400 (buffer-string (& b)))
+    (error-free! (& (-> err error)))
     (buffer-free! (& b))))
 
 (define (route-typed? [r (ptr http-request)] [json bool]) -> bool
@@ -103,12 +105,15 @@
 
 (define (route-form-fields [r (ptr http-request)] [body (slice u8)] [pairs (ptr (slice url-pair))]
                            [parts (ptr (slice multipart-part))]) -> bool
-  (let* ([a (& (-> r arena))] [t (http-request-header r "content-type")] [why string])
+  (let* ([a (& (-> r arena))] [t (http-request-header r "content-type")] [why error])
     (set! (@ pairs) 0)
     (set! (@ parts) 0)
     (if (http-media-type? t "multipart/form-data")
         (or (multipart-parse a body (multipart-boundary a t) parts (& why))
-            (begin (http-answer-text! r 400 why) #f))
+            (begin
+              (http-answer-text! r 400 (error-text (& why)))
+              (error-free! (& why))
+              #f))
         (begin (set! (@ pairs) (url-form-parse a (cast string body))) #t))))
 
 (define (route-add-text! [b (ptr buffer)] [s string])
@@ -440,7 +445,7 @@
                            #,@(if (== body 0)
                                   `(,#`(unless (route-typed? r #,(literal (boolean (!= json 0)))) (return)))
                                   nil)
-                           (let ([#,args (cast (ptr #,given) (arena-alloc (& (-> r arena)) (sizeof #,given)))])
+                           (let ([#,args (new (& (-> r arena)) #,given)])
                              #,@(for/list ([x values]) #`(set! (-> #,args #,x) #,x))
                              (set! (-> r route) (cast (ptr void) #,args))
                              (http-read-body! r #,(if (== limit 0) (number 0) limit) #,read)))
@@ -448,7 +453,7 @@
            [start #`(define (#,(start-of r) [r (ptr http-request)] #,@(formals ps))
                       #,(if (== query 0)
                             ending
-                            #`(let ([#,q (cast (ptr #,query) (arena-alloc (& (-> r arena)) (sizeof #,query)))]
+                            #`(let ([#,q (new (& (-> r arena)) #,query)]
                                     [#,e form-error])
                                 (unless (#,(derived query '"form-read" 'form where) (& (-> r arena))
                                          (url-form-parse (& (-> r arena)) (url-query (-> r target))) no-parts #,q
@@ -462,14 +467,14 @@
                  (let* ([#,args (cast (ptr #,given) (-> r route))] #,@(for/list ([x values]) #`[#,x (-> #,args #,x)]))
                    #,(cond [(!= body 0) (handler-call handler values `(,#'bytes))]
                            [(!= json 0)
-                            #`(let ([#,value (cast (ptr #,json) (arena-alloc (& (-> r arena)) (sizeof #,json)))]
+                            #`(let ([#,value (new (& (-> r arena)) #,json)]
                                     [#,e json-error])
                                 (unless (#,(derived json '"json-read" 'json where) (& (-> r arena)) (cast string bytes)
                                          #,value (& #,e))
                                   (return (route-json-refused! r (& #,e))))
                                 #,(handler-call handler values `(,value)))]
                            [else
-                            #`(let ([#,value (cast (ptr #,form) (arena-alloc (& (-> r arena)) (sizeof #,form)))]
+                            #`(let ([#,value (new (& (-> r arena)) #,form)]
                                     [#,e form-error] [pairs (slice url-pair)] [parts (slice multipart-part)])
                                 (unless (route-form-fields r bytes (& pairs) (& parts)) (return))
                                 (unless (#,(derived form '"form-read" 'form where) (& (-> r arena)) pairs parts #,value

package/std/http/server.sub

@@ -3,7 +3,8 @@
 ;; in ms, the default at 0 and none below 0: idle-timeout 5 s (130 s behind proxies), head-timeout 60 s,
 ;; request-timeout 300 s, send-timeout 60 s; body-limit for http-read-body!, 1 MiB at 0; compress, a gzip level for
 ;; answers of a type that compresses, of 1 KB or more, and for event streams that ask; proxies, how many proxies' hops
-;; of X-Forwarded headers to believe; checks, run before handle. problem holds why listening failed.
+;; of X-Forwarded headers to believe; checks, run before handle. problem holds the failure when listening fails after
+;; http-serve! returns.
 ;; A request lasts until it is answered and its body has ended; on-done is called as it ends and must not trap. A trap
 ;; in a request's code answers 500, or ends the connection once the answer has begun, and goes to on-trap, the log, or
 ;; stderr.
@@ -39,7 +40,7 @@
   [on-end (fn ((ptr http-request)))]
   [on-gone (fn ((ptr http-request)))] [on-drained (fn ((ptr http-request)))] [body buffer] [limit u32]
   [taken (fn ((ptr http-request) (slice u8)))] [added buffer] [own-head http-head] [etag string] [modified f64]
-  [ranges bool] [compressible bool] [events bool] [encoded bool] [gzip i32] [deflater (ptr deflater)] [crc u32]
+  [ranges bool] [compressible bool] [events bool] [encoded bool] [gzip zip-mode] [deflater (ptr deflater)] [crc u32]
   [size u32])
 
 ;; A check runs before the handler and returns #t when it has answered.
@@ -65,7 +66,7 @@
 
 (struct http-server [head event-head] [listener u32] [port u32] [host string] [secure bool] [most u32]
   [idle-timeout f64] [head-timeout f64] [request-timeout f64] [send-timeout f64] [body-limit u32] [compress i32]
-  [proxies u32] [checks (slice http-check)] [problem string] [user (ptr void)] [connections (ptr http-connection)]
+  [proxies u32] [checks (slice http-check)] [problem error] [user (ptr void)] [connections (ptr http-connection)]
   [hooks (ptr http-hook)] [stopping bool] [stop-timer u32] [stopped (fn ((ptr http-server)))] [log (ptr logger)]
   [handle (fn ((ptr http-request)))] [listening (fn ((ptr http-server)))] [on-trap (fn ((ptr http-request) string))]
   [on-done (fn ((ptr http-request)))])
@@ -140,13 +141,11 @@
   (http-write-header! (& (-> r added)) name value))
 
 (define (new-request! [c (ptr http-connection)] [h (ptr http-head)]) -> (ptr http-request)
-  (let ([r (cast (ptr http-request) (calloc 1 (sizeof http-request)))])
+  (let ([r (new 0 http-request)])
     (set! (-> r connection) (cast (ptr void) c))
     (set! (-> r server) (-> c server))
     (set! (-> r length) -1)
-    (set! (-> r peer) (cast string (slice (cast (ptr u8) (arena-alloc (& (-> r arena)) (-> c peer length)))
-                                           (-> c peer length))))
-    (memcpy (-> r peer bytes) (-> c peer bytes) (-> c peer length))
+    (set! (-> r peer) (copy (& (-> r arena)) (-> c peer)))
     (http-head-copy! (& (-> r own-head)) h)
     (set! (-> r head) (& (-> r own-head)))
     (set! (-> r method) (-> r own-head method))
@@ -581,7 +580,7 @@
           [(== kind stream-failed) (drop! c)])))
 
 (define (new-connection! [s (ptr http-server)] [stream u32]) -> (ptr http-connection)
-  (let ([c (cast (ptr http-connection) (calloc 1 (sizeof http-connection)))])
+  (let ([c (new 0 http-connection)])
     (set! (-> c head handle) connection-heard)
     (set! (-> c server) (cast (ptr void) s))
     (set! (-> c stream) stream)
@@ -612,10 +611,7 @@
 ;; ---- compression ----
 
 ;; How an answer is compressed: not, whole by http-send!, as each piece is written, or each event alone.
-(const zip-none i32 0)
-(const zip-whole i32 1)
-(const zip-pieces i32 2)
-(const zip-events i32 3)
+(enum zip-mode zip-none zip-whole zip-pieces zip-events)
 
 ;; Bodies shorter than this go uncompressed.
 (const zip-least i64 1024)
@@ -763,7 +759,7 @@
     (when (and (== (-> r gzip) zip-none) (or (< (-> r length) 0) (>= (-> r length) zip-least)) (zip? r))
       (set! (-> r gzip) (if (-> r events) zip-events zip-pieces))
       (when (== (-> r gzip) zip-pieces)
-        (set! (-> r deflater) (cast (ptr deflater) (malloc (sizeof deflater))))
+        (set! (-> r deflater) (new 0 deflater))
         (deflater-init! (-> r deflater) (-> s compress))))
     (when (and (has-length? r) (>= (-> r length) 0) (< (-> r gzip) zip-pieces))
       (http-write-number! b "content-length" (-> r length)))
@@ -911,7 +907,7 @@
         (begin
           (stream-close from)
           (http-finish! r))
-        (let ([p (cast (ptr relay) (malloc (sizeof relay)))])
+        (let ([p (new 0 relay)])
           (http-write! r 0)
           (set! (-> p head handle) relay-heard)
           (set! (-> p from) from)
@@ -982,19 +978,21 @@
            (when (!= (-> s listening) 0) ((-> s listening) s))]
           [(== kind net-accept) (if (-> s stopping) (stream-close (cast u32 value)) (accept! s (cast u32 value)))]
           [(== kind net-failed)
-           (set! (-> s port) 0)
-           (set! (-> s problem) (events-take-text))
-           (when (!= (-> s listening) 0) ((-> s listening) s))])))
+           (let ([why (events-take-text)])
+             (set! (-> s port) 0)
+             (error-fail! (& (-> s problem)) value why)
+             (free (-> why bytes))
+             (when (!= (-> s listening) 0) ((-> s listening) s)))])))
 
-(define (http-serve! [s (ptr http-server)] [port u32] [handle (fn ((ptr http-request)))]) -> u32
+(define (http-serve! [s (ptr http-server)] [port u32] [handle (fn ((ptr http-request)))] [err (ptr error)]) -> bool
   (trap-handler! http-trapped)
   (set! (-> s head handle) server-heard)
   (set! (-> s handle) handle)
   (set! (-> s connections) 0)
   (set! (-> s port) 0)
-  (set! (-> s problem) "")
-  (set! (-> s listener) (net-listen port (-> s host) (-> s secure) (-> s most) (cast (ptr void) s) (& (-> s problem))))
-  (-> s listener))
+  (error-free! (& (-> s problem)))
+  (set! (-> s problem code) 0)
+  (net-listen port (-> s host) (-> s secure) (-> s most) (cast (ptr void) s) (& (-> s listener)) err))
 
 ;; http-server-close! stops listening and drops every connection at once, and runs the hooks forced.
 (define (http-server-close! [s (ptr http-server)])
@@ -1089,8 +1087,8 @@
   (set! (-> stopper server) s)
   (set! (-> stopper ms) ms)
   (set! (-> stopper done) done)
-  (set! (-> stopper term) (signal-listen "SIGTERM" (cast (ptr void) (& stopper)) 0))
-  (signal-listen "SIGINT" (cast (ptr void) (& stopper)) 0))
+  (signal-listen "SIGTERM" (cast (ptr void) (& stopper)) (& (-> stopper term)) 0)
+  (signal-listen "SIGINT" (cast (ptr void) (& stopper)) 0 0))
 
 ;; ---- connections without streams ----
 

package/std/http/session.sub

@@ -51,10 +51,7 @@
       (set! ok (and (<= at (+ (now-seconds) 60)) (<= (cast i64 (- (now-seconds) at)) (max-age-of s)))))
     (set! (-> b length) 0)
     (set! ok (and ok (base64url-decode! (& b) (slice value 0 first))))
-    (when ok
-      (let ([p (cast (ptr u8) (arena-alloc (& (-> r arena)) (-> b length)))])
-        (memcpy p (-> b bytes) (-> b length))
-        (set! (@ into) (slice p (-> b length)))))
+    (when ok (set! (@ into) (copy (& (-> r arena)) (buffer-bytes (& b)))))
     (buffer-free! (& b))
     ok))
 
@@ -100,9 +97,9 @@
       (raise-syntax-error 'session "this type needs a json form, which (json T) defines: write it first" t))
     `(,#`(define (#,(derive-name t '"session-read") [s (ptr http-sessions)] [r (ptr http-request)] [v (ptr #,t)])
            -> bool
-           (let ([bytes (slice u8)] [e json-error])
+           (let ([bytes (slice u8)])
              (and (http-session-read s r (& bytes))
-                  (#,(derive-name t '"json-read") (& (-> r arena)) (cast string bytes) v (& e)))))
+                  (#,(derive-name t '"json-read") (& (-> r arena)) (cast string bytes) v 0))))
       ,#`(define (#,(derive-name t '"session-write!") [s (ptr http-sessions)] [r (ptr http-request)] [v (ptr #,t)])
            (let ([b (make-buffer)])
              (#,(derive-name t '"json-write!") (& b) v)

package/std/http/sse-client.sub

@@ -11,16 +11,11 @@
 (require-unqualified "http.sub")
 
 (provide sse-event sse-parser sse-parser-init! sse-parse! sse-parser-end! sse-parser-free! sse-client
-         sse-client-open! sse-client-close! sse-ended sse-lost sse-refused)
+         sse-client-open! sse-client-close! sse-end sse-ended sse-lost sse-refused)
 
-(const sse-ended i32 0)
-(const sse-lost i32 1)
-(const sse-refused i32 2)
+(enum sse-end sse-ended sse-lost sse-refused)
 
-(const state-closed i32 0)
-(const state-connecting i32 1)
-(const state-open i32 2)
-(const state-waiting i32 3)
+(enum client-state state-closed state-connecting state-open state-waiting)
 
 (const default-retry f64 3000.0)
 
@@ -133,10 +128,10 @@
 ;; ---- the client ----
 
 (struct sse-client [head event-head] [user (ptr void)] [reconnect bool] [retry f64] [status i32] [error i32]
-  [method string] [url string] [headers (slice string)] [body (slice u8)] [state i32] [fetch u32] [timer u32]
+  [method string] [url string] [headers (slice string)] [body (slice u8)] [state client-state] [fetch u32] [timer u32]
   [parser sse-parser] [chunk (array u8 16384)]
   [on-open (fn ((ptr sse-client)))] [on-event (fn ((ptr sse-client) (ptr sse-event)))]
-  [on-closed (fn ((ptr sse-client) i32))])
+  [on-closed (fn ((ptr sse-client) sse-end))])
 
 (define (parsed [p (ptr sse-parser)] [e (ptr sse-event)])
   (let ([c (cast (ptr sse-client) (-> p user))])
@@ -144,7 +139,7 @@
 
 (define (connect! [c (ptr sse-client)])
   (let* ([n (-> c headers length)] [id (buffer-string (& (-> c parser id)))]
-         [all (cast (ptr string) (malloc (* (+ n 4) (sizeof string))))] [k n])
+         [all (new 0 string (+ n 4))] [k n])
     (for ([i u32 0]) (< i n) (+= i 1) (set! (@ all i) (@ (-> c headers) i)))
     (set! (@ all k) "accept")
     (set! (@ all (+ k 1)) "text/event-stream")
@@ -154,8 +149,8 @@
       (set! (@ all (+ k 1)) id)
       (+= k 2))
     (set! (-> c state) state-connecting)
-    (set! (-> c fetch) (fetch-start (-> c method) (-> c url) (slice all k) (-> c body) (cast (ptr void) c)))
-    (free all)))
+    (set! (-> c fetch) (fetch-start (-> c method) (-> c url) (slice all 0 k) (-> c body) (cast (ptr void) c)))
+    (free (-> all items))))
 
 (define (stop! [c (ptr sse-client)])
   (unless (== (-> c fetch) 0) (stream-close (-> c fetch)))
@@ -164,7 +159,7 @@
   (set! (-> c timer) 0)
   (set! (-> c state) state-closed))
 
-(define (ended! [c (ptr sse-client)] [why i32])
+(define (ended! [c (ptr sse-client)] [why sse-end])
   (stream-close (-> c fetch))
   (set! (-> c fetch) 0)
   (sse-parser-end! (& (-> c parser)))