From 8d3e31ef5612cf1d1cd2ed50bf830e57e068fe3e Mon Sep 17 00:00:00 2001 From: Bubblegumdrop Date: Sat, 12 Oct 2024 19:53:34 -0400 Subject: [PATCH] Fully WebSocket Server. We're now using clack, lack, ningle, and websocket-driver. Quite a few more dependencies. --- live-chat-core.lisp | 70 ----------------------------------- live-chat-db.lisp | 67 +++++++++++++++++---------------- live-chat-hunchentoot.lisp | 43 ---------------------- live-chat-main.lisp | 61 ++++++++++++++++++++++++++++-- live-chat-routes.lisp | 25 +++++++++++++ live-chat-ui.lisp | 92 ++++++++++++++++++++++++++++++++++++++++++++++ live-chat-ws.lisp | 51 +++++++++++++++++++++++++ live-chat.asd | 11 ++++-- package.lisp | 41 +++++++++++++++------ readme.org | 10 ++++- 10 files changed, 308 insertions(+), 163 deletions(-) delete mode 100644 live-chat-core.lisp delete mode 100644 live-chat-hunchentoot.lisp create mode 100644 live-chat-routes.lisp create mode 100644 live-chat-ui.lisp create mode 100644 live-chat-ws.lisp diff --git a/live-chat-core.lisp b/live-chat-core.lisp deleted file mode 100644 index d3a8d0d..0000000 --- a/live-chat-core.lisp +++ /dev/null @@ -1,70 +0,0 @@ -(in-package #:cl-user) - -(in-package #:live-chat-core) - -;; (defvar *messages* (make-array 0 :adjustable t :fill-pointer t) -;; "Array to store chat messages.") - -(defun handle-post-message (message) - "Handle a new message being posted to the chat." - (insert-message message) - ;; (vector-push-extend message *messages*) - (format nil "Message received: ~a" message)) - -(defun render-chat-messages () - "Render the list of chat messages as HTML." - (let ((messages (fetch-messages))) - (if messages - (cl-who:with-html-output-to-string (*standard-output* nil :indent t) - (:h3 :class "title is-3" "Chat Messages") - (loop for msg in messages - do (cl-who:htm - (:div :class "box" (cl-who:str msg))))) - ""))) - -(defun render-chat-ui () - "Render the main chat page with HTMX integration." - (cl-who:with-html-output-to-string (*standard-output* nil :prologue t :indent t) - (:html :lang "en" - (:head - (:meta :charset "utf-8") - (:meta :name "viewport" :content "width=device-width, initial-scale=1") - (:title "Live Chat") - (:link :rel "stylesheet" - :href "https://cdnjs.cloudflare.com/ajax/libs/bulma/1.0.2/css/bulma.min.css" - :integrity "sha512-RpeJZX3aH5oZN3U3JhE7Sd+HG8XQsqmP3clIbu4G28p668yNsRNj3zMASKe1ATjl/W80wuEtCx2dFA8xaebG5w==" - :crossorigin "anonymous" - :referrerpolicy "no-referrer") - (:script :src "https://cdnjs.cloudflare.com/ajax/libs/htmx/2.0.3/htmx.min.js" - :integrity "sha512-dQu3OKLMpRu85mW24LA1CUZG67BgLPR8Px3mcxmpdyijgl1UpCM1RtJoQP6h8UkufSnaHVRTUx98EQT9fcKohw==" - :crossorigin "anonymous" - :referrerpolicy "no-referrer")) - (:body - (:section :class "section" - (:div :class "container" - (:h1 :class "title" "Live Chat") - - ;; Form for sending messages - (:form :id "post-message-form" - :name "post-message-form" - :hx-post "/post-message" - :hx-swap "innerHTML" - :hx-target "#chat-messages" - (:div :class "field has-addons" - (:div :class "control is-expanded" - (:input :class "input is-expanded" - :form "post-message-form" - :placeholder "Ender your message..." - :type "text" :name "message")) - (:div :class "control" - (:button :class "button is-link is-light" - :form "post-message-form" - :type "submit" "Send")))))) - - ;; Chat messages will be updated by HTMX via GET to /chat-messages - (:section :class "section" - (:div :class "container" - :id "chat-messages" - :hx-get "/chat-messages" - :hx-trigger "every 2s" - (cl-who:str (render-chat-messages)))))))) diff --git a/live-chat-db.lisp b/live-chat-db.lisp index 6600328..b824502 100644 --- a/live-chat-db.lisp +++ b/live-chat-db.lisp @@ -3,48 +3,51 @@ (defvar *db* nil "Database connection object.") -(defun open-database () - "Open the SQLite database." - (setf *db* (dbi:connect-cached - :sqlite3 :database-name - (asdf:system-relative-pathname :live-chat "chat.db")))) +(defvar *db-lock* (bt:make-lock) + "Lock to ensure thread-safe access to database.") -(defun close-database () - "Close the SQLite database." - (when *db* (dbi:disconnect *db*))) +(defmacro with-database (conn &body body) + "Open the SQLite database." + `(let ((*db* ,conn)) + (bt:with-lock-held (*db-lock*) + ,@body))) + +(defun db () + (dbi:connect-cached + :sqlite3 :database-name + (asdf:system-relative-pathname :live-chat "chat.db"))) (defun create-messages-table () "Create the messages table if it doesn't exist." - (open-database) - (let ((query (dbi:prepare *db* - "CREATE TABLE IF NOT EXISTS messages -(id INTEGER PRIMARY KEY AUTOINCREMENT, - content TEXT NOT NULL)"))) - (dbi:execute query (list))) - (close-database)) + (with-database (db) + (let ((query (dbi:prepare + *db* + "CREATE TABLE IF NOT EXISTS messages (id + INTEGER PRIMARY KEY AUTOINCREMENT,content TEXT NOT NULL)"))) + (dbi:execute query (list))))) (defun insert-message (message) "Insert a new message into the database." - (open-database) - (let ((query (dbi:prepare *db* - "INSERT INTO messages (content) VALUES (?)"))) - (dbi:execute query (list message)) - (close-database) - message)) + (with-database (db) + (let ((query (dbi:prepare + *db* + "INSERT INTO messages (content) VALUES (?)"))) + (dbi:execute query (list message)) + message))) (defun fetch-messages () "Fetch all messages from the database." - (open-database) - (let* ((query (dbi:prepare *db* - "SELECT content FROM messages ORDER BY id")) - (query (dbi:execute query (list))) - (results (loop for row = (dbi:fetch query) - while row - collect (getf row :|content|)))) - (close-database) - (reverse results))) + (with-database (db) + (let* ((query (dbi:prepare *db* + "SELECT content FROM messages ORDER BY id")) + (query (dbi:execute query (list))) + (results (loop for row = (dbi:fetch query) + while row + collect (getf row :|content|)))) + (reverse results)))) (defun clear-messages () "Clear all messages from the database." - (let ((query (dbi:prepare *db* "DELETE FROM messages"))) - (dbi:execute query (list)))) + (with-database (db) + (let ((query (dbi:prepare *db* "DELETE FROM messages"))) + (dbi:execute query (list))))) diff --git a/live-chat-hunchentoot.lisp b/live-chat-hunchentoot.lisp deleted file mode 100644 index 2c47a02..0000000 --- a/live-chat-hunchentoot.lisp +++ /dev/null @@ -1,43 +0,0 @@ -(in-package #:live-chat-hunchentoot) - -(defvar *server* nil - "The server acceptor.") - -(hunchentoot:define-easy-handler (chat-index :uri "/") () - "Handle GET requests to / and render the chat UI." - (render-chat-ui)) - -(hunchentoot:define-easy-handler (chat-handler :uri "/chat-messages") () - "Handle GET requests to /chat-messages and render the chat UI." - (render-chat-messages)) - -(hunchentoot:define-easy-handler (chat-post-handler :uri "/post-message" :default-request-type :post) () - "Handle POST requests to /post-message and process the message." - (let ((message (hunchentoot:post-parameter "message"))) - (when (and message (not (string= message ""))) - (handle-post-message message))) - (render-chat-messages)) - -(defun start-chat-server (&optional (address "localhost") (port 8080)) - "Start the Hunchentoot chat server." - (setf (cl-who:html-mode) :html5 - *server* (make-instance 'hunchentoot:easy-acceptor - :address address - :port port)) - (hunchentoot:start *server*) - (format t "Chat server started on port 8080~%") - (wait-for-hunchentoot-listener "hunchentoot-listener-")) - -;; https://stackoverflow.com/a/30424968 -(defun wait-for-hunchentoot-listener (name) - (bt2:join-thread - (find-if - (lambda (th) - (prefixp name (bt2:thread-name th))) - (bt2:all-threads)))) - -;; https://github.com/brown/base?tab=readme-ov-file#prefixp-prefix-sequence-key-test-eql -(defun prefixp (prefix sequence &key (test #'eql)) - "Does PREFIX match a prefix of SEQUENCE?" - (let ((mismatch (mismatch prefix sequence :test test))) - (or (null mismatch) (= mismatch (length prefix))))) diff --git a/live-chat-main.lisp b/live-chat-main.lisp index b34fc53..f60fde4 100644 --- a/live-chat-main.lisp +++ b/live-chat-main.lisp @@ -1,5 +1,60 @@ (in-package #:live-chat) -(defun main () - (create-messages-table) - (start-chat-server)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar *handler* nil + "The clack chat server app.") + +;; to wrap with multiple middlewares at once, use lack's builder macro +(defparameter *app* + (lack:builder + :session + (:static :path "/public/" + :root #P"/static-files/") + ;; (lambda (app) + ;; (lambda (env) + ;; (prog1 (funcall app env) + ;; (do-before-responding)))) + (:mount "/ws-chat-messages" #'live-chat-ws:make-websocket-server) + live-chat-routes::*app*)) + +;; Start the chat server +(defun start-chat-server (&rest args &key (address "localhost") (port 8080) &allow-other-keys) + "Start the Clack chat server." + (setf *handler* + (apply #'clack:clackup *app* + :port port :host address args)) + (when *handler* + (format t "Chat server started on ~A port ~A~%" address port))) + +(defun stop-chat-server (&rest args) + (declare (ignore args)) + (when *handler* + (prog1 + (clack:stop *handler*) + (setf *handler* nil))) + (unless *handler* + (format t "Chat server stopped.~%"))) + +(defun restart-chat-server (&rest args) + (apply #'stop-chat-server args) + (apply #'start-chat-server args)) + +(defun main (&rest args &key (foreground nil) &allow-other-keys) + (progn + (setf (cl-who:html-mode) :html5) + (create-messages-table) + (apply #'restart-chat-server args))) + +;; https://stackoverflow.com/a/30424968 +(defun wait-for-hunchentoot-listener (name) + (bt:join-thread + (find-if + (lambda (th) + (prefixp name (bt:thread-name th))) + (bt:all-threads)))) + +;; https://github.com/brown/base?tab=readme-ov-file#prefixp-prefix-sequence-key-test-eql +(defun prefixp (prefix sequence &key (test #'eql)) + "Does PREFIX match a prefix of SEQUENCE?" + (let ((mismatch (mismatch prefix sequence :test test))) + (or (null mismatch) (= mismatch (length prefix))))) diff --git a/live-chat-routes.lisp b/live-chat-routes.lisp new file mode 100644 index 0000000..5445dc5 --- /dev/null +++ b/live-chat-routes.lisp @@ -0,0 +1,25 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package #:live-chat-routes) + +;; Define a app for routing +(defparameter *app* (make-instance 'ningle:app)) + +;; Route to render the chat UI +(setf (ningle:route *app* "/" :method :GET) + #'(lambda (params) + (declare (ignore params)) + (live-chat-ui:render-chat-ui))) + +;; Route for chat messages +(setf (ningle:route *app* "/chat-messages" :method :GET) + #'(lambda (params) + (declare (ignore params)) + (live-chat-ui:render-chat-messages))) + +;; Route for posting messages +(setf (ningle:route *app* "/post-message" :method :POST) + #'(lambda (params) + (let ((message (cdr (assoc "message" params :test 'equal)))) + (when (and message (not (string= message ""))) + (handle-post-message message))) + (live-chat-ui:render-chat-messages))) diff --git a/live-chat-ui.lisp b/live-chat-ui.lisp new file mode 100644 index 0000000..9c8dc81 --- /dev/null +++ b/live-chat-ui.lisp @@ -0,0 +1,92 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(in-package #:live-chat-ui) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar *default-prefix* "/lisp-chat") + +(defun set-subpath-prefix (prefix) + (setf *default-prefix* prefix)) + +(defun subpath-prefix (path) + (format nil "~a~a" *default-prefix* path)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Render chat messages +(defun render-chat-messages () + "Render the list of chat messages as HTML." + (let ((messages (fetch-messages))) + (if messages + (cl-who:with-html-output-to-string (*standard-output* nil :indent t) + (loop for msg in messages + do (cl-who:htm + (:div :class "box" + :style "overflow:auto;" + (cl-who:str msg))))) + ""))) + +;; Render chat UI +(defun render-chat-ui () + "Render the main chat page with HTMX integration." + (cl-who:with-html-output-to-string (*standard-output* nil :prologue t :indent t) + (:html :lang "en" + (:head + (:meta :charset "utf-8") + (:meta :name "viewport" :content "width=device-width, initial-scale=1") + (:title "Live Chat") + (:link :rel "stylesheet" + :href "https://cdnjs.cloudflare.com/ajax/libs/bulma/1.0.2/css/bulma.min.css" + :integrity "sha512-RpeJZX3aH5oZN3U3JhE7Sd+HG8XQsqmP3clIbu4G28p668yNsRNj3zMASKe1ATjl/W80wuEtCx2dFA8xaebG5w==" + :crossorigin "anonymous" + :referrerpolicy "no-referrer") + (:script :src "https://cdnjs.cloudflare.com/ajax/libs/htmx/2.0.3/htmx.min.js" + :integrity "sha512-dQu3OKLMpRu85mW24LA1CUZG67BgLPR8Px3mcxmpdyijgl1UpCM1RtJoQP6h8UkufSnaHVRTUx98EQT9fcKohw==" + :crossorigin "anonymous" + :referrerpolicy "no-referrer") + (:script :src "https://cdnjs.cloudflare.com/ajax/libs/htmx/2.0.3/ext/ws.min.js" + :integrity "sha512-1OIiXEswZd/etj60BUwFmyoi0OhrWdoYlzayJpSBivoMV0pQPIQr+vtAn3W3htsbWtLRU8DrBl0epdK4DQbj/w==" + :crossorigin "anonymous" + :referrerpolicy "no-referrer")) + (:body + (:section :class "section" + (:div :class "container" + (:h1 :class "title" "Live Chat") + (:div :class "field has-addons" + (:div :class "control is-expanded" + (:input :class "input is-expanded" + :id "chat-input" + :autocomplete "off" + :placeholder "Enter your message..." + :type "text" :name "message")) + (:div :class "control" + (:button :class "button is-link is-light" + :type "submit" "Send"))))) + (:section :class "section" + (:div :class "container" + :hx-ext "ws" + :ws-connect (subpath-prefix "/ws-chat-messages") + (:h3 :class "title is-3" "Chat Messages") + (:div :class "container" + :id "chat-messages" + :hx-get "/chat-messages" + (cl-who:str (render-chat-messages))))) + (:script " +//////////////////////////////////////////////////////////////////////////////// + +function receivedMessage(msg) { + document.querySelector('#chat-messages') + .insertAdjacentHTML('afterbegin', msg.data); +} + +// TODO {{ server-name }}:{{ server-port }} +const ws = new WebSocket('ws://' + window.location.host + '/ws-chat-messages'); +ws.addEventListener('message', receivedMessage); + +//////////////////////////////////////////////////////////////////////////////// + +const inputField = document.getElementById('chat-input'); +inputField.addEventListener('keyup', (evt) => { + if (evt.key === 'Enter') { + ws.send(evt.target.value); + evt.target.value = ''; + } +});"))))) diff --git a/live-chat-ws.lisp b/live-chat-ws.lisp new file mode 100644 index 0000000..1a45a67 --- /dev/null +++ b/live-chat-ws.lisp @@ -0,0 +1,51 @@ +(in-package #:live-chat-ws) + +(defvar *connections* (make-hash-table)) + +(defun handle-post-message (message) + "Handle a new message being posted to the chat." + (let ((message (cl-who:escape-string message))) + (format *standard-output* "Message received: ~a~%" message) + (live-chat-db:insert-message message))) + +(defun handle-new-connection (con) + (setf (gethash con *connections*) + (princ-to-string (gensym "USER-")))) + +(defun broadcast-to-room (connection message) + (handle-post-message message) + (let ((message + (cl-who:with-html-output-to-string (*standard-output*) + (:div :class "box" + (format t "~a: ~a" (gethash connection *connections*) message))))) + (loop :for con :being :the :hash-key :of *connections* :do + (send con message)))) + +(defun handle-close-connection (connection) + (let ((message + (cl-who:with-html-output-to-string (*standard-output*) + (:div :class "box" + (format t "... ~a disconnected." + (gethash connection *connections*)))))) + (loop :for con :being :the :hash-key :of *connections* :do + (send con message)))) + +(defun make-websocket-server (env) + (handler-case + (let ((ws (make-server env))) + (on :open ws + (lambda () + (handle-new-connection ws))) + (on :message ws + (lambda (msg) + (broadcast-to-room ws msg))) + (on :close ws + (lambda (&key code reason) + (declare (ignore code reason)) + (handle-close-connection ws))) + (lambda (responder) + (declare (ignore responder)) + (start-connection ws))) + (error (e) + (declare (ignore e)) + (format nil "Something went wrong. Try again?")))) diff --git a/live-chat.asd b/live-chat.asd index e75f597..bfeee04 100644 --- a/live-chat.asd +++ b/live-chat.asd @@ -12,10 +12,15 @@ :depends-on (#:bordeaux-threads #:cl-dbi #:cl-who - #:hunchentoot) + #:clack + #:lack + #:ningle + ;; WebSocket chat server backend + #:websocket-driver) :components ((:file "package") (:file "live-chat-db") - (:file "live-chat-core") - (:file "live-chat-hunchentoot") + (:file "live-chat-ui") + (:file "live-chat-routes") (:file "live-chat-cgi") + (:file "live-chat-ws") (:file "live-chat-main"))) diff --git a/package.lisp b/package.lisp index 656a526..b5e651e 100644 --- a/package.lisp +++ b/package.lisp @@ -8,40 +8,59 @@ #:close-database #:create-messages-table #:insert-message - #:fetch-messages)) + #:fetch-messages + #:clear-messages)) -(defpackage #:live-chat-core +(defpackage #:live-chat-ui (:use #:cl) (:local-nicknames (#:cl-who #:cl-who)) (:import-from #:live-chat-db #:insert-message #:fetch-messages) - (:export #:render-chat-messages + (:export #:set-subpath-prefix + #:render-chat-messages #:render-chat-ui #:handle-post-message #:*messages*)) (defpackage #:live-chat-cgi (:use #:cl) - (:import-from #:live-chat-core) + (:import-from #:live-chat-ui) (:export #:cgi-handler)) -(defpackage #:live-chat-hunchentoot +(defpackage #:live-chat-routes (:use #:cl) - (:import-from #:live-chat-core + (:import-from #:live-chat-db + #:insert-message) + (:import-from #:live-chat-ui #:handle-post-message #:render-chat-messages #:render-chat-ui) (:local-nicknames (#:cl-who #:cl-who) - (#:hunchentoot #:hunchentoot)) - (:export #:start-chat-server)) + (#:myway #:myway)) + (:export #:app)) + +(defpackage #:live-chat-ws + (:use #:cl) + (:import-from #:websocket-driver + #:make-client + #:make-server + #:on + #:send + #:start-connection + #:close-connection) + (:export #:make-websocket-server + #:handle-close-connection + #:broadcast-to-room + #:handle-new-connection + #:*connections*)) (uiop:define-package #:live-chat (:use #:cl) - (:use-reexport #:live-chat-core - #:live-chat-cgi + (:import-from #:clack #:clackup) + (:use-reexport #:live-chat-ui #:live-chat-db - #:live-chat-hunchentoot)) + #:live-chat-routes)) (in-package #:live-chat) diff --git a/readme.org b/readme.org index eb6a3b1..a6a3e1c 100644 --- a/readme.org +++ b/readme.org @@ -1,3 +1,11 @@ * What It Is -Twitch.TV-like live chat on the web. Uses HTMX to poll for messages. No database support (yet). +Twitch.TV-like live chat on the web. Uses HTMX to poll for messages. + +* Database Connection + +It's using CL-DBI for SQLite connection. + +* WebSocket Support + +Now with WebSocket support for authentic live chat.