lumbda/examples/http-static-server-sendfile.lsp

;;; http-static-server-sendfile.lsp — hybrid in-memory + sendfile(2)
;;; static server for lumbda.com. Small assets (HTML/CSS/txt) are
;;; cached whole as pre-built HTTP responses and flushed in one
;;; tcp-send. Large assets (PDFs, images) cache only the headers;
;;; the body is streamed from disk via sendfile(2), a zero-copy
;;; kernel->socket path that never enters the lumbda heap.
;;;
;;; Why the split:
;;;   - For small bodies (<= *inline-threshold*), one tcp-send beats
;;;     the syscall split (headers + sendfile).
;;;   - For large bodies, kernel-side DMA + no userspace bounce
;;;     dominates any string copy we could do in-process.
;;;
;;; Configuration:
;;;   *docroot*            filesystem root
;;;   *preload-paths*      URL paths to prepare at startup
;;;   *inline-threshold*   bytes; <= inline, > sendfile
;;;
;;; Target tier: asm-gc (has tcp-sendfile primitive). On tiers that
;;; lack tcp-sendfile (Python, C, bump-only asm) this file will
;;; error at load — it's a deployment example for asm-gc, not a
;;; portable reference.

(define *port*              8080)
(define *docroot*           "www")
(define *cache-max*         100)
(define *max-requests*      1000000)
(define *inline-threshold*  16384)

(define *crlf*              "\r\n")
(define *crlf-crlf*         "\r\n\r\n")

;;; ── MIME ────────────────────────────────────────────────────

(define (ends-with? s suffix)
  (let ((ns (string-length s)) (nf (string-length suffix)))
    (if (< ns nf) #f
        (string=? suffix (substring s (- ns nf) ns)))))

(define (mime-of path)
  (cond
    ((ends-with? path ".html") "text/html; charset=utf-8")
    ((ends-with? path ".css")  "text/css; charset=utf-8")
    ((ends-with? path ".pdf")  "application/pdf")
    ((ends-with? path ".txt")  "text/plain; charset=utf-8")
    ((ends-with? path ".js")   "application/javascript")
    ((ends-with? path ".svg")  "image/svg+xml")
    ((ends-with? path ".png")  "image/png")
    ((ends-with? path ".jpg")  "image/jpeg")
    ((ends-with? path ".ico")  "image/x-icon")
    (else "application/octet-stream")))

;;; ── Response builders ───────────────────────────────────────

(define (inline-response status ctype body)
  (string-append
    "HTTP/1.0 " status *crlf*
    "Content-Type: " ctype *crlf*
    "Content-Length: " (number->string (string-length body)) *crlf*
    "Connection: close" *crlf-crlf*
    body))

(define (headers-only status ctype nbytes)
  (string-append
    "HTTP/1.0 " status *crlf*
    "Content-Type: " ctype *crlf*
    "Content-Length: " (number->string nbytes) *crlf*
    "Connection: close" *crlf-crlf*))

(define (url-to-fs url-path)
  (cond
    ((string=? url-path "/") (string-append *docroot* "/index.html"))
    (else (string-append *docroot* url-path))))

;;; ── Cache ───────────────────────────────────────────────────
;;;
;;; Two tables keyed by URL path:
;;;   *cache-inline*  url -> full HTTP response (string)
;;;   *cache-sendfile* url -> (headers . fs-path) pair
;;;
;;; Per-request handler hits one or the other, never both.

(define *cache-inline*   (make-hash-table))
(define *cache-sendfile* (make-hash-table))

(define (cache-count)
  (+ (hash-table-size *cache-inline*)
     (hash-table-size *cache-sendfile*)))

(define (cache-add! url-path)
  (if (>= (cache-count) *cache-max*)
      (begin
        (display "cache-add!: skipped (cap reached): ")
        (display url-path) (newline)
        'capped)
      (let ((fs-path (url-to-fs url-path)))
        (let ((body (file->string fs-path)))
          (cond
            ((not body)
              (display "cache-add!: missing file: ")
              (display fs-path) (newline)
              'missing)
            ((<= (string-length body) *inline-threshold*)
              (hash-table-set! *cache-inline* url-path
                (inline-response "200 OK" (mime-of fs-path) body))
              'inline)
            (else
              (hash-table-set! *cache-sendfile* url-path
                (cons (headers-only "200 OK" (mime-of fs-path)
                                    (string-length body))
                      fs-path))
              'sendfile))))))

(define *preload-paths*
  (list "/"
        "/style.css"
        "/whitepaper.pdf"
        "/robots.txt"
        "/404.html"))

(define *resp-404*
  (let ((body (file->string (string-append *docroot* "/404.html"))))
    (if body
        (inline-response "404 Not Found" "text/html; charset=utf-8" body)
        (inline-response "404 Not Found" "text/plain" "not found\n"))))

(define (preload-all paths)
  (cond
    ((null? paths) 'done)
    (else
      (cache-add! (car paths))
      (preload-all (cdr paths)))))

(preload-all *preload-paths*)

;;; ── Request parsing ─────────────────────────────────────────

(define SPACE 32)
(define (char-at s i) (char->integer (string-ref s i)))

(define (second-token s)
  (let ((len (string-length s)))
    (let loop1 ((i 0))
      (cond
        ((= i len) "/")
        ((= (char-at s i) SPACE)
         (let loop2 ((j (+ i 1)))
           (cond
             ((= j len) (substring s (+ i 1) len))
             ((= (char-at s j) SPACE) (substring s (+ i 1) j))
             (else (loop2 (+ j 1))))))
        (else (loop1 (+ i 1)))))))

;;; ── Per-request dispatch ────────────────────────────────────

(define (serve client req)
  (let ((path (second-token req)))
    (let ((inline (hash-table-ref/default *cache-inline* path #f)))
      (if inline
          (tcp-send client inline)
          (let ((sf (hash-table-ref/default *cache-sendfile* path #f)))
            (if sf
                (begin
                  (tcp-send     client (car sf))
                  (tcp-sendfile client (cdr sf)))
                (tcp-send client *resp-404*)))))))

;;; ── Main loop ───────────────────────────────────────────────

(define server (tcp-listen *port*))

(define (server-loop n snap)
  (if (>= n *max-requests*)
      (begin
        (display "request cap reached, exiting\n")
        (tcp-close server))
      (begin
        (let ((client (tcp-accept server)))
          (let ((req (tcp-recv client 4096)))
            (if (and req (> (string-length req) 0))
                (serve client req)
                #f))
          (tcp-close client))
        (heap-restore snap)
        (server-loop (+ n 1) snap))))

(display "lumbda-www sendfile on :") (display *port*)
(display " serving ") (display *docroot*)
(display " (") (display (hash-table-size *cache-inline*))
(display " inline, ") (display (hash-table-size *cache-sendfile*))
(display " sendfile, cap ") (display *cache-max*) (display ")")
(newline)
(server-loop 0 (heap-snapshot))