Zander671/truth-table
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Redo web server build

Browse Source
This commit is contained in:
Alexander Rosenberg
2026-02-13 03:24:48 -08:00
parent 7f6872c0ea
commit 2ba02e821e
6 changed files with 108 additions and 78 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -1,2 +1,2 @@
truth-table truth-table
truth-table-webserver truth-table-web-server

5
Makefile
View File

@ -3,6 +3,7 @@ SBCL ?= sbcl
BASE_FILES=base-packages.lisp parse.lisp table.lisp typeset.lisp eval.lisp \ BASE_FILES=base-packages.lisp parse.lisp table.lisp typeset.lisp eval.lisp \
arguments.lisp arguments.lisp
CLI_FILES=cli.lisp CLI_FILES=cli.lisp
WEB_FILES=web.lisp
all: cli all: cli
@ -10,6 +11,10 @@ cli: truth-table
truth-table: build.lisp truth-table.asd $(BASE_FILES) $(CLI_FILES) truth-table: build.lisp truth-table.asd $(BASE_FILES) $(CLI_FILES)
$(SBCL) --load build.lisp --eval '(cli)' $(SBCL) --load build.lisp --eval '(cli)'
web: truth-table-web-server
truth-table-web-server: build.lisp truth-table.asd $(BASE_FILES) $(WEB_FILES)
$(SBCL) --load build.lisp --eval '(web)'
clean: clean:
rm -f truth-table rm -f truth-table

11
build.lisp
View File

@ -16,3 +16,14 @@
:executable t :executable t
:save-runtime-options t :save-runtime-options t
:toplevel (intern "TOPLEVEL" :truth-table/cli))) :toplevel (intern "TOPLEVEL" :truth-table/cli)))
(defun web ()
"Build web CLI application executable."
(sb-ext:disable-debugger)
(asdf:load-system :truth-table/web)
(require :truth-table/web)
(sb-ext:save-lisp-and-die
"truth-table-web-server"
:executable t
:save-runtime-options t
:toplevel (intern "TOPLEVEL" :truth-table/web)))

9
truth-table-web-wrapper
View File

@ -1,9 +0,0 @@
#!/bin/sh
SBCL=${SBCL:-sbcl}
# Use Quicklisp instead of ASDF to silence the output
exec ${SBCL} --noinform \
--eval '(format *error-output* "Loading systems...~%")' \
--eval '(ql:quickload :truth-table/web :silent t)' \
--eval '(truth-table/web:toplevel)' - "${@}"

1
truth-table.asd
View File

@ -36,6 +36,7 @@
#:reblocks #:reblocks
#:reblocks-ui #:reblocks-ui
#:reblocks-lass #:reblocks-lass
#:clack-handler-hunchentoot
#:truth-table/base #:truth-table/base
#:truth-table/args) #:truth-table/args)
:serial t :serial t

158
web.lisp
View File

@ -37,45 +37,47 @@
(defparameter *default-port* 8000) (defparameter *default-port* 8000)
(defparameter *default-address* "127.0.0.1") (defparameter *default-address* "127.0.0.1")
(defparameter *default-prefix* "/") (defparameter *default-prefix* "/")
(defparameter *max-input-length* 128
"The maximum length of any input proposition.")
(defwidget help-overlay () (defwidget help-overlay ()
() ()
(:documentation "Simple class to handle holding the help overlay.")) (:documentation "Simple class to handle holding the help overlay."))
(defmethod render ((overlay help-overlay)) (defmethod render ((overlay help-overlay))
(with-html (with-html ()
(:div :id "help-table-wrapper" (:div :id "help-table-wrapper"
(:div :id "help-header-wrapper" (:div :id "help-header-wrapper"
(:span :id "help-header" "Help") (:span :id "help-header" "Help")
(:span :id "help-close-button" (:span :id "help-close-button"
:onclick "document.querySelector(\".help-overlay\").style.display = \"none\"" :onclick "document.querySelector(\".help-overlay\").style.display = \"none\""
"Close")) "Close"))
(:table ;:style "margin-bottom: 10px;" (:table ;:style "margin-bottom: 10px;"
(:tr (:th "Operator") (:th "Syntax")) (:tr (:th "Operator") (:th "Syntax"))
(loop for ((sym (name . nics) desc (examples)) . rest-desc) (loop for ((sym (name . nics) desc (examples)) . rest-desc)
= *operator-descriptions* then rest-desc = *operator-descriptions* then rest-desc
for ((_sym . syntax) . rest-st) for ((_sym . syntax) . rest-st)
= *operator-symbol-table* then rest-st = *operator-symbol-table* then rest-st
while sym while sym
do do
(:tr (:tr
(:td name) (:td name)
(:td (format nil "~{~a~^, ~}" (sort (copy-list syntax) (:td (format nil "~{~a~^, ~}" (sort (copy-list syntax)
'string<))))) 'string<)))))
(:tr (:th "Operand") (:th "Syntax")) (:tr (:th "Operand") (:th "Syntax"))
(loop for (sym . syntax) in *operand-symbol-table* do (loop for (sym . syntax) in *operand-symbol-table* do
(:tr (:tr
(:td (string-downcase (symbol-name sym))) (:td (string-downcase (symbol-name sym)))
(:td (format nil "~{~a~^, ~}" (sort (copy-list syntax) (:td (format nil "~{~a~^, ~}" (sort (copy-list syntax)
'string<)))))) 'string<))))))
(:p "You can input multiple propositions by separating them with" (:p "You can input multiple propositions by separating them with"
"commas (,):" "commas (,):"
(:br) (:br)
(:code "ab,cd")) (:code "ab,cd"))
(:p "Two operands next to each other is treated as an 'implicit and'" (:p "Two operands next to each other is treated as an 'implicit and'"
"(unless this feature is disabled):" "(unless this feature is disabled):"
(:br) (:br)
(:code (:raw "abc|d = a &and; b &and; c &or; d")))))) (:code (:raw "abc|d = a &and; b &and; c &or; d"))))))
(defmethod get-dependencies ((overlay help-overlay)) (defmethod get-dependencies ((overlay help-overlay))
(append (append
@ -168,27 +170,27 @@ reblocks bug.")
:pretty-print pretty-print :pretty-print pretty-print
:latin-truths latin-truths))))) :latin-truths latin-truths)))))
(when data (when data
(with-html (with-html ()
(:div :class "label" "Output:") (:div :class "label" "Output:")
(:span :id "output-span" (:span :id "output-span"
;; there seems to be a bug in reblocks that means you have to pass ;; there seems to be a bug in reblocks that means you have to pass
;; the second argument to `make-js-action' ;; the second argument to `make-js-action'
(:button :onclick (make-js-action (:button :onclick (make-js-action
(lambda (&key &allow-other-keys) (lambda (&key &allow-other-keys)
(truth-table-toggle-output table) (truth-table-toggle-output table)
(update table)) (update table))
:args *blank-hash-table*) :args *blank-hash-table*)
:id "output-expander-button" :id "output-expander-button"
(if output-visible (if output-visible
"⏷" "⏷"
"⏵")) "⏵"))
(if (or pretty-print (if (or pretty-print
(equal format "ascii") (equal format "ascii")
(equal format "unicode")) (equal format "unicode"))
(:pre :id "output-area" :hidden (not output-visible) (:pre :id "output-area" :hidden (not output-visible)
other-text) other-text)
(:code :id "output-area" :hidden (not output-visible) (:code :id "output-area" :hidden (not output-visible)
other-text))) other-text)))
(:div :class "label" "HTML Preview:")) (:div :class "label" "HTML Preview:"))
(princ html-text reblocks/html:*stream*)))) (princ html-text reblocks/html:*stream*))))
nil) nil)
@ -240,11 +242,11 @@ reblocks bug.")
(defmethod render ((box error-box)) (defmethod render ((box error-box))
"Render BOX." "Render BOX."
(with-html (with-html ()
(with-slots (message) box (with-slots (message) box
(when message (when message
(:div (:div
(:pre message)))))) (:pre message))))))
(defmethod get-dependencies ((box error-box)) (defmethod get-dependencies ((box error-box))
(append (append
@ -340,9 +342,17 @@ reblocks bug.")
(update table) (update table)
(update error-box))) (update error-box)))
(declaim (inline handle-too-long-error))
(defun handle-too-long-error (page length)
"Handle requests that were too long by showing the user an error message."
(setf (error-box-message (page-error-box page))
(format nil "Input of length ~S is longer than maximum of ~S"
length *max-input-length*))
(update (page-error-box page)))
(defmethod render ((page page)) (defmethod render ((page page))
"Render PAGE." "Render PAGE."
(with-html (with-html ()
(:body (:body
(with-slots (table error-box help-overlay) page (with-slots (table error-box help-overlay) page
(render help-overlay) (render help-overlay)
@ -352,15 +362,17 @@ reblocks bug.")
include-vars subexps latin include-vars subexps latin
pretty pretty
&allow-other-keys) &allow-other-keys)
(handle-generate-request (if (> (length prop-str) *max-input-length*)
page :prop-str prop-str (handle-too-long-error page (length prop-str))
:implicit-and implicit-and (handle-generate-request
:multi-char-names multi-char-names page :prop-str prop-str
:format format :implicit-and implicit-and
:include-vars include-vars :multi-char-names multi-char-names
:subexps subexps :format format
:pretty pretty :include-vars include-vars
:latin latin))) :subexps subexps
:pretty pretty
:latin latin))))
(:div :id "main-controls-wrapper" (:div :id "main-controls-wrapper"
(:input :id "prop-input-field" (:input :id "prop-input-field"
:type "text" :type "text"
@ -487,6 +499,14 @@ was not specified."
*default-port*)) *default-port*))
*default-port*))) *default-port*)))
(defun wait-for-hunchentoot ()
"Wait for the hunchentoot webserver to exit."
(bordeaux-threads:join-thread
(find-if (lambda (thread)
(equal "clack-handler-hunchentoot"
(bordeaux-threads:thread-name thread)))
(bordeaux-threads:all-threads))))
(defun main (argv) (defun main (argv)
"The main entry point to the program. ARGV is the list of command line "The main entry point to the program. ARGV is the list of command line
arguments." arguments."
@ -497,7 +517,7 @@ arguments."
(format *error-output* "~a~%" c) (format *error-output* "~a~%" c)
(setq cmdline-error t) (setq cmdline-error t)
(continue)))) (continue))))
(destructuring-bind ((&rest norm-args) &rest opts) (destructuring-bind (norm-args &rest opts)
(parse-command-line *command-line-spec* argv) (parse-command-line *command-line-spec* argv)
;; parse the options here so that continue still exits properly ;; parse the options here so that continue still exits properly
(let ((port (determine-port opts)) (let ((port (determine-port opts))
@ -517,9 +537,11 @@ arguments."
:port port :port port
:interface address :interface address
:debug (option-value 'debug opts) :debug (option-value 'debug opts)
:disable-welcome-app t)))))) :disable-welcome-app t
:server-type :hunchentoot))))))
(defun toplevel () (defun toplevel ()
"Top-level function to be passed to `save-lisp-and-die'." "Top-level function to be passed to `save-lisp-and-die'."
#+sbcl (sb-ext:disable-debugger) #+sbcl (sb-ext:disable-debugger)
(main (uiop:command-line-arguments))) (main (uiop:command-line-arguments))
(wait-for-hunchentoot))