; web.wisp — a small HTTP/1.1 server that runs inside a REPL session.
; Serves files under `public/` (relative to the session's filesystem root),
; one request per connection: read the request line, answer, close.
; The session's on-connection/on-data handlers call web-connection/web-data
; (see site/serve.wisp), so (reload web) changes the live server.
(module web
  (provide web-connection web-data web-path content-type)

  (define byte-space (string-ref " " 0))
  (define root "public")

  ; index of the first byte equal to `b` in `s` at or after `i`; -1 if none.
  (define find-byte (lambda (s b i)
    (if (= i (string-len s)) -1
      (if (= (string-ref s i) b) i (find-byte s b (+ i 1))))))

  ; does `s` end with `suffix`?
  (define ends-with (lambda (s suffix)
    (let (n (string-len s))
      (let (k (string-len suffix))
        (if (< n k) 0
          (string=? (substring s (- n k) n) suffix))))))

  ; does `s` start with `prefix`?
  (define starts-with (lambda (s prefix)
    (if (< (string-len s) (string-len prefix)) 0
      (string=? (substring s 0 (string-len prefix)) prefix))))

  ; index of `pat` in `s` at or after `i`, or -1. Jumps between bytes that
  ; match pat's first byte, so it allocates only at those candidates.
  (define find-str (lambda (s pat i)
    (let (j (find-byte s (string-ref pat 0) i))
      (if (< j 0) -1
        (if (< (string-len s) (+ j (string-len pat))) -1
          (if (string=? (substring s j (+ j (string-len pat))) pat) j
            (find-str s pat (+ j 1))))))))

  ; does `s` contain `pat` at or after `i`?
  (define contains (lambda (s pat i)
    (if (< (find-str s pat i) 0) 0 1)))

  ; the request target from "GET /path HTTP/1.1...", or "" if malformed.
  (define web-path (lambda (req)
    (let (a (find-byte req byte-space 0))
      (if (< a 0) ""
        (let (b (find-byte req byte-space (+ a 1)))
          (if (< b 0) "" (substring req (+ a 1) b)))))))

  ; strip a query string: "/a?x=1" -> "/a"
  (define strip-query (lambda (p)
    (let (q (find-byte p (string-ref "?" 0) 0))
      (if (< q 0) p (substring p 0 q)))))

  (define content-type (lambda (p)
    (if (ends-with p ".html") "text/html; charset=utf-8"
      (if (ends-with p ".css") "text/css; charset=utf-8"
        (if (ends-with p ".js") "text/javascript; charset=utf-8"
          (if (ends-with p ".svg") "image/svg+xml"
            (if (ends-with p ".txt") "text/plain; charset=utf-8"
            (if (ends-with p ".wisp") "text/plain; charset=utf-8"
              "application/octet-stream"))))))))

  ; join a list of strings (string-append takes exactly two)
  (define cat (lambda (xs)
    (if (null? xs) "" (string-append (car xs) (cat (cdr xs))))))

  ; non-negative integer -> decimal text
  (define num->str (lambda (n)
    (if (< n 10) (substring "0123456789" n (+ n 1))
      (string-append (num->str (/ n 10)) (num->str (- n (* 10 (/ n 10))))))))

  (define response (lambda (status ctype body)
    (cat (list "HTTP/1.1 " status "\r\n"
      "Content-Type: " ctype "\r\n"
      "Content-Length: " (num->str (string-len body)) "\r\n"
      "Connection: close\r\n\r\n" body))))

  ; "/" -> public/index.html, "/about" -> public/about.html, "/x.css" -> public/x.css
  (define file-for (lambda (p)
    (if (string=? p "/source") "web.wisp"
    (if (string=? p "/") (string-append root "/index.html")
      (if (ends-with p "/") (cat (list root p "index.html"))
        (if (< (find-byte p (string-ref "." 0) 0) 0)
          (cat (list root p ".html"))
          (string-append root p)))))))

  ; every occurrence of `pat` in `s` replaced by `rep`, scanning from `i`
  (define replace-from (lambda (s pat rep i)
    (let (j (find-str s pat i))
      (if (< j 0) s
        (replace-from
          (cat (list (substring s 0 j) rep (substring s (+ j (string-len pat)) (string-len s))))
          pat rep (+ j (string-len rep)))))))

  ; the value for `k` in an association list of (key value) pairs; 0 if absent
  (define assoc-get (lambda (k xs)
    (if (null? xs) 0
      (if (string=? (car (car xs)) k) (car (cdr (car xs))) (assoc-get k (cdr xs))))))

  ; ── live introspection ────────────────────────────────────────────────
  ; Public: counts, names, statuses and request paths only. Paths come from
  ; visitors, so they are escaped and cut short.

  (define b-lt (string-ref "<" 0))
  (define b-gt (string-ref ">" 0))
  (define b-amp (string-ref "&" 0))
  (define b-quot (string-ref "\"" 0))
  (define b-apos (string-ref "'" 0))

  (define esc-byte (lambda (s i)
    (let (c (string-ref s i))
      (if (= c b-lt) "&lt;"
        (if (= c b-gt) "&gt;"
          (if (= c b-amp) "&amp;"
            (if (= c b-quot) "&quot;"
              (if (= c b-apos) "&#39;" (substring s i (+ i 1))))))))))

  (define esc-from (lambda (s i acc)
    (if (= i (string-len s)) acc
      (esc-from s (+ i 1) (string-append acc (esc-byte s i))))))

  (define html-escape (lambda (s)
    (esc-from (if (< 80 (string-len s)) (string-append (substring s 0 80) "...") s) 0 "")))

  (define take (lambda (xs n)
    (if (null? xs) xs
      (if (= n 0) (list) (cons (car xs) (take (cdr xs) (- n 1)))))))

  ; on-data results (request paths) from firing entries (seq handler result),
  ; oldest first in, newest first out
  (define paths-of (lambda (entries acc)
    (if (null? entries) acc
      (paths-of (cdr entries)
        (if (string=? (car (cdr (car entries))) "on-data")
          (cons (car (cdr (cdr (car entries)))) acc)
          acc)))))

  (define recent-items (lambda (xs)
    (if (null? xs) ""
      (string-append (cat (list "<li><code>" (html-escape (car xs)) "</code></li>"))
        (recent-items (cdr xs))))))

  ; the last 12 request paths, newest first
  (define recent (lambda ()
    (let (head (event-head))
      (let (r (events-after (if (< head 60) 0 (- head 60))))
        (recent-items (take (paths-of (cdr (cdr r)) (list)) 12))))))

  (define status-of (lambda (id)
    (match (actor-status id) ((ok s) s) ((err e) "unknown"))))

  (define actor-items (lambda (xs)
    (if (null? xs) ""
      (string-append
        (match (car xs)
          ((actor-info id name parent)
            (cat (list "<li><code>" (html-escape name) "</code> <span class=\"small\">"
              (substring id 0 8) " &middot; " (html-escape (status-of id)) "</span></li>"))))
        (actor-items (cdr xs))))))

  (define actors (lambda ()
    (match (list-actors) ((ok xs) (actor-items xs)) ((err e) ""))))

  ; This session's own event chain, from the daemon's chain recorder
  ; (chain-watch). Types, short hashes and sizes only: the payloads hold what
  ; visitors sent. Recording starts on the first request that asks, so it
  ; starts again by itself after a restart.

  (define short-hash (lambda (h)
    (if (< (string-len h) 12) h (substring h 0 12))))

  ; the events in xs (oldest first) up to and including the one with hash
  ; `head`, newest first. Reading the chain adds events after the head; this
  ; leaves them out, so the list ends where the head is.
  (define upto-head (lambda (xs head acc)
    (if (null? xs) acc
      (match (car xs)
        ((chain-event hash parent type size)
          (if (string=? hash head) (cons (car xs) acc)
            (upto-head (cdr xs) head (cons (car xs) acc))))))))

  (define chain-items (lambda (xs)
    (if (null? xs) ""
      (string-append
        (match (car xs)
          ((chain-event hash parent type size)
            (cat (list "<li><code>" (short-hash hash) "</code> " (html-escape type)
              " <span class=\"small\">" (num->str size) " bytes</span></li>"))))
        (chain-items (cdr xs))))))

  (define linked (lambda ()
    (match (chain-verify (self))
      ((ok c) (match c ((chain-check good count kept dropped breaks from-root)
        (if good "yes" (cat (list "no: " (num->str breaks) " breaks"))))))
      ((err e) "unknown"))))

  ; head hash, count, whether it links up, and the newest 10 events
  (define chain (lambda ()
    (match (chain-head (self))
      ((ok h)
        (match h ((chain-head head count recording)
          (cat (list
            "<dl class=\"stats\"><dt>head</dt><dd><code>" (short-hash head) "</code></dd>"
            "<dt>events recorded</dt><dd>" (num->str count) "</dd>"
            "<dt>each links to the last</dt><dd>" (linked) "</dd></dl>"
            "<ul class=\"plain\">"
            (match (chain-tail (self) 40)
              ((ok xs) (chain-items (take (upto-head xs head (list)) 10)))
              ((err e) ""))
            "</ul>")))))
      ((err e)
        (begin (chain-watch (self))
          "<p class=\"small\">Recording just started. Reload to see it.</p>")))))

  ; live values for an HTML page:
  ;   {{events}}  events this session has handled (3 per request)
  ;   {{heap}}    this session's heap, in KB
  ;   {{actors}}  <li> per actor in the runtime: name, short id, status
  ;   {{recent}}  <li> per recent request path, newest first
  ;   {{chain}}   this session's event chain: head, count, newest 10 events
  ; An unknown key is left as it is.
  (define value-of (lambda (key)
    (if (string=? key "events") (num->str (assoc-get "event-seq" (memory-stats)))
      (if (string=? key "heap") (num->str (/ (assoc-get "heap-bytes" (memory-stats)) 1024))
        (if (string=? key "actors") (actors)
          (if (string=? key "recent") (recent)
            (if (string=? key "chain") (chain)
              (cat (list "{{" key "}}")))))))))

  ; one pass: the text before each {{key}}, then its value, then the rest
  (define fill-from (lambda (html i acc)
    (let (a (find-str html "{{" i))
      (if (< a 0) (cat (list acc (substring html i (string-len html))))
        (let (b (find-str html "}}" (+ a 2)))
          (if (< b 0) (cat (list acc (substring html i (string-len html))))
            (fill-from html (+ b 2)
              (cat (list acc (substring html i a) (value-of (substring html (+ a 2) b)))))))))))

  (define fill (lambda (html) (fill-from html 0 "")))

  (define not-found (response "404 Not Found" "text/html; charset=utf-8"
    "<!doctype html><title>Not found</title><p>Nothing here.</p>"))

  ; the full response for a raw request
  (define answer (lambda (req)
    (let (p (strip-query (web-path req)))
      (if (string=? p "") (response "400 Bad Request" "text/plain" "bad request\n")
        (if (contains p ".." 0) not-found
          (let (f (file-for p))
            (match (fs-read f)
              ((ok body)
                (let (text (bytes->string body))
                  (response "200 OK" (content-type f)
                    ; docs (public/docs/) are built pages: no live keys to fill
                    (if (ends-with f ".html")
                      (if (starts-with f "public/docs/") text (fill text))
                      text))))
              ((err e) not-found))))))))

  (define web-connection (lambda (cid)
    (begin
      (tcp-activate cid)
      (tcp-set-active cid "active")
      cid)))

  ; e = (conn-id bytes). Answers and closes; returns "METHOD path" for the log.
  (define web-data (lambda (e)
    (let (cid (car e))
      (let (req (bytes->string (car (cdr e))))
        (begin
          (tcp-send cid (answer req))
          (tcp-close cid)
          (web-path req)))))))