From c6cadc31230a87249c20653f146d4fbb8a3fddcb Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Thu, 5 Sep 2024 14:46:05 -0700 Subject: [PATCH] Make web server --- Makefile | 16 +- arguments.lisp | 8 +- packages.lisp => base-packages.lisp | 15 +- build.lisp | 15 +- cli.lisp | 12 +- parse.lisp | 144 ++++++------ table.lisp | 41 ++-- truth-table-web-wrapper | 5 + truth-table.asd | 12 +- typeset.lisp | 62 ++++- web.lisp | 337 +++++++++++++++++++++++++++- 11 files changed, 525 insertions(+), 142 deletions(-) rename packages.lisp => base-packages.lisp (81%) create mode 100755 truth-table-web-wrapper diff --git a/Makefile b/Makefile index b3730c2..5227158 100644 --- a/Makefile +++ b/Makefile @@ -1,20 +1,16 @@ -LISP ?= sbcl +SBCL ?= sbcl -BASE_FILES=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 CLI_FILES=cli.lisp -WEB_FILES=web.lisp -all: cli web +all: cli cli: truth-table truth-table: build.lisp truth-table.asd $(BASE_FILES) $(CLI_FILES) - $(LISP) --load build.lisp --eval '(cli)' - -web: truth-table-webserver -truth-table-webserver: build.lisp truth-table.asd $(BASE_FILES) $(WEB_FILES) - $(LISP) --load build.lisp --eval '(web)' + $(SBCL) --load build.lisp --eval '(cli)' clean: - rm -f truth-table truth-table-webserver + rm -f truth-table .PHONY: all cli clean diff --git a/arguments.lisp b/arguments.lisp index f83c838..339eaee 100644 --- a/arguments.lisp +++ b/arguments.lisp @@ -130,7 +130,8 @@ arguments will be placed in a list at the beginning of the alist." finally (setf output-other (nconc (nreverse rest) output-other))) (cons (nreverse output-other) output-opts))) -(defun print-usage (stream spec exec-name &optional general-args) +(defun print-usage (stream spec exec-name &key general-args + (print-astrisk t)) "Print the command line usage corresponding to SPEC to STREAM." (format stream "usage: ~a [options]~@[ ~a~]~%~%" exec-name general-args) (loop with longest-option @@ -149,8 +150,9 @@ arguments will be placed in a list at the beginning of the alist." (format stream " ~v@<~@[-~c~]~@[, ~*~]~@[--~a~]~@[=~*~]~> ~a~%" longest-option short (or short long) long has-arg-p desc)) - (format stream "~%The choice surrounded by '*' is the default. Arguments to long -options are also required for their short variant.~%")) + (format stream +"~%~@[The choice surrounded by '*' is the default. ~]Arguments to long~:[ ~;~%~]~ +options are also required for their short variant.~%" print-astrisk print-astrisk)) (defun option-value (opt opts) "Get the value of command line option OPT from OTPS, which is an alist as diff --git a/packages.lisp b/base-packages.lisp similarity index 81% rename from packages.lisp rename to base-packages.lisp index da8acbd..dfc33a4 100644 --- a/packages.lisp +++ b/base-packages.lisp @@ -41,6 +41,7 @@ #:latex-var-name-transform #:typeset-proposition #:convert-truth-table-to-latex + #:convert-truth-table-to-html #:*table-border-ascii-alist* #:*table-border-unicode-alist* #:typeset-truth-table @@ -56,16 +57,6 @@ #:unknown-option-error #:option-no-arg-error #:no-input-error - #:parse-command-line #:print-usage - #:option-value)) - -(defpackage #:truth-table/cli - (:use #:common-lisp #:truth-table/base - #:truth-table/args) - (:export #:toplevel #:main)) - -(defpackage #:truth-table/web - (:use #:common-lisp #:truth-table/base - #:truth-table/args) - (:export #:toplevel #:main)) + #:option-value + #:parse-command-line)) diff --git a/build.lisp b/build.lisp index d3e8991..199d6f5 100644 --- a/build.lisp +++ b/build.lisp @@ -1,15 +1,14 @@ ;; This file should be run as follows: -;; sbcl --load build.lisp --eval '()' +;; sbcl --load build.lisp --eval '(cli)' ;; where is either `cli' or `web' #-sbcl (error "Only SBCL is supported right now") -(sb-ext:disable-debugger) - (require :asdf) (defun cli () "Build the CLI application executable." + (sb-ext:disable-debugger) (asdf:load-system :truth-table/cli) (require :truth-table/cli) (sb-ext:save-lisp-and-die @@ -17,13 +16,3 @@ :executable t :save-runtime-options t :toplevel (intern "TOPLEVEL" :truth-table/cli))) - -(defun web () - "Build the web server executable." - (asdf:load-system :truth-table/web) - (require :truth-table/web) - (sb-ext:save-lisp-and-die - "truth-table-webserver" - :executable t - :save-runtime-options t - :toplevel (intern "TOPLEVEL" :truth-table/web))) diff --git a/cli.lisp b/cli.lisp index 40bea09..f2523df 100644 --- a/cli.lisp +++ b/cli.lisp @@ -13,6 +13,11 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . +(defpackage #:truth-table/cli + (:use #:common-lisp #:truth-table/base + #:truth-table/args) + (:export #:toplevel #:main)) + (in-package :truth-table/cli) (defun eval-and-typeset-propositions (prop-strs &key (format "unicode") @@ -43,7 +48,8 @@ functions involved in evaluating and typesetting." (defparameter *command-line-spec* '((#\h "help" help nil "print this message, then exit") - (#\f "format" format t "specify the output format (*unicode*, ascii, or latex)") + (#\f "format" format t + "specify the output format (*unicode*, ascii, latex, or html)") (#\s "subexps" subexps nil "include sub-expressions in the output table") (#\n "no-vars" no-vars nil "do not include variables in the output table") (#\m "multi-char" multi-char nil "allow multi-character variable names") @@ -70,8 +76,8 @@ arguments." (parse-command-line *command-line-spec* argv) (cond ((option-value 'help opts) - (print-usage t *command-line-spec* - "truth-table" "") + (print-usage t *command-line-spec* "truth-table" + :general-args "") (uiop:quit (if cmdline-error 1 0))) ((null prop-strs) (cerror *cli-parse-continue-string* 'no-input-error)) diff --git a/parse.lisp b/parse.lisp index 2ca1cc9..22cfe1c 100644 --- a/parse.lisp +++ b/parse.lisp @@ -258,79 +258,83 @@ found variables." (operands '()) (oper-poses '()) (last-was-operand nil)) - (dotokens (token token-pos str) - (:multi-char-names multi-char-names) - (destructuring-bind (type value) (interpret-token token) - (cond - ;; unknown type - ((not type) - (error 'proposition-parse-error - :position token-pos - :proposition str - :message "unknown token")) - ;; operand - ((eq type 'operand) - (when last-was-operand - ;; two operands next to each other often means "and" implicitly - (unless implicit-and - (error 'proposition-parse-error - :position token-pos - :proposition str - :message "expected operator, found operand")) + (flet ((push-operator (value pos) (multiple-value-bind (new-oper new-opan pop-count) - (apply-lower-precedent (operator-precedence 'and) - operators operands str token-pos) + (apply-lower-precedent (operator-precedence value) + operators operands str pos) (setq operators new-oper operands new-opan) (dotimes (i pop-count) (pop oper-poses))) - (push 'and operators) + (push value operators) + (push pos oper-poses))) + (dotokens (token token-pos str) + (:multi-char-names multi-char-names) + (destructuring-bind (type value) (interpret-token token) + (cond + ;; unknown type + ((not type) + (error 'proposition-parse-error + :position token-pos + :proposition str + :message "unknown token")) + ;; operand + ((eq type 'operand) + (when last-was-operand + ;; two operands next to each other often means "and" implicitly + (unless implicit-and + (error 'proposition-parse-error + :position token-pos + :proposition str + :message "expected operator, found operand")) + (push-operator 'and token-pos)) + (unless (member value '(true false)) + (pushnew value found-vars :test 'equal)) + (push value operands) + (setq last-was-operand t)) + ((eq value 'open-paren) + (when last-was-operand + ;; an open parenthesis directly following an operator is also a + ;; signal of an implicit "and" + (unless implicit-and + (error 'proposition-parse-error + :position token-pos + :proposition str + :message "expected operator, found open parenthesis")) + (push-operator 'and token-pos) + (setq last-was-operand nil)) + (push value operators) (push token-pos oper-poses)) - (unless (member value '(true false)) - (pushnew value found-vars :test 'equal)) - (push value operands) - (setq last-was-operand t)) - ;; open and close paren don't touch `last-was-operand' - ((eq value 'open-paren) - (push value operators) - (push token-pos oper-poses)) - ((eq value 'close-paren) - (loop while (not (eq (car operators) 'open-paren)) - when (null operators) do - (error 'proposition-parse-error - :position token-pos - :proposition str - :message "no matching open parenthesis") - do - (setf (values operators operands) - (apply-one-operator operators operands - str token-pos)) - (pop oper-poses)) - ;; remove the open-paren - (pop operators) - (pop oper-poses)) - ;; operator - (t - (multiple-value-bind (new-oper new-opan pop-count) - (apply-lower-precedent (operator-precedence value) - operators operands str token-pos) - (setq operators new-oper - operands new-opan) - (dotimes (i pop-count) - (pop oper-poses))) - (push value operators) - (push token-pos oper-poses) - (setq last-was-operand nil))))) - (loop while operators - for oper-pos = (pop oper-poses) - when (eq (car operators) 'open-paren) do - (error 'proposition-parse-error - :message "no matching closing parenthesis" - :proposition str - :position oper-pos) - do - (setf (values operators operands) - (apply-one-operator operators operands - str oper-pos))) - ;; return variables in the order we found them - (values (car operands) (nreverse found-vars)))) + ;; close paren doesn't touch `last-was-operand' + ((eq value 'close-paren) + (loop while (not (eq (car operators) 'open-paren)) + when (null operators) do + (error 'proposition-parse-error + :position token-pos + :proposition str + :message "no matching open parenthesis") + do + (setf (values operators operands) + (apply-one-operator operators operands + str token-pos)) + (pop oper-poses)) + ;; remove the open-paren + (pop operators) + (pop oper-poses)) + ;; operator + (t + (push-operator value token-pos) + (setq last-was-operand nil))))) + (loop while operators + for oper-pos = (pop oper-poses) + when (eq (car operators) 'open-paren) do + (error 'proposition-parse-error + :message "no matching closing parenthesis" + :proposition str + :position oper-pos) + do + (setf (values operators operands) + (apply-one-operator operators operands + str oper-pos))) + ;; return variables in the order we found them + (values (car operands) (nreverse found-vars))))) diff --git a/table.lisp b/table.lisp index 6d692e0..a6638e9 100644 --- a/table.lisp +++ b/table.lisp @@ -15,13 +15,18 @@ ;; along with this program. If not, see . (in-package :truth-table/base) +(defun flatten-tree (tree) + "Flatten TREE into a single list." + (if (atom tree) + (list tree) + (apply 'append (mapcar 'flatten-tree tree)))) + (defun discover-variables (prop) "Return a list of all the variables in PROP, in left to right order." - (cond - ((stringp prop) - (list prop)) - ((listp prop) - (mapcan 'discover-variables (cdr prop))))) + (let ((vars)) + (dolist (item (flatten-tree prop) (nreverse vars)) + (when (stringp item) + (pushnew item vars :test 'equal))))) (defun permute-variables (vars) "Return a list of alists, each with a different permutation of VARS." @@ -38,17 +43,21 @@ "Evaluate PROP with all possible combinations of truth values for its variables. If supplied VARS should be a list of all the know variables in PORP, if it is excluded, `discover-variables' will be used to generate it." - (if (null vars) - (list (list (cons prop (eval-proposition prop '())))) - (loop for perm in (permute-variables vars) - for (value sub-map) = (multiple-value-list - (eval-proposition prop perm)) - collect - (append (when include-vars perm) - (when include-intermediate - (delete-if (lambda (item) (equal prop (car item))) - sub-map)) - (list (cons prop value)))))) + (cond + ((null prop) + (list (list (cons nil nil)))) + ((null vars) + (list (list (cons prop (eval-proposition prop '()))))) + (t + (loop for perm in (permute-variables vars) + for (value sub-map) = (multiple-value-list + (eval-proposition prop perm)) + collect + (append (when include-vars perm) + (when include-intermediate + (reverse (delete-if (lambda (item) (equal prop (car item))) + sub-map))) + (list (cons prop value))))))) (defun extract-truth-table-expressions (table) "Extract each expression from TABLE and return them as a list. diff --git a/truth-table-web-wrapper b/truth-table-web-wrapper new file mode 100755 index 0000000..41de794 --- /dev/null +++ b/truth-table-web-wrapper @@ -0,0 +1,5 @@ +#!/bin/sh + +exec sbcl --noinform \ + --eval '(asdf:load-system :truth-table/web)' \ + --eval '(truth-table/web:toplevel)' "${@}" diff --git a/truth-table.asd b/truth-table.asd index 3535f4d..c9e0357 100644 --- a/truth-table.asd +++ b/truth-table.asd @@ -9,7 +9,7 @@ :depends-on () :serial t :components - ((:file "packages") + ((:file "base-packages") (:file "parse") (:file "eval") (:file "table") @@ -19,7 +19,7 @@ :depends-on (#:uiop) :serial t :components - ((:file "packages") + ((:file "base-packages") (:file "arguments"))) (defsystem #:truth-table/cli @@ -29,17 +29,15 @@ #:truth-table/args) :serial t :components - ((:file "packages") - (:file "cli"))) + ((:file "cli"))) (defsystem #:truth-table/web :depends-on (#:uiop - #:with-user-abort #:reblocks #:reblocks-ui + #:reblocks-lass #:truth-table/base #:truth-table/args) :serial t :components - ((:file "packages") - (:file "web"))) + ((:file "web"))) diff --git a/typeset.lisp b/typeset.lisp index 0fd1e0b..7360053 100644 --- a/typeset.lisp +++ b/typeset.lisp @@ -71,6 +71,22 @@ (false . "\\bot")) "Lookup table mapping operators to their LaTeX representation.") +(defparameter *operator-html-lookup-alist* + '((and . "∧") + (nand . "↑") + (or . "∨") + (nor . "↓") + (xor . "⊕") + (not . "¬") + (implies . "→") + (converse . "←") + (iff . "↔") + (open-paren . "(") + (close-paren . ")") + (true . "⊤") + (false . "⊥")) + "Lookup table mapping operators to their HTML representation.") + (defun latex-var-name-transform (name) "Transform NAME so that it is escaped for use in LaTeX." (format nil "{~{~A~}}" (loop for char across name @@ -83,6 +99,16 @@ else collect char))) +(defun html-var-name-transform (name) + "Transform NAME so that it is escaped for use in HTML." + (format nil "~{~A~}" (loop for char across name + if (eq char #\<) + collect "<" + else if (eq char #\>) + collect ">" + else + collect char))) + (defun typeset-proposition (expr &optional (lookup-table *operator-ascii-lookup-alist*) var-name-transform @@ -93,6 +119,9 @@ be a table mapping operators to their textual representation. VAR-NAME-TRANSFORM escape it for use in the target typesetting system. PARENT-PERC is for internal use (it controls when parentheses are applied.)" (cond + ;; expr is empty + ((null expr) + "") ;; expr is a variable name ((stringp expr) (if var-name-transform @@ -154,6 +183,35 @@ between each row." typeset-exprs (extract-truth-table-values table)))) +(defun format-html-properties-alist (props) + "Format PROPS, a list of conses, as a list of HTML properties." + (loop for (name . value) in props + when (eq value t) + collect (format nil "~A=\"\"" name) + else when value + collect (format nil "~A=~S" name (princ-to-string value)))) + + +(defun convert-truth-table-to-html (table &key class id more-props) + "Convert TABLE, which should be a truth table as returned by +`create-truth-table' to HTML. CLASS and ID are their respective HTML +properties. MORE-PROPS is an alist mapping properties to values. +NOTE: though the overall order does not matter, the order must be the same +between each row." + (let ((typeset-exprs (mapcar (lambda (expr) + (typeset-proposition + expr *operator-html-lookup-alist* + 'html-var-name-transform)) + (extract-truth-table-expressions table)))) + (format nil "~ +~ + ~{~A~}~ + ~{~{~:[⊥~;⊤~]~}~}~ +" + class id (format-html-properties-alist more-props) + typeset-exprs + (extract-truth-table-values table)))) + (defparameter *table-border-ascii-alist* '((vertical . #\|) (horizontal . #\-) @@ -255,7 +313,7 @@ between each row." (cdr (assoc 'bottom-right box-lookup-table)))))) (defparameter *known-formats* - '("unicode" "ascii" "latex") + '("unicode" "ascii" "latex" "html") "The known formats that `typeset-table-to-format' can take.") (defun typeset-table-to-format (table format) @@ -269,4 +327,6 @@ between each row." *table-border-ascii-alist*)) ((equal format "latex") (convert-truth-table-to-latex table)) + ((equal format "html") + (convert-truth-table-to-html table)) (t (error 'table-format-error :format format)))) diff --git a/web.lisp b/web.lisp index 46489f4..ae19588 100644 --- a/web.lisp +++ b/web.lisp @@ -13,18 +13,341 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . +(defpackage #:truth-table/web + (:use #:common-lisp #:truth-table/base + #:truth-table/args) + (:export #:toplevel #:main) + (:import-from #:reblocks/app + #:defapp) + (:import-from #:reblocks/html + #:with-html) + (:import-from #:reblocks/widget + #:defwidget + #:update + #:render) + (:import-from #:reblocks-ui/form + #:with-html-form) + (:import-from #:reblocks/actions + #:make-js-action) + (:import-from #:reblocks/dependencies + #:get-dependencies)) + (in-package :truth-table/web) +(defparameter *default-port* 8000) +(defparameter *default-address* "127.0.0.1") + +(defwidget truth-table () + ((data :initform nil + :accessor truth-table-data) + (format :initform "html" + :accessor truth-table-format) + (output-visible :initform t + :accessor truth-table-output-visible)) + (:documentation "Class to hold the generated table.")) + +(defmethod truth-table-toggle-output ((table truth-table)) + "Toggle the visibility of the output box of TABLE." + (with-slots (output-visible) table + (setf output-visible (not output-visible)))) + +(defparameter *blank-hash-table* (make-hash-table) + "Blank hash table to pass to make-js-action because of what seems to be a +reblocks bug.") + +(defmethod render ((table truth-table)) + "Render TABLE." + (with-slots (data format output-visible) table + (let* ((html-text (convert-truth-table-to-html data)) + (other-text + (when output-visible + (if (equal format "html") + html-text + (typeset-table-to-format data format))))) + (when data + (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 (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) + +(defmethod get-dependencies ((widget truth-table)) + (append + (list + (reblocks-lass:make-dependency + '(.truth-table + (.label + :font-size "large" + :font-weight "bold" + :margin-top "5px" + :margin-bottom "5px") + (|#output-span| + :display "flex" + (button :margin-right "10px")) + (|#output-expander-button| + :margin-bottom "auto" + :font-size "xx-large" + :background "none" + :border "none" + :cursor "pointer") + (|#output-area| + :background "lightgrey" + :flex-grow "1" + :padding "5px" + :border-style "solid" + :border-color "black" + :border-width "1px" + :max-height "25vh" + :overflow-y "scroll") + (table + :margin "auto" + :border-collapse "collapse" + :border-spacing "0px" + ((:or th td) + :padding "3px" + :text-align "center" + :border-style "solid" + :border-width "1px" + :border-color "black"))))) + (call-next-method))) + +(defwidget error-box () + ((message :initform nil + :accessor error-box-message)) + (:documentation "Class to hold various error messages.")) + +(defmethod render ((box error-box)) + "Render BOX." + (with-html + (with-slots (message) box + (when message + (:div + (:pre message)))))) + +(defmethod get-dependencies ((box error-box)) + (append + (list + (reblocks-lass:make-dependency + `(.error-box + (div + :border-width "1px" + :border-style "solid" + :border-color "black" + (pre + :margin "0px" + :padding-top "5px" + :font-size "large" + :border-left-style "solid" + :border-left-color "red" + :border-left-width "10px" + :padding-left "5px"))))) + (call-next-method))) + +(defwidget page () + ((table :initform (make-instance 'truth-table) + :accessor page-table) + (error-box :initform (make-instance 'error-box) + :accessor page-error-box)) + (:documentation "The root of the whole page")) + +(defmethod handle-generate-request ((page page) + &key prop-str implicit-and multi-char-names + format include-vars subexps) + "Handler for requests to generate truth tables." + (with-slots (table error-box) page + (setf (truth-table-format table) format + (error-box-message error-box) nil) + (if (not (zerop (length prop-str))) + (handler-case + (multiple-value-bind (parsed-exp vars) + (parse-proposition-string + prop-str + :implicit-and implicit-and + :multi-char-names multi-char-names) + (setf (truth-table-data table) (create-truth-table parsed-exp + :vars vars + :include-vars include-vars + :include-intermediate subexps))) + ((or proposition-parse-error proposition-eval-error) (e) + (setf (error-box-message error-box) (princ-to-string e)))) + (setf (truth-table-data table) nil)) + (update table) + (update error-box))) + +(defmethod render ((page page)) + "Render PAGE." + (with-html + (with-slots (table error-box) page + (:h1 "Truth Table Generator") + (with-html-form (:POST (lambda (&key prop-str implicit-and + multi-char-names format + include-vars subexps + &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))) + (:div :id "main-controls-wrapper" + (:input :id "prop-input-field" + :type "text" + :name "prop-str" + :placeholder "Proposition string...") + (:input :id "submit-button" + :type "submit" + :value "Generate")) + (:div :id "extra-controls-wrapper" + (:input :type "checkbox" + :name "implicit-and" + :checked t) + (:label :for "implicit-and" "Implicit And") + (:input :type "checkbox" + :name "multi-char-names" + :style "margin-left: 10px;") + (:label :for "multi-char-names" "Multi-character Variables") + (:input :type "checkbox" + :name "include-vars" + :checked t + :style "margin-left: 10px;") + (:label :for "include-vars" "Include Variables") + (:input :type "checkbox" + :name "subexps" + :checked t + :style "margin-left: 10px;") + (:label :for "subexps" "Include Sub-expressions") + (:select :name "format" :style "margin-left: 10px;" + (:option :value "html" "HTML") + (:option :value "latex" "LaTeX") + (:option :value "ascii" "ASCII") + (:option :value "unicode" "Unicode")))) + (render error-box) + (render table) + (:div :id "info-text" + (:span + "This website is free software under the terms of the AGPL" + "license version 3. You can find a copy of the license ") + (:a :href "https://www.gnu.org/licenses/agpl-3.0.html" + "here") + (:span ". You can find the source of this website ") + (:a :href "https://git.zander.im/Zander671/truth-table" + "here") + (:span "."))))) + +(defmethod get-dependencies ((page page)) + (append + (list + (reblocks-lass:make-dependency + '(.page + :width "70%" + :margin "auto" + (h1 :text-align "center") + (form + :margin-bottom "5px" + (|#main-controls-wrapper| + :display flex + :margin-bottom "5px" + (|#prop-input-field| + :flex-grow "1" + :margin-right "5px" + :font-size "large") + (|#submit-button| + :font-size "large")) + (|#extra-controls-wrapper| + :display "flex" + :justify-content "center" + :align-items "center")) + (|#info-text| + :text-align "center" + :margin-top "10px" + :font-size "small")))) + (call-next-method))) + +(defapp truth-table-app + :prefix "/") + +(defmethod reblocks/page:init-page ((app truth-table-app) (url-path string) + expire-at) + "Main entry point for webpage." + (declare (ignorable app url-path expire-at)) + (make-instance 'page)) + +(defparameter *command-line-spec* + `((#\h "help" help nil "print this message, then exit") + (#\d "debug" debug nil "enable debug output") + (#\p "port" port t + ,(format nil "specify port to use (default: ~d)" *default-port*)) + (#\a "address" address t + ,(format nil "specify address to bind to (default: ~a)" *default-address*))) + "Spec for use in `parse-command-line.") + +(defun determine-port (opts) + "Get port from the command line option array OPTS, or use a default if port +was not specified." + (let ((raw-value (option-value 'port opts))) + (if raw-value + (handler-case + (let ((value (parse-integer raw-value :junk-allowed nil))) + (if (< value 1) + (error 'parse-error) + value)) + (parse-error () + (cerror "Use *default-port*" 'command-line-error + :message (format nil "invalid port: ~a" raw-value)) + *default-port*)) + *default-port*))) + (defun main (argv) "The main entry point to the program. ARGV is the list of command line arguments." - (format t "Hello World~%")) + (let ((cmdline-error nil)) + (handler-bind + ((command-line-error + (lambda (c) + (format *error-output* "~a~%" c) + (setq cmdline-error t) + (continue)))) + (destructuring-bind ((&rest 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)) + (address (or (option-value 'address opts) *default-address*))) + (when norm-args + (cerror "Ignore the extra arguments." 'command-line-error + :message "extra non-option arguments")) + (when (option-value 'help opts) + (print-usage t *command-line-spec* "truth-table-webserver" + :print-astrisk nil) + (if cmdline-error + (uiop:quit 1) + (uiop:quit 0))) + (when cmdline-error + (uiop:quit 1)) + (reblocks/server:start :apps '(truth-table-app) + :port port + :interface address + :debug (option-value 'debug opts))))))) (defun toplevel () "Top-level function to be passed to `save-lisp-and-die'." - (handler-case - (with-user-abort:with-user-abort - (main (uiop:command-line-arguments))) - (with-user-abort:user-abort () - (format *error-output* "Keyboard interrupt~%") - (uiop:quit 1)))) + #+sbcl (sb-ext:disable-debugger) + (main (uiop:command-line-arguments)))