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