Make web server

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)'
+	$(SBCL) --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)'
 
 clean:
-	rm -f truth-table truth-table-webserver
+	rm -f truth-table
 
 .PHONY: all cli clean

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~]~@[=<arg>~*~]~>  ~a~%"
                    longest-option
                    short (or short long) long has-arg-p desc))
-  (format stream "~%The choice surrounded by '*' is the default. Arguments to long
+  (format stream
-options are also required for their short variant.~%"))
+"~%~@[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

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))
+   #:option-value
-
+   #:parse-command-line))
-(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))

build.lisp

@@ -1,15 +1,14 @@
 ;; This file should be run as follows:
-;;   sbcl --load build.lisp --eval '(<BUILD FUNCTION>)'
+;;   sbcl --load build.lisp --eval '(cli)'
 ;; where <BUILD FUNCTION> 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)))

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 <https://www.gnu.org/licenses/>.
+(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*
+           (print-usage t *command-line-spec* "truth-table"
-                        "truth-table" "<propositions...>")
+                        :general-args "<propositions...>")
            (uiop:quit (if cmdline-error 1 0)))
           ((null prop-strs)
            (cerror *cli-parse-continue-string* 'no-input-error))

parse.lisp

@@ -258,6 +258,16 @@ found variables."
         (operands '())
         (oper-poses '())
         (last-was-operand nil))
+    (flet ((push-operator (value pos)
+             (multiple-value-bind (new-oper new-opan pop-count)
+                 (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 value operators)
+             (push pos oper-poses)))
       (dotokens (token token-pos str)
           (:multi-char-names multi-char-names)
         (destructuring-bind (type value) (interpret-token token)
@@ -277,23 +287,25 @@ found variables."
                         :position token-pos
                         :proposition str
                         :message "expected operator, found operand"))
-             (multiple-value-bind (new-oper new-opan pop-count)
+               (push-operator 'and token-pos))
-                 (apply-lower-precedent (operator-precedence 'and)
-                                        operators operands str token-pos)
-               (setq operators new-oper
-                     operands new-opan)
-               (dotimes (i pop-count)
-                 (pop oper-poses)))
-             (push 'and 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)
+             (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))
+            ;; close paren doesn't touch `last-was-operand'
             ((eq value 'close-paren)
              (loop while (not (eq (car operators) 'open-paren))
                    when (null operators) do
@@ -311,15 +323,7 @@ found variables."
              (pop oper-poses))
             ;; operator
             (t
-           (multiple-value-bind (new-oper new-opan pop-count)
+             (push-operator value token-pos)
-               (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)
@@ -333,4 +337,4 @@ found variables."
                      (apply-one-operator operators operands
                                          str oper-pos)))
       ;; return variables in the order we found them
-    (values (car operands) (nreverse found-vars))))
+      (values (car operands) (nreverse found-vars)))))

table.lisp

@@ -15,13 +15,18 @@
 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 (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
+  (let ((vars))
-    ((stringp prop)
+    (dolist (item (flatten-tree prop) (nreverse vars))
-     (list prop))
+      (when (stringp item)
-    ((listp prop)
+        (pushnew item vars :test 'equal)))))
-     (mapcan 'discover-variables (cdr prop)))))
 
 (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)
+  (cond
-      (list (list (cons prop (eval-proposition prop '()))))
+    ((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
-                      (delete-if (lambda (item) (equal prop (car item)))
+                     (reverse (delete-if (lambda (item) (equal prop (car item)))
-                                 sub-map))
+                                         sub-map)))
-                    (list (cons prop value))))))
+                   (list (cons prop value)))))))
 
 (defun extract-truth-table-expressions (table)
   "Extract each expression from TABLE and return them as a list.

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)' "${@}"

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")))

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 "&lt;"
+                             else if (eq char #\>)
+                                    collect "&gt;"
+                             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 "~
+<table~@[ class=~s~]~@[ id=~s~]~{ ~A~}>~
+  <tr>~{<th>~A</th>~}</tr>~
+  ~{<tr>~{<td>~:[&perp;~;&top;~]</td>~}</tr>~}~
+</table>"
+            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))))

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 <https://www.gnu.org/licenses/>.
+(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
+  #+sbcl (sb-ext:disable-debugger)
-      (with-user-abort:with-user-abort
   (main (uiop:command-line-arguments)))
-    (with-user-abort:user-abort ()
-      (format *error-output* "Keyboard interrupt~%")
-      (uiop:quit 1))))