Initial import of rkt-web-player

2026-08-26 22:12:52 +02:00
parent e1247719a9
commit d22a7ad529
13 changed files with 3045 additions and 1 deletions
@@ -0,0 +1,92 @@
+#lang racket/base
+
+(require json
+         racket/contract
+         racket/runtime-path
+         web-server/dispatch
+         web-server/http
+         web-server/http/json
+         web-server/servlet-env
+         "player.rkt")
+
+(provide serve-player)
+
+(define-runtime-path public-directory "../public")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HTTP handlers
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define current-player #f)
+
+(define (json-response value #:code [code 200])
+  (response/jsexpr
+   value
+   #:code code
+   #:headers (list (header #"Cache-Control" #"no-store"))))
+
+(define (error-response exception)
+  (json-response
+   (hasheq 'error (exn-message exception))
+   #:code 400))
+
+(define (request-jsexpr request)
+  (let ((body (request-post-data/raw request)))
+    (if (and body (positive? (bytes-length body)))
+        (bytes->jsexpr body)
+        (hasheq))))
+
+(define (state-handler _request)
+  (json-response (player-state->jsexpr current-player)))
+
+(define (discover-handler _request)
+  (player-discover! current-player)
+  (json-response (player-state->jsexpr current-player)))
+
+(define (command-handler request command)
+  (with-handlers
+      ((exn:fail? error-response))
+    (json-response
+     (player-command!
+      current-player
+      command
+      (request-jsexpr request)))))
+
+(define-values (dispatch _url)
+  (dispatch-rules
+   [("api" "state") #:method "get" state-handler]
+   [("api" "discover") #:method "post" discover-handler]
+   [("api" "command" (string-arg))
+    #:method "post"
+    command-handler]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Provided functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Serve the web interface and JSON player API.
+; pre    : Value is a player, listen-ip is a string, and port is valid.
+; post   : Static files and API routes are served until the server stops.
+; result : The result returned by serve/servlet.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define/contract (serve-player value
+                               #:listen-ip [listen-ip "127.0.0.1"]
+                               #:port [port 8080]
+                               #:launch-browser? [launch-browser? #t])
+  (->* (any/c)
+       (#:listen-ip string?
+        #:port exact-positive-integer?
+        #:launch-browser? boolean?)
+       any)
+  (set! current-player value)
+  (serve/servlet
+   dispatch
+   #:listen-ip listen-ip
+   #:port port
+   #:connection-close? #t
+   #:launch-browser? launch-browser?
+   #:quit? #f
+   #:banner? #t
+   #:servlet-regexp #rx"^/api(?:/|$)"
+   #:extra-files-paths (list public-directory)))