498 lines
22 KiB
EmacsLisp
498 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")))
|
|
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--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)
|
|
"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)))
|
|
(process-put process :kkkmeet-room-id safe-room-id)
|
|
(process-put process :kkkmeet-peer-id peer-id)
|
|
(process-put process :kkkmeet-name safe-name)
|
|
(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)
|
|
(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)))))
|
|
|
|
(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")))
|
|
((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
|