Files
kkkmeet/kkkmeet-server.el
T

511 lines
22 KiB
EmacsLisp

;;; kkkmeet-server.el --- Tiny WebRTC signaling server -*- lexical-binding: t; -*-
;; Run from a shell:
;; emacs -Q --batch -l kkkmeet-server.el -f kkkmeet-server-run-batch
;;
;; Or from Emacs:
;; M-x kkkmeet-server-start
(require 'cl-lib)
(require 'json)
(require 'seq)
(require 'subr-x)
(require 'url-util)
(defgroup kkkmeet-server nil
"Small static file and WebRTC signaling server for kkkmeet."
:group 'applications)
(defcustom kkkmeet-server-host "127.0.0.1"
"Host address for `kkkmeet-server-start'."
:type 'string)
(defcustom kkkmeet-server-port 3000
"Port for `kkkmeet-server-start'."
:type 'integer)
(defcustom kkkmeet-server-public-dir
(expand-file-name "public" default-directory)
"Directory containing the browser client."
:type 'directory)
(defvar kkkmeet-server--process nil)
(defvar kkkmeet-server--rooms (make-hash-table :test 'equal))
(defvar kkkmeet-server--watch-states (make-hash-table :test 'equal))
(defvar kkkmeet-server--presentation-states (make-hash-table :test 'equal))
(defconst kkkmeet-server--default-room-id "main")
(defconst kkkmeet-server--mime-types
'(("html" . "text/html; charset=utf-8")
("css" . "text/css; charset=utf-8")
("js" . "text/javascript; charset=utf-8")
("json" . "application/json; charset=utf-8")
("svg" . "image/svg+xml")))
(defun kkkmeet-server--uuid ()
"Return a UUID-like random peer id."
(let ((hex (md5 (format "%s-%s-%s" (current-time) (random) (emacs-pid)))))
(format "%s-%s-%s-%s-%s"
(substring hex 0 8)
(substring hex 8 12)
(substring hex 12 16)
(substring hex 16 20)
(substring hex 20 32))))
(defun kkkmeet-server--room (room-id)
"Return room hash table for ROOM-ID, creating it when needed."
(or (gethash room-id kkkmeet-server--rooms)
(puthash room-id (make-hash-table :test 'equal) kkkmeet-server--rooms)))
(defun kkkmeet-server--hash-keys (table)
"Return keys from hash TABLE."
(let (keys)
(maphash (lambda (key _value) (push key keys)) table)
(nreverse keys)))
(defun kkkmeet-server--room-peers (table)
"Return peer objects from room TABLE."
(let (peers)
(maphash
(lambda (peer-id process)
(push `((id . ,peer-id)
(name . ,(or (process-get process :kkkmeet-name) "Guest"))
(clientId . ,(or (process-get process :kkkmeet-client-id) "")))
peers))
table)
(vconcat (nreverse peers))))
(defun kkkmeet-server--normalize-name (name)
"Return a display-safe NAME."
(let ((normalized (string-trim (replace-regexp-in-string "[ \t\n\r]+" " " (or name "")))))
(if (string-empty-p normalized)
"Guest"
(substring normalized 0 (min 48 (length normalized))))))
(defun kkkmeet-server--normalize-announcement (text)
"Return a display-safe announcement TEXT."
(let ((normalized (string-trim (replace-regexp-in-string "[ \t\n\r]+" " " (or text "")))))
(substring normalized 0 (min 240 (length normalized)))))
(defun kkkmeet-server--normalize-client-id (value)
"Return a safe persistent client id from VALUE."
(let ((normalized (string-trim (or value ""))))
(if (string-match-p "\\`[A-Za-z0-9_-]\\{16,80\\}\\'" normalized)
normalized
"")))
(defun kkkmeet-server--nonnegative-number (value)
"Return VALUE as a nonnegative number, or zero."
(max 0 (if (numberp value) value 0)))
(defun kkkmeet-server--normalize-playlist (playlist)
"Return a sanitized YouTube PLAYLIST vector."
(let ((seen (make-hash-table :test 'equal))
items)
(dolist (item (cond
((vectorp playlist) (append playlist nil))
((listp playlist) playlist)
(t nil)))
(let* ((video-id (and (listp item) (alist-get 'videoId item)))
(title (and (listp item) (alist-get 'title item)))
(position (and (listp item) (alist-get 'position item)))
(duration (and (listp item) (alist-get 'duration item)))
(safe-video-id (and video-id (format "%s" video-id)))
(safe-title (string-trim (format "%s" (or title "")))))
(when (and safe-video-id
(string-match-p "\\`[A-Za-z0-9_-]\\{11\\}\\'" safe-video-id)
(not (gethash safe-video-id seen))
(< (length items) 50))
(puthash safe-video-id t seen)
(push `((videoId . ,safe-video-id)
(title . ,(if (string-empty-p safe-title)
(format "YouTube video %s" safe-video-id)
safe-title))
(position . ,(kkkmeet-server--nonnegative-number position))
(duration . ,(kkkmeet-server--nonnegative-number duration)))
items))))
(vconcat (nreverse items))))
(defun kkkmeet-server--json (value)
"Encode VALUE as JSON."
(let ((json-array-type 'list)
(json-object-type 'alist)
(json-false :false))
(json-encode value)))
(defun kkkmeet-server--send-response (process status headers &optional body keep-open)
"Send HTTP response to PROCESS with STATUS, HEADERS, and BODY.
When KEEP-OPEN is nil, close PROCESS after writing."
(let* ((reason (pcase status
(200 "OK")
(202 "Accepted")
(400 "Bad Request")
(403 "Forbidden")
(404 "Not Found")
(405 "Method Not Allowed")
(_ "Internal Server Error")))
(payload (or body ""))
(base-headers `(("Connection" . ,(if keep-open "keep-alive" "close"))
,@headers))
(full-headers (if keep-open
base-headers
`(("Content-Length" . ,(number-to-string (string-bytes payload)))
,@base-headers))))
(process-send-string process (format "HTTP/1.1 %s %s\r\n" status reason))
(dolist (header full-headers)
(process-send-string process (format "%s: %s\r\n" (car header) (cdr header))))
(process-send-string process "\r\n")
(when body
(process-send-string process payload))
(unless keep-open
(delete-process process))))
(defun kkkmeet-server--send-json (process status value)
"Send JSON VALUE to PROCESS."
(kkkmeet-server--send-response
process status
'(("Content-Type" . "application/json; charset=utf-8")
("Cache-Control" . "no-store"))
(kkkmeet-server--json value)))
(defun kkkmeet-server--send-sse (process value)
"Send VALUE as a server-sent event to PROCESS."
(when (process-live-p process)
(process-send-string process (format "data: %s\n\n" (kkkmeet-server--json value)))))
(defun kkkmeet-server--broadcast (room-id sender-id value)
"Broadcast VALUE in ROOM-ID to everyone except SENDER-ID."
(let ((room (gethash room-id kkkmeet-server--rooms)))
(when room
(maphash
(lambda (peer-id process)
(unless (equal peer-id sender-id)
(kkkmeet-server--send-sse process value)))
room))))
(defun kkkmeet-server--remove-peer (process)
"Remove PROCESS from its room and notify remaining peers."
(let ((room-id (process-get process :kkkmeet-room-id))
(peer-id (process-get process :kkkmeet-peer-id)))
(when (and room-id peer-id)
(let ((room (gethash room-id kkkmeet-server--rooms)))
(when room
(remhash peer-id room)
(kkkmeet-server--broadcast
room-id peer-id `((type . "peer-left") (peerId . ,peer-id)))
(when (equal (alist-get 'peerId (gethash room-id kkkmeet-server--presentation-states))
peer-id)
(remhash room-id kkkmeet-server--presentation-states)
(kkkmeet-server--broadcast
room-id peer-id `((type . "presentation-state")
(from . ,peer-id)
(sharing . :false))))
(when (= (hash-table-count room) 0)
(remhash room-id kkkmeet-server--rooms)
(remhash room-id kkkmeet-server--watch-states)
(remhash room-id kkkmeet-server--presentation-states)))))))
(defun kkkmeet-server--parse-request (raw)
"Parse RAW HTTP request into an alist."
(let* ((split (string-match-p "\r\n\r\n" raw))
(head (substring raw 0 split))
(body (substring raw (+ split 4)))
(lines (split-string head "\r\n"))
(request-line (split-string (car lines) " "))
(headers (make-hash-table :test 'equal)))
(dolist (line (cdr lines))
(when (string-match "\\`\\([^:]+\\):[ \t]*\\(.*\\)\\'" line)
(puthash (downcase (match-string 1 line)) (match-string 2 line) headers)))
`((method . ,(nth 0 request-line))
(target . ,(nth 1 request-line))
(path . ,(car (split-string (nth 1 request-line) "?")))
(headers . ,headers)
(body . ,body))))
(defun kkkmeet-server--request-complete-p (raw)
"Return non-nil when RAW contains a complete HTTP request."
(when-let ((split (string-match-p "\r\n\r\n" raw)))
(let* ((head (substring raw 0 split))
(headers (make-hash-table :test 'equal)))
(dolist (line (cdr (split-string head "\r\n")))
(when (string-match "\\`\\([^:]+\\):[ \t]*\\(.*\\)\\'" line)
(puthash (downcase (match-string 1 line)) (match-string 2 line) headers)))
(let ((length (string-to-number (or (gethash "content-length" headers) "0"))))
(>= (string-bytes (substring raw (+ split 4))) length)))))
(defun kkkmeet-server--safe-static-path (url-path)
"Return a safe static file path for URL-PATH, or nil."
(let* ((relative (if (equal url-path "/") "/index.html" url-path))
(decoded (url-unhex-string relative))
(full-path (expand-file-name (string-remove-prefix "/" decoded)
kkkmeet-server-public-dir))
(root (file-name-as-directory (expand-file-name kkkmeet-server-public-dir))))
(when (string-prefix-p root full-path)
full-path)))
(defun kkkmeet-server--serve-static (process method path)
"Serve static file PATH to PROCESS for METHOD."
(let ((file-path (kkkmeet-server--safe-static-path path)))
(cond
((not file-path)
(kkkmeet-server--send-response process 403 nil "Forbidden"))
((not (file-regular-p file-path))
(kkkmeet-server--send-response process 404 nil "Not found"))
(t
(let* ((extension (file-name-extension file-path))
(mime (or (cdr (assoc extension kkkmeet-server--mime-types))
"application/octet-stream"))
(body (unless (equal method "HEAD")
(with-temp-buffer
(set-buffer-multibyte nil)
(insert-file-contents-literally file-path)
(buffer-string)))))
(kkkmeet-server--send-response
process 200
`(("Content-Type" . ,mime)
("Cache-Control" . "no-store"))
body))))))
(defun kkkmeet-server--query-param (target name)
"Return query parameter NAME from request TARGET."
(when-let ((query (cadr (split-string target "?" t))))
(cadr (assoc name (url-parse-query-string query)))))
(defun kkkmeet-server--handle-events (process room-id display-name client-id)
"Attach PROCESS to ROOM-ID as an SSE client."
(let* ((safe-room-id (if (string-empty-p room-id) kkkmeet-server--default-room-id room-id))
(room (kkkmeet-server--room safe-room-id))
(peer-id (kkkmeet-server--uuid))
(peers (kkkmeet-server--room-peers room))
(safe-name (kkkmeet-server--normalize-name display-name))
(safe-client-id (kkkmeet-server--normalize-client-id client-id)))
(process-put process :kkkmeet-room-id safe-room-id)
(process-put process :kkkmeet-peer-id peer-id)
(process-put process :kkkmeet-name safe-name)
(process-put process :kkkmeet-client-id safe-client-id)
(puthash peer-id process room)
(kkkmeet-server--send-response
process 200
'(("Content-Type" . "text/event-stream; charset=utf-8")
("Cache-Control" . "no-store, no-transform")
("X-Accel-Buffering" . "no"))
nil t)
(kkkmeet-server--send-sse
process `((type . "welcome")
(peerId . ,peer-id)
(name . ,safe-name)
(clientId . ,safe-client-id)
(peers . ,peers)
(watchState . ,(or (gethash safe-room-id kkkmeet-server--watch-states)
:null))
(presentationState . ,(or (gethash safe-room-id kkkmeet-server--presentation-states)
:null))))
(kkkmeet-server--broadcast
safe-room-id peer-id `((type . "peer-joined")
(peerId . ,peer-id)
(name . ,safe-name)
(clientId . ,safe-client-id)))))
(defun kkkmeet-server--handle-signal (process room-id body)
"Handle signaling BODY from PROCESS for ROOM-ID."
(condition-case error
(let* ((json-object-type 'alist)
(payload (json-read-from-string body))
(from (alist-get 'from payload))
(to (alist-get 'to payload))
(type (alist-get 'type payload))
(target (gethash to (gethash room-id kkkmeet-server--rooms))))
(if (and from to type)
(progn
(when target
(kkkmeet-server--send-sse target payload))
(kkkmeet-server--send-json process 202 '((ok . t))))
(kkkmeet-server--send-json
process 400 '((error . "Signal messages require from, to, and type.")))))
(error
(kkkmeet-server--send-json process 400 `((error . ,(error-message-string error)))))))
(defun kkkmeet-server--handle-watch (process room-id body)
"Handle shared YouTube watch state BODY for ROOM-ID."
(condition-case error
(let* ((json-object-type 'alist)
(payload (json-read-from-string body))
(from (alist-get 'from payload))
(type (alist-get 'type payload))
(video-id (format "%s" (or (alist-get 'videoId payload) "")))
(action (format "%s" (or (alist-get 'action payload) "")))
(playlist (kkkmeet-server--normalize-playlist (alist-get 'playlist payload)))
(safe-room-id (if (string-empty-p room-id)
kkkmeet-server--default-room-id
room-id)))
(if (and from (equal type "watch-state"))
(let* ((active-video-id (if (seq-some
(lambda (item)
(equal video-id (alist-get 'videoId item)))
(append playlist nil))
video-id
""))
(safe-action (if (and (equal action "play")
(not (string-empty-p active-video-id)))
"play"
"pause"))
(watch-state `((type . "watch-state")
(from . ,from)
(name . ,(kkkmeet-server--normalize-name
(alist-get 'name payload)))
(videoId . ,active-video-id)
(playlist . ,playlist)
(position . ,(or (alist-get 'position payload) 0))
(playing . ,(if (equal safe-action "play") t :false))
(action . ,safe-action)
(updatedAt . ,(or (alist-get 'updatedAt payload)
(floor (* 1000 (float-time))))))))
(puthash safe-room-id watch-state kkkmeet-server--watch-states)
(kkkmeet-server--broadcast safe-room-id from watch-state)
(kkkmeet-server--send-json process 202 '((ok . t))))
(kkkmeet-server--send-json
process 400 '((error . "Watch messages require from and type=watch-state.")))))
(error
(kkkmeet-server--send-json process 400 `((error . ,(error-message-string error)))))))
(defun kkkmeet-server--handle-room-event (process room-id body)
"Handle shared room event BODY for ROOM-ID."
(condition-case error
(let* ((json-object-type 'alist)
(payload (json-read-from-string body))
(from (alist-get 'from payload))
(type (alist-get 'type payload))
(safe-room-id (if (string-empty-p room-id)
kkkmeet-server--default-room-id
room-id)))
(cond
((and from (equal type "presentation-state"))
(let ((event `((type . "presentation-state")
(from . ,from)
(peerId . ,from)
(name . ,(kkkmeet-server--normalize-name
(alist-get 'name payload)))
(sharing . ,(if (alist-get 'sharing payload) t :false))
(updatedAt . ,(floor (* 1000 (float-time)))))))
(if (alist-get 'sharing payload)
(puthash safe-room-id event kkkmeet-server--presentation-states)
(when (equal (alist-get 'peerId (gethash safe-room-id kkkmeet-server--presentation-states))
from)
(remhash safe-room-id kkkmeet-server--presentation-states)))
(kkkmeet-server--broadcast safe-room-id from event)
(kkkmeet-server--send-json process 202 '((ok . t)))))
((and from (equal type "voice-announcement"))
(let ((text (kkkmeet-server--normalize-announcement
(alist-get 'text payload))))
(if (string-empty-p text)
(kkkmeet-server--send-json
process 400 '((error . "Voice announcements require text.")))
(let ((event `((type . "voice-announcement")
(from . ,from)
(name . ,(kkkmeet-server--normalize-name
(alist-get 'name payload)))
(text . ,text)
(updatedAt . ,(floor (* 1000 (float-time)))))))
(kkkmeet-server--broadcast safe-room-id from event)
(kkkmeet-server--send-json process 202 '((ok . t)))))))
(t
(kkkmeet-server--send-json
process 400 '((error . "Room events require from and a supported type."))))))
(error
(kkkmeet-server--send-json process 400 `((error . ,(error-message-string error)))))))
(defun kkkmeet-server--handle-request (process request)
"Route REQUEST for PROCESS."
(let ((method (alist-get 'method request))
(target (alist-get 'target request))
(path (alist-get 'path request))
(body (alist-get 'body request)))
(cond
((and (equal method "GET") (string-prefix-p "/events/" path))
(kkkmeet-server--handle-events
process
(url-unhex-string (string-remove-prefix "/events/" path))
(kkkmeet-server--query-param target "name")
(kkkmeet-server--query-param target "clientId")))
((and (equal method "POST") (string-prefix-p "/signal/" path))
(kkkmeet-server--handle-signal
process (url-unhex-string (string-remove-prefix "/signal/" path)) body))
((and (equal method "POST") (string-prefix-p "/watch/" path))
(kkkmeet-server--handle-watch
process (url-unhex-string (string-remove-prefix "/watch/" path)) body))
((and (equal method "POST") (string-prefix-p "/room-event/" path))
(kkkmeet-server--handle-room-event
process (url-unhex-string (string-remove-prefix "/room-event/" path)) body))
((member method '("GET" "HEAD"))
(kkkmeet-server--serve-static process method path))
(t
(kkkmeet-server--send-response process 405 nil "Method not allowed")))))
(defun kkkmeet-server--filter (process chunk)
"Accumulate request CHUNK for PROCESS and respond when complete."
(let ((raw (concat (or (process-get process :kkkmeet-raw-request) "") chunk)))
(process-put process :kkkmeet-raw-request raw)
(when (kkkmeet-server--request-complete-p raw)
(process-put process :kkkmeet-raw-request nil)
(condition-case error
(kkkmeet-server--handle-request process (kkkmeet-server--parse-request raw))
(error
(kkkmeet-server--send-json process 500 `((error . ,(error-message-string error)))))))))
(defun kkkmeet-server--sentinel (process _event)
"Clean up PROCESS when a connection closes."
(unless (process-live-p process)
(kkkmeet-server--remove-peer process)))
;;;###autoload
(defun kkkmeet-server-start (&optional port host)
"Start kkkmeet server on PORT and HOST."
(interactive)
(kkkmeet-server-stop)
(setq kkkmeet-server--rooms (make-hash-table :test 'equal))
(setq kkkmeet-server--watch-states (make-hash-table :test 'equal))
(setq kkkmeet-server--presentation-states (make-hash-table :test 'equal))
(setq kkkmeet-server--process
(make-network-process
:name "kkkmeet-server"
:server t
:host (or host kkkmeet-server-host)
:service (or port kkkmeet-server-port)
:coding 'binary
:filter #'kkkmeet-server--filter
:sentinel #'kkkmeet-server--sentinel))
(message "kkkmeet is running at http://%s:%s"
(or host kkkmeet-server-host)
(or port kkkmeet-server-port)))
;;;###autoload
(defun kkkmeet-server-stop ()
"Stop the kkkmeet server and all active SSE clients."
(interactive)
(when (process-live-p kkkmeet-server--process)
(delete-process kkkmeet-server--process))
(maphash
(lambda (_room-id room)
(maphash (lambda (_peer-id process)
(when (process-live-p process)
(delete-process process)))
room))
kkkmeet-server--rooms)
(setq kkkmeet-server--process nil)
(setq kkkmeet-server--rooms (make-hash-table :test 'equal))
(setq kkkmeet-server--watch-states (make-hash-table :test 'equal))
(setq kkkmeet-server--presentation-states (make-hash-table :test 'equal)))
;;;###autoload
(defun kkkmeet-server-run-batch ()
"Run kkkmeet server forever for `emacs --batch'."
(let ((port (or (and (getenv "PORT") (string-to-number (getenv "PORT")))
kkkmeet-server-port))
(host (or (getenv "HOST") kkkmeet-server-host)))
(kkkmeet-server-start port host)
(while t
(accept-process-output nil 1))))
(provide 'kkkmeet-server)
;;; kkkmeet-server.el ends here