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

;;; http-static-server-cached.lsp — lumbda.com's docroot served
;;; from an in-memory response cache. Every preloaded path's full
;;; HTTP/1.0 response (headers + body) is composed once at startup
;;; and stored in a hash-table, so the per-request handler is a
;;; single hash-table-ref. No file->string, no string-append, no
;;; MIME lookup in the hot path.
;;;
;;; Configuration:
;;;   *docroot*        filesystem root containing the files
;;;   *cache-max*      soft cap on cached entries (default 100)
;;;   *preload-paths*  list of URL paths to pre-fetch at startup
;;;
;;; Add a file: drop it in *docroot*, add its URL path to
;;; *preload-paths*, restart. A server restart is deliberate
;;; — cache lives forever across requests.
;;;
;;; Runs in any tier (Python/C/asm/asm-gc); target deployment is
;;; asm-gc (27 KB stripped, bounded RSS).

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

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

;;; ── HTTP / MIME helpers (startup-time only) ─────────────────

(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")))

(define (http-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 (url-to-fs url-path)
  (cond
    ((string=? url-path "/") (string-append *docroot* "/index.html"))
    (else (string-append *docroot* url-path))))

;;; ── Cache (hash-table: url-path → full HTTP response) ───────

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

(define (cache-count) (hash-table-size *cache*))

(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
            (body
              (hash-table-set! *cache* url-path
                (http-response "200 OK" (mime-of fs-path) body))
              'cached)
            (else
              (display "cache-add!: missing file: ") (display fs-path) (newline)
              'missing))))))

;;; Paths to preload. Anything not in this list returns 404.
(define *preload-paths*
  (list "/"
        "/style.css"
        "/whitepaper.pdf"
        "/robots.txt"
        "/404.html"))

;;; ── 404 / 403 (built once) ──────────────────────────────────

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

(define *resp-403*
  (http-response "403 Forbidden" "text/plain" "forbidden\n"))

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

(preload-all *preload-paths*)

;;; ── Per-request handler ────────────────────────────────────

(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)))))))

(define (handle-request req)
  (let ((path (second-token req)))
    (hash-table-ref/default *cache* path *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))
                (tcp-send client (handle-request req))
                #f))
          (tcp-close client))
        (heap-restore snap)
        (server-loop (+ n 1) snap))))

(display "lumbda-www cached on :") (display *port*)
(display " serving ") (display *docroot*)
(display " (") (display (cache-count)) (display "/") (display *cache-max*)
(display " cached)") (newline)
(server-loop 0 (heap-snapshot))