commit 2a54fc3e0d113dc05ee1c5bf5b3391690fc4164c Author: Bubblegumdrop Date: Fri Oct 11 16:45:22 2024 -0400 Initial commit for git.lain.church diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c983b6a --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +bin/ +*.bin +*.fasl +*.db diff --git a/live-chat-cgi.lisp b/live-chat-cgi.lisp new file mode 100644 index 0000000..3a7b8db --- /dev/null +++ b/live-chat-cgi.lisp @@ -0,0 +1,32 @@ +(in-package #:live-chat-cgi) + +(defun print-http-header () + "Print standard HTTP headers for CGI." + (format t "Content-Type: text/html~%~%")) + +(defun cgi-handler () + "Handle CGI requests and dispatch them to the appropriate logic." + (let ((request-method (string-downcase (or (getenv "REQUEST_METHOD") "")))) + (print-http-header) + (cond + ((string= request-method "get") + (let ((path (getenv "PATH_INFO"))) + (cond + ((string= path "/chat-messages") + (render-chat-messages)) + ((string= path "/") + (render-chat-ui)) + (t + (format t "Not Found"))))) + ((string= request-method "post") + ;; Read the POST data + (let ((input (read-line *standard-input*))) + (when (and input (not (string= input ""))) + (let ((params (split-sequence:split-sequence #\& input))) + (dolist (param params) + (let* ((pair (split-sequence:split-sequence #\= param)) + (key (first pair)) + (value (second pair))) + (when (string= key "message") + (handle-post-message value)))))) + (render-chat-messages)))))) diff --git a/live-chat-core.lisp b/live-chat-core.lisp new file mode 100644 index 0000000..d3a8d0d --- /dev/null +++ b/live-chat-core.lisp @@ -0,0 +1,70 @@ +(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 new file mode 100644 index 0000000..6600328 --- /dev/null +++ b/live-chat-db.lisp @@ -0,0 +1,50 @@ +(in-package #:live-chat-db) + +(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")))) + +(defun close-database () + "Close the SQLite database." + (when *db* (dbi:disconnect *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)) + +(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)) + +(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))) + +(defun clear-messages () + "Clear all messages from the database." + (let ((query (dbi:prepare *db* "DELETE FROM messages"))) + (dbi:execute query (list)))) diff --git a/live-chat-hunchentoot.lisp b/live-chat-hunchentoot.lisp new file mode 100644 index 0000000..2c47a02 --- /dev/null +++ b/live-chat-hunchentoot.lisp @@ -0,0 +1,43 @@ +(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 new file mode 100644 index 0000000..b34fc53 --- /dev/null +++ b/live-chat-main.lisp @@ -0,0 +1,5 @@ +(in-package #:live-chat) + +(defun main () + (create-messages-table) + (start-chat-server)) diff --git a/live-chat.asd b/live-chat.asd new file mode 100644 index 0000000..e75f597 --- /dev/null +++ b/live-chat.asd @@ -0,0 +1,21 @@ +;;;; live-chat.asd + +(asdf:defsystem #:live-chat + :description "Twitch.TV-like live chat on the web. Uses HTMX to poll for messages." + :author "Bubblegumdrop " + :license "WTFPL 2+" + :version "0.1.0" + :defsystem-depends-on (:deploy) ;; so you need to quickload deploy sometime before. + :build-operation "deploy-op" ;; instead of program-op for asdf:make + :build-pathname "live-chat" + :entry-point "live-chat::main" + :depends-on (#:bordeaux-threads + #:cl-dbi + #:cl-who + #:hunchentoot) + :components ((:file "package") + (:file "live-chat-db") + (:file "live-chat-core") + (:file "live-chat-hunchentoot") + (:file "live-chat-cgi") + (:file "live-chat-main"))) diff --git a/makefile b/makefile new file mode 100644 index 0000000..f5e5642 --- /dev/null +++ b/makefile @@ -0,0 +1,22 @@ +PROG := live-chat + +SRC := $(wildcard *.asd) $(wildcard *.lisp) +BIN := $(PROG).bin + +all: install + +install: $(BIN) + +bin/$(PROG): $(SRC) + sbcl --load $< \ + --eval "(load \"live-chat.asd\")" \ + --eval "(asdf:load-system :live-chat)" \ + --eval "(asdf:make 'live-chat)" + +$(BIN): bin/$(PROG) + mv $< $@ + +clean: + $(RM) -rf *~ bin $(BIN) + +.PHONY: all install diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..656a526 --- /dev/null +++ b/package.lisp @@ -0,0 +1,47 @@ +(in-package #:cl-user) + +(defpackage #:live-chat-db + (:use #:cl) + (:local-nicknames (#:cl-dbi #:dbi)) + (:export #:*db* + #:open-database + #:close-database + #:create-messages-table + #:insert-message + #:fetch-messages)) + +(defpackage #:live-chat-core + (:use #:cl) + (:local-nicknames (#:cl-who #:cl-who)) + (:import-from #:live-chat-db + #:insert-message + #:fetch-messages) + (:export #:render-chat-messages + #:render-chat-ui + #:handle-post-message + #:*messages*)) + +(defpackage #:live-chat-cgi + (:use #:cl) + (:import-from #:live-chat-core) + (:export #:cgi-handler)) + +(defpackage #:live-chat-hunchentoot + (:use #:cl) + (:import-from #:live-chat-core + #:handle-post-message + #:render-chat-messages + #:render-chat-ui) + (:local-nicknames (#:cl-who #:cl-who) + (#:hunchentoot #:hunchentoot)) + (:export #:start-chat-server)) + +(uiop:define-package #:live-chat + (:use #:cl) + (:use-reexport #:live-chat-core + #:live-chat-cgi + #:live-chat-db + #:live-chat-hunchentoot)) + +(in-package #:live-chat) + diff --git a/readme.org b/readme.org new file mode 100644 index 0000000..eb6a3b1 --- /dev/null +++ b/readme.org @@ -0,0 +1,3 @@ +* What It Is + +Twitch.TV-like live chat on the web. Uses HTMX to poll for messages. No database support (yet).