Redo web server build

.gitignore

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

Makefile

@@ -3,6 +3,7 @@ SBCL ?= sbcl
 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
 
@@ -10,6 +11,10 @@ cli: truth-table
 truth-table: build.lisp truth-table.asd $(BASE_FILES) $(CLI_FILES)
 	$(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:
 	rm -f truth-table
 

build.lisp

@@ -16,3 +16,14 @@
    :executable t
    :save-runtime-options t
    :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)))

truth-table-web-wrapper

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

truth-table.asd

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

web.lisp

@@ -37,13 +37,15 @@
 (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")
@@ -168,7 +170,7 @@ 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
@@ -240,7 +242,7 @@ reblocks bug.")
 
 (defmethod render ((box error-box))
   "Render BOX."
-  (with-html
+  (with-html ()
     (with-slots (message) box
       (when message
         (:div
@@ -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,6 +362,8 @@ reblocks bug.")
                                          include-vars subexps latin
                                          pretty
                                        &allow-other-keys)
+                                (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
@@ -360,7 +372,7 @@ reblocks bug.")
                                           :include-vars include-vars
                                           :subexps subexps
                                           :pretty pretty
-                                 :latin latin)))
+                                          :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))