From 3b8e1dfe2e0e82b52f512b5e270989340ae44f98 Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 25 Jun 2026 21:51:41 +0000 Subject: [PATCH] host: live writes via signed sessions + kernel multi-Set-Cookie (193/193) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Unblock the guarded blog write routes for browsers: a login form sets a signed session cookie that the same routes accept (alongside Bearer), so publishing works end-to-end on blog.rose-ash.com without Quart. - kernel: http-listen emit serialises a response :set-cookies LIST as one Set-Cookie header each (a headers dict can't hold more than one). Purely additive — responses without :set-cookies are unchanged. - server.sx: host/-dream->native forwards :set-cookies to the native resp. - lib/host/session.sx: durable, signed sessions on the persist KV (session/create|exists|get|set|clear), wired via dream-sessions-signed. - lib/host/auth.sx: GET/POST /login + POST /logout; host/require-user accepts a session principal OR a Bearer token. - router.sx: host/make-app wraps the whole app in the session middleware and auto-mounts /login + /logout — the front door always has sessions. - blog.sx: write routes use host/require-user; serve.sh flips POST /new from the experimental UNGUARDED route to the guarded write routes, with admin creds + signing secret + ACL grant from the container env. - session conformance suite (12): login->cookie->guarded write 201; no cookie/forged/logged-out -> 401; Bearer fallback still works. Verified live on blog.rose-ash.com: 401 unauthenticated, 303 login, 303 publish, anonymous read renders, post persists across container recreate. Co-Authored-By: Claude Opus 4.8 --- docker-compose.dev-sx-host.yml | 7 ++ hosts/ocaml/bin/sx_server.ml | 12 ++++ lib/host/auth.sx | 96 +++++++++++++++++++++++++++ lib/host/blog.sx | 2 +- lib/host/conformance.sh | 4 ++ lib/host/router.sx | 16 +++-- lib/host/serve.sh | 42 +++++++++--- lib/host/server.sx | 6 +- lib/host/session.sx | 70 ++++++++++++++++++++ lib/host/tests/session.sx | 117 +++++++++++++++++++++++++++++++++ 10 files changed, 357 insertions(+), 15 deletions(-) create mode 100644 lib/host/auth.sx create mode 100644 lib/host/session.sx create mode 100644 lib/host/tests/session.sx diff --git a/docker-compose.dev-sx-host.yml b/docker-compose.dev-sx-host.yml index 3621980d..63536980 100644 --- a/docker-compose.dev-sx-host.yml +++ b/docker-compose.dev-sx-host.yml @@ -22,6 +22,13 @@ services: SX_HTTP_HOST: "0.0.0.0" # Durable persist store root — on a named volume so data survives restarts. SX_PERSIST_DIR: /data/persist + # Blog write auth: admin login + session-cookie signing secret. The blog + # write routes (POST /new, POST/PUT/DELETE /posts) are guarded by a session + # login or Bearer token, so these gate publishing. Not a real site — these + # are demo creds; rotate by editing here and recreating the container. + SX_ADMIN_USER: admin + SX_ADMIN_PASSWORD: "sx-host-camper-van-2026" + SX_SESSION_SECRET: "ra-host-sess-7c1f9b3e2a8d4056" OCAMLRUNPARAM: "b" volumes: # SX source (hot-reload on container restart) diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index b4c00115..3cae0201 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -850,6 +850,18 @@ let setup_evaluator_bridge env = List.iter (fun (k, v) -> Buffer.add_string buf (Printf.sprintf "%s: %s\r\n" k v)) rhdrs; + (* Cookies: a response carries :set-cookies as a LIST of pre-formatted + cookie strings (Dream's dream-set-cookie), because a headers Dict + cannot hold more than one Set-Cookie. Emit one header per item. *) + (match getk "set-cookies" with + | Some (List items) -> + List.iter (fun v -> + match v with + | String s -> + Buffer.add_string buf + (Printf.sprintf "Set-Cookie: %s\r\n" s) + | _ -> ()) items + | _ -> ()); if not (List.exists (fun (k, _) -> String.lowercase_ascii k = "content-type") diff --git a/lib/host/auth.sx b/lib/host/auth.sx new file mode 100644 index 00000000..95fe9afc --- /dev/null +++ b/lib/host/auth.sx @@ -0,0 +1,96 @@ +;; lib/host/auth.sx — browser login on top of host sessions (lib/host/session.sx). +;; A login form posts credentials; on success the principal is written to the +;; session cookie. The guarded write routes then accept EITHER a logged-in session +;; OR a Bearer token (host/require-user), so the same routes serve browsers and API +;; clients. Single admin user; credentials come from $SX_ADMIN_USER / _PASSWORD +;; (set in serve.sh) — the in-source defaults are dev-only. +;; +;; Depends on lib/host/session.sx, lib/host/{handler,middleware}.sx, lib/dream/* +;; (form/types/session) + the kernel render-page primitive. + +;; ── page shell (own copy; render-page renders the static SX tree) ─── +(define host/-auth-page + (fn (title body) + (str "" + (render-page + (quasiquote + (html + (head (meta :charset "utf-8") (title (unquote title))) + (body (unquote body)))))))) + +;; ── admin credential (override from env in serve.sh) ──────────────── +(define host/admin-user "admin") +(define host/admin-password "letmein") +(define host/auth-set-admin! + (fn (u p) (begin (set! host/admin-user u) (set! host/admin-password p)))) +(define host/-verify-cred + (fn (user pass) + (and (not (= pass "")) + (= user host/admin-user) + (= pass host/admin-password)))) + +;; ── GET /login — minimal SX login form ────────────────────────────── +(define host/login-page + (fn (req) + (dream-html + (host/-auth-page "Log in" + (quasiquote + (div + (h1 "Log in") + (form :method "post" :action "/login" + (p (input :name "username" :placeholder "username")) + (p (input :name "password" :type "password" :placeholder "password")) + (p (button :type "submit" "Log in"))))))))) + +;; ── POST /login — verify, write session principal, redirect home ──── +;; The session middleware (host/sessions) has already created/loaded the session +;; and will set the cookie on this response, so writing :principal here lands on +;; the right sid and the browser keeps the cookie. +(define host/login-submit + (fn (req) + (let ((user (dream-form-field req "username")) + (pass (dream-form-field req "password"))) + (if (host/-verify-cred user pass) + (begin + (host/login! req user) + (dream-redirect "/")) + (dream-html-status 401 + (host/-auth-page "Log in" + (quasiquote + (div (h1 "Log in") + (p "Invalid credentials.") + (p (a :href "/login" "Try again.")))))))))) + +;; ── POST /logout — clear the session, redirect home ───────────────── +(define host/logout-submit + (fn (req) + (begin + (host/logout! req) + (dream-redirect "/")))) + +;; ── login routes (mounted by host/make-app) ───────────────────────── +(define host/auth-routes + (list + (dream-get "/login" host/login-page) + (dream-post "/login" host/login-submit) + (dream-post "/logout" host/logout-submit))) + +;; ── auth middleware: session principal OR bearer token ────────────── +;; Place AFTER the session middleware (so host/current-principal can read the +;; session) and BEFORE host/require-permission. resolve : token -> principal | nil +;; is the bearer fallback for API clients; a logged-in browser needs no token. +(define host/require-user + (fn (resolve) + (fn (next) + (fn (req) + (let ((sp (host/current-principal req))) + (let ((principal + (if (and sp (not (= sp ""))) + sp + (let ((tok (dream-bearer-token req))) + (if tok (resolve tok) nil))))) + (if (or (nil? principal) (= principal "")) + (dream-add-header + (host/error 401 "unauthorized") + "www-authenticate" "Bearer") + (next (assoc req :dream-principal principal))))))))) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index a6ac57d9..1322a8c1 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -234,7 +234,7 @@ (host/pipeline (list host/wrap-errors - (host/require-auth resolve) + (host/require-user resolve) (host/require-permission "edit" (fn (req) "blog"))) h))) (define host/blog-write-routes diff --git a/lib/host/conformance.sh b/lib/host/conformance.sh index c5ab4f1b..0a4ad863 100755 --- a/lib/host/conformance.sh +++ b/lib/host/conformance.sh @@ -68,9 +68,12 @@ MODULES=( "lib/dream/auth.sx" "lib/dream/error.sx" "lib/dream/form.sx" + "lib/dream/session.sx" "lib/dream/router.sx" "lib/host/handler.sx" "lib/host/middleware.sx" + "lib/host/session.sx" + "lib/host/auth.sx" "lib/host/sxtp.sx" "lib/host/router.sx" "lib/host/feed.sx" @@ -90,6 +93,7 @@ SUITES=( "feed host-fd-tests-run! lib/host/tests/feed.sx" "relations host-rl-tests-run! lib/host/tests/relations.sx" "blog host-bl-tests-run! lib/host/tests/blog.sx" + "session host-se-tests-run! lib/host/tests/session.sx" "page host-pg-tests-run! lib/host/tests/page.sx" "server host-sv-tests-run! lib/host/tests/server.sx" "ledger host-lg-tests-run! lib/host/tests/ledger.sx" diff --git a/lib/host/router.sx b/lib/host/router.sx index 400b3df7..678ae9fb 100644 --- a/lib/host/router.sx +++ b/lib/host/router.sx @@ -4,16 +4,22 @@ ;; request -> response. Each subsystem contributes a list of Dream routes (see ;; lib/host/feed.sx); host/make-app concatenates them under one router. ;; dr/flatten-routes (Dream) flattens the nested groups, so a group is just a list -;; of routes. Depends on lib/dream/router.sx + lib/host/handler.sx. +;; of routes. Depends on lib/dream/router.sx + lib/host/handler.sx + the host +;; session middleware (lib/host/session.sx) and login routes (lib/host/auth.sx). ;; Liveness probe — GET /health -> 200 {"ok":true,"data":"healthy"}. (define host/health-route (dream-get "/health" (fn (req) (host/ok "healthy")))) ;; Build the host app from a list of route groups (each a list of Dream routes). -;; The health route is always mounted first; Dream's router returns a JSON-free -;; 404 for unmatched paths, which host endpoints override per-domain as needed. +;; The health route + login routes are always mounted; Dream's router returns a +;; JSON 404 for unmatched paths, which host endpoints override per-domain as +;; needed. The WHOLE app is wrapped in the signed-session middleware so every +;; request carries a session and any handler can log a principal in/out — this is +;; the front door, so sessions are not optional. (define host/make-app (fn (groups) - (dream-router - (cons host/health-route groups)))) + (let ((router (dream-router + (cons host/health-route + (cons host/auth-routes groups))))) + ((host/sessions) router)))) diff --git a/lib/host/serve.sh b/lib/host/serve.sh index 0d7d8680..c31c2dc4 100755 --- a/lib/host/serve.sh +++ b/lib/host/serve.sh @@ -73,9 +73,12 @@ MODULES=( "lib/dream/auth.sx" "lib/dream/error.sx" "lib/dream/form.sx" + "lib/dream/session.sx" "lib/dream/router.sx" "lib/host/handler.sx" "lib/host/middleware.sx" + "lib/host/session.sx" + "lib/host/auth.sx" "lib/host/sxtp.sx" "lib/host/router.sx" "lib/host/feed.sx" @@ -84,6 +87,13 @@ MODULES=( "lib/host/server.sx" ) +# Admin login credentials + session signing secret. Override via the container +# env; the in-source defaults are dev-only. The blog write routes are now GUARDED +# (session login or Bearer), so these gate publishing on blog.rose-ash.com. +ADMIN_USER="${SX_ADMIN_USER:-admin}" +ADMIN_PASS="${SX_ADMIN_PASSWORD:-letmein}" +SESSION_SECRET="${SX_SESSION_SECRET:-rose-ash-host-dev-secret-change-me}" + EPOCH=1 { for M in "${MODULES[@]}"; do @@ -95,16 +105,32 @@ EPOCH=1 echo "(epoch $EPOCH)" echo "(eval \"(host/blog-use-store! (persist/durable-backend))\")" EPOCH=$((EPOCH+1)) + # Session signing secret + admin login credentials, then grant the admin + # principal "edit" on "blog" so a logged-in session passes the ACL gate on the + # write routes. Sessions stay IN-MEMORY (default store) — logins reset on + # restart but the durable KV isn't spammed by anonymous/ crawler sessions + # (lazy session creation is a future lib/dream/session.sx improvement). + echo "(epoch $EPOCH)" + echo "(eval \"(host/session-set-secret! \\\"$SESSION_SECRET\\\")\")" + EPOCH=$((EPOCH+1)) + echo "(epoch $EPOCH)" + echo "(eval \"(host/auth-set-admin! \\\"$ADMIN_USER\\\" \\\"$ADMIN_PASS\\\")\")" + EPOCH=$((EPOCH+1)) + echo "(epoch $EPOCH)" + echo "(eval \"(acl/load! (list (acl-grant \\\"$ADMIN_USER\\\" \\\"edit\\\" \\\"blog\\\")))\")" + EPOCH=$((EPOCH+1)) + # Idempotently seed a welcome post (sx_content = SX element markup, the editor's + # content model). Re-seeding is a no-op if the slug already exists. echo "(epoch $EPOCH)" echo "(eval \"(host/blog-seed! \\\"welcome\\\" \\\"Welcome to the SX host\\\" \\\"(article (h1 \\\\\\\"Welcome to the SX host\\\\\\\") (p \\\\\\\"Rendered by lib/host via render-to-html, from the durable SX store.\\\\\\\"))\\\" \\\"published\\\")\")" EPOCH=$((EPOCH+1)) echo "(epoch $EPOCH)" - # Anonymous read endpoints: feed timeline + relations container reads + blog - # post detail (blog-routes LAST — the :slug catch-all must not shadow the rest). - # Guarded write groups (auth/ACL or internal-HMAC) are added here once their - # injected policy is supplied at wiring time. - # EXPERIMENTAL: host/blog-open-create-routes mounts POST /new UNGUARDED (no - # auth) so the editor can publish end-to-end on the experimental subdomain. - # Create-only (no PUT/DELETE). GATE (Caddy basicauth / sessions) before real use. - echo "(eval \"(host/serve $PORT (list host/feed-routes host/relations-routes host/blog-open-create-routes host/blog-routes))\")" + # Anonymous reads (feed timeline + relations container reads + blog post detail) + # plus the GUARDED blog write routes: POST /new (editor form ingest), POST/PUT/ + # DELETE /posts behind host/require-user (session login OR Bearer) + ACL. make-app + # auto-mounts /login + /logout and wraps everything in the signed-session + # middleware, so a browser logs in then publishes. The bearer resolver is a stub + # (no API tokens configured) — browser session is the live auth path for now. + # blog-routes LAST — its GET /:slug catch-all must not shadow the rest. + echo "(eval \"(host/serve $PORT (list host/feed-routes host/relations-routes (host/blog-write-routes (fn (tok) nil)) host/blog-routes))\")" } | exec "$SX_SERVER" diff --git a/lib/host/server.sx b/lib/host/server.sx index 77850f18..b9f0ff07 100644 --- a/lib/host/server.sx +++ b/lib/host/server.sx @@ -23,11 +23,15 @@ ;; ── dream response -> native response ─────────────────────────────── ;; dream-response is already {:body :headers :status}; the native server wants ;; {:status :headers :body}. Same keys — normalise the shape explicitly so the -;; contract is visible (and headers/body never nil). +;; contract is visible (and headers/body never nil). :set-cookies is a LIST of +;; pre-formatted cookie strings (Dream's dream-set-cookie); the kernel http-listen +;; emit serialises one Set-Cookie header per item (a headers dict can't hold more +;; than one). Carry it through so sessions/login can set the cookie. (define host/-dream->native (fn (resp) {:status (dream-status resp) :headers (or (dream-headers resp) {}) + :set-cookies (dream-resp-cookies resp) :body (or (dream-resp-body resp) "")})) ;; ── adapter + serve ───────────────────────────────────────────────── diff --git a/lib/host/session.sx b/lib/host/session.sx new file mode 100644 index 00000000..5004617c --- /dev/null +++ b/lib/host/session.sx @@ -0,0 +1,70 @@ +;; lib/host/session.sx — durable, signed sessions for the host. +;; Backs Dream's session middleware ops (session/create|exists|get|set|clear) +;; with the SAME durable persist KV the blog uses, so a login survives restarts. +;; The session cookie carries only a signed sid (dream-sessions-signed): the sid +;; itself is a persisted monotonic counter ("s1", "s2", …) — cheap and ordered — +;; and the HMAC signature (dr/sess-hash, keyed by host/session-secret) makes a +;; guessed or forged cookie unusable. http-listen serialises handler calls under a +;; mutex, so the counter increment is race-free. +;; +;; Depends on lib/dream/session.sx (dream-sessions-signed + cookie helpers) and +;; lib/persist/* (the KV backend). Wired into host/make-app via host/sessions. + +;; ── store (durable persist KV, injectable; mirrors host/blog-store) ── +(define host/session-store (persist/open)) +(define host/session-use-store! (fn (b) (set! host/session-store b))) + +;; ── signing secret (override from $SX_SESSION_SECRET in serve.sh) ──── +(define host/session-secret "rose-ash-host-dev-secret-change-me") +(define host/session-set-secret! (fn (s) (set! host/session-secret s))) + +;; ── keys ──────────────────────────────────────────────────────────── +(define host/-sess-key (fn (sid) (str "session:" sid))) +(define host/-sess-counter-key "session:-counter") + +;; mint the next sid from a persisted counter (signature guards guessability) +(define host/-sess-next-sid + (fn () + (let ((n (+ 1 (or (persist/backend-kv-get host/session-store host/-sess-counter-key) 0)))) + (begin + (persist/backend-kv-put host/session-store host/-sess-counter-key n) + (str "s" n))))) + +;; ── backend io fn: dispatch session/* ops onto the persist KV ─────── +(define host/session-backend + (fn (op) + (let ((kind (get op :op))) + (cond + ((= kind "session/create") + (let ((sid (host/-sess-next-sid))) + (begin + (persist/backend-kv-put host/session-store (host/-sess-key sid) {}) + sid))) + ((= kind "session/exists") + (persist/backend-kv-has? host/session-store (host/-sess-key (get op :sid)))) + ((= kind "session/get") + (get + (or (persist/backend-kv-get host/session-store (host/-sess-key (get op :sid))) {}) + (get op :key))) + ((= kind "session/set") + (let ((sid (get op :sid))) + (persist/backend-kv-put host/session-store (host/-sess-key sid) + (assoc + (or (persist/backend-kv-get host/session-store (host/-sess-key sid)) {}) + (get op :key) + (get op :val))))) + ((= kind "session/load") + (or (persist/backend-kv-get host/session-store (host/-sess-key (get op :sid))) {})) + ((= kind "session/clear") + (persist/backend-kv-delete host/session-store (host/-sess-key (get op :sid)))) + (else nil))))) + +;; ── middleware for the host pipeline: signed cookie + durable backend ─ +(define host/sessions + (fn () (dream-sessions-signed host/session-backend host/session-secret))) + +;; ── handler-facing helpers ────────────────────────────────────────── +;; The logged-in principal (or nil), and login/logout writing the session field. +(define host/current-principal (fn (req) (dream-session-field req :principal))) +(define host/login! (fn (req principal) (dream-set-session-field req :principal principal))) +(define host/logout! (fn (req) (dream-invalidate-session req))) diff --git a/lib/host/tests/session.sx b/lib/host/tests/session.sx new file mode 100644 index 00000000..7b867af3 --- /dev/null +++ b/lib/host/tests/session.sx @@ -0,0 +1,117 @@ +;; lib/host/tests/session.sx — the live-write story end-to-end: a browser logs in +;; (POST /login) → signed session cookie → guarded write succeeds; no cookie → 401; +;; the Bearer path still works for API clients; logout drops the principal. +;; make-app auto-mounts /login + /logout and wraps everything in host/sessions, so +;; these tests drive the WHOLE app handler (session middleware + router) the way +;; the native server does. + +(define host-se-pass 0) +(define host-se-fail 0) +(define host-se-fails (list)) + +(define host-se-test + (fn (name actual expected) + (if (= actual expected) + (set! host-se-pass (+ host-se-pass 1)) + (begin + (set! host-se-fail (+ host-se-fail 1)) + (append! host-se-fails {:name name :actual actual :expected expected}))))) + +;; ── fixtures ──────────────────────────────────────────────────────── +(acl/load! (list (acl-grant "admin" "edit" "blog"))) +(host/auth-set-admin! "admin" "secret") +(host/session-set-secret! "test-session-secret") + +;; bearer fallback for API clients (session is the browser path) +(define host-se-resolve (fn (tok) (if (= tok "apitoken") "admin" nil))) + +;; a guarded write route isolating the session mechanism from blog specifics: +;; same pipeline shape as host/blog--protect (wrap-errors + require-user + ACL). +(define host-se-secure-h + (host/pipeline + (list + host/wrap-errors + (host/require-user host-se-resolve) + (host/require-permission "edit" (fn (req) "blog"))) + (fn (req) (host/ok-status 201 (host/principal req))))) + +(define host-se-app + (host/make-app (list (list (dream-post "/secure" host-se-secure-h))))) + +;; ── helpers ───────────────────────────────────────────────────────── +(define host-se-login + (fn (user pass) + (host-se-app + (dream-request "POST" "/login" {} + (str "username=" user "&password=" pass))))) + +;; the name=value pair from the Set-Cookie (drop the "; Path=…" attributes) +(define host-se-cookie-of + (fn (resp) + (let ((c (first (dream-resp-cookies resp)))) + (if (nil? c) nil (substr c 0 (index-of c ";")))))) + +(define host-se-secure + (fn (cookie) + (host-se-app + (dream-request "POST" "/secure" (if cookie {:cookie cookie} {}) "")))) + +(define host-se-secure-bearer + (fn (tok) + (host-se-app + (dream-request "POST" "/secure" {:authorization (str "Bearer " tok)} "")))) + +;; ── login ─────────────────────────────────────────────────────────── +(host-se-test "login good creds -> 303 redirect" + (dream-status (host-se-login "admin" "secret")) 303) +(host-se-test "login good creds sets a session cookie" + (not (nil? (host-se-cookie-of (host-se-login "admin" "secret")))) true) +(host-se-test "login bad creds -> 401" + (dream-status (host-se-login "admin" "wrong")) 401) + +;; ── session-authed write ──────────────────────────────────────────── +(host-se-test "logged-in session passes the guarded write -> 201" + (dream-status (host-se-secure (host-se-cookie-of (host-se-login "admin" "secret")))) + 201) +(host-se-test "principal threaded from the session to the handler" + (contains? + (dream-resp-body (host-se-secure (host-se-cookie-of (host-se-login "admin" "secret")))) + "\"data\":\"admin\"") + true) + +;; ── unauthenticated / forged ──────────────────────────────────────── +(host-se-test "no cookie -> 401" + (dream-status (host-se-secure nil)) 401) +(host-se-test "bad-cred login leaves an anonymous session (no principal) -> 401" + (dream-status (host-se-secure (host-se-cookie-of (host-se-login "admin" "wrong")))) + 401) +(host-se-test "forged cookie -> 401" + (dream-status (host-se-secure "dream.session=s1|forged")) 401) + +;; ── bearer fallback (API path still works) ────────────────────────── +(host-se-test "valid bearer token -> 201" + (dream-status (host-se-secure-bearer "apitoken")) 201) +(host-se-test "invalid bearer token -> 401" + (dream-status (host-se-secure-bearer "nope")) 401) + +;; ── logout ────────────────────────────────────────────────────────── +;; log in, get the cookie, log out with it, then the same cookie no longer authes. +(define host-se-logout + (fn (cookie) + (host-se-app + (dream-request "POST" "/logout" (if cookie {:cookie cookie} {}) "")))) +(define host-se-live-cookie (host-se-cookie-of (host-se-login "admin" "secret"))) +(host-se-test "logout returns 303" + (dream-status (host-se-logout host-se-live-cookie)) 303) +(host-se-test "after logout the cookie no longer authes -> 401" + (begin + (host-se-logout host-se-live-cookie) + (dream-status (host-se-secure host-se-live-cookie))) + 401) + +(define host-se-tests-run! + (fn () + {:total (+ host-se-pass host-se-fail) + :passed host-se-pass + :failed host-se-fail + :fails host-se-fails}))