Puttin back simple static-file handler.

api.lisp

@@ -57,7 +57,7 @@
   "Stop an acceptor from listening for connections. It can be
 restarted with START-ACCEPTOR."
   (setf (shutdown-p acceptor) t)
-  (shutdown (taskmaster acceptor) acceptor)
+  (shutdown (taskmaster acceptor))
   (when soft
     (with-lock-held ((shutdown-lock acceptor))
       ;; FIXME: seems like this should perhaps be a while loop not a
@@ -129,8 +129,8 @@ we dynamically abort rather than returning a stream."
   (setf (status-code request) status-code)
   (let ((stream (send-response-headers request nil content-type charset)))
     (if (text-type-p content-type)
-        stream
-        (make-flexi-stream stream :external-format (make-external-format charset)))))
+        (make-flexi-stream stream :external-format (make-external-format charset))
+        stream)))
 
 (defun abort-request-handler (request response-status-code &optional body)
   "Abort the handling of a request, sending instead a response with
@@ -335,3 +335,34 @@ or NIL if no such cookie was sent."
   "Returns the current value of the outgoing cookie named
 NAME. Search is case-sensitive."
   (cdr (assoc name (cookies-out request) :test #'string=)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Trivial static file handler
+
+(defclass static-file-handler ()
+  ((root :initarg :root :accessor root)
+   (path-checker :initarg :path-checker :initform #'safe-filename-p :accessor path-checker))
+
+  (:documentation "A handler that serves files found under a given root directory."))
+
+(defmethod handle-request ((handler static-file-handler) request)
+  (with-slots (root path-checker) handler
+    (let ((*default-pathname-defaults* root)
+          (path (uri-path (request-uri request))))
+      (unless (funcall path-checker path)
+        (abort-request-handler request +http-forbidden+))
+      (serve-file request (merge-pathnames (subseq (add-index path) 1))))))
+
+(defun safe-filename-p (path)
+  "Verify that a path, translated to a file doesn't contain any tricky
+bits such as '..'"
+  (let ((directory (pathname-directory (subseq path 1))))
+    (or (stringp directory)
+        (null directory)
+        (and (consp directory)
+             (eql (first directory) :relative)
+             (every #'stringp (rest directory))))))
+
+(defun add-index (filename &key (extension "html"))
+  (format nil "~a~@[index~*~@[.~a~]~]" filename (ends-with #\/ filename) extension))

http.lisp

@@ -88,6 +88,8 @@
    (shutdown-queue       :initform (make-condition-variable) :accessor shutdown-queue)
    (shutdown-lock        :initform (make-lock "toot-shutdown") :accessor shutdown-lock))
 
+  (:documentation "The object that listens on a socket for connections.")
+
   (:default-initargs
     :address nil
     :port nil

log.lisp

@@ -52,7 +52,8 @@
 
 (defclass stream-logger ()
   ((destination :initarg :destination :reader destination)
-   (lock :initform (make-lock "log-lock") :reader lock)))
+   (lock :initform (make-lock "log-lock") :reader lock))
+  (:documentation "A logger that writes to a given stream."))
 
 (defvar *default-logger* (make-instance 'stream-logger :destination *error-output*))
 

packages.lisp

@@ -42,6 +42,7 @@
 
    :acceptor
    :stream-logger
+   :static-file-handler
 
    ;; Generic functions
    :handle-request

taskmaster.lisp

@@ -27,26 +27,28 @@
 
 (in-package :toot)
 
-(defclass taskmaster () ())
 
-(defgeneric execute-acceptor (taskmaster acceptor))
+(defgeneric execute-acceptor (taskmaster acceptor)
+  (:documentation "Execute the acceptor by calling accept-connections."))
 
-(defgeneric handle-incoming-connection (taskmaster acceptor socket))
+(defgeneric handle-incoming-connection (taskmaster acceptor socket)
+  (:documentation "Handle a new connection by calling process-connection."))
 
-(defgeneric shutdown (taskmaster acceptor))
+(defgeneric shutdown (taskmaster)
+  (:documentation "Shutdown the taskmaster, cleaning up an threads it created."))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Simple minded, single-threaded taskmaster implemenetation
 
-(defclass single-threaded-taskmaster (taskmaster) ())
+(defclass single-threaded-taskmaster () ())
 
 (defmethod execute-acceptor ((taskmaster single-threaded-taskmaster) acceptor)
   (accept-connections acceptor))
 
 (defmethod handle-incoming-connection ((taskmaster single-threaded-taskmaster) acceptor socket)
   (process-connection acceptor socket))
 
-(defmethod shutdown ((taskmaster taskmaster) acceptor) taskmaster)
+(defmethod shutdown ((taskmaster single-threaded-taskmaster)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Thread-per-connection taskmaster implemenetation
@@ -60,7 +62,7 @@
 ;;  - Bordeaux Threads doesn't provide a way to "reset" and restart a thread,
 ;;    and it's not clear how many Lisp implementations can do this.
 ;; So for now, we leave this out of the mix.
-(defclass thread-per-connection-taskmaster (taskmaster)
+(defclass thread-per-connection-taskmaster ()
   ((acceptor-process :accessor acceptor-process)
    (max-thread-count
     :type (or integer null)
@@ -166,10 +168,8 @@ implementations."))
     (t
      (create-connection-handler-thread taskmaster acceptor socket))))
 
-(defmethod shutdown ((taskmaster thread-per-connection-taskmaster) acceptor)
-  ;; just wait until the acceptor process has finished, then return
-  (loop while (thread-alive-p (acceptor-process taskmaster)) do (sleep 1))
-  taskmaster)
+(defmethod shutdown ((taskmaster thread-per-connection-taskmaster))
+  (loop while (thread-alive-p (acceptor-process taskmaster)) do (sleep 1)))
 
 (defun increment-taskmaster-request-count (taskmaster)
   (when (taskmaster-max-thread-count taskmaster)

tests.lisp

@@ -64,22 +64,9 @@ to what ENOUGH-NAMESTRING does for pathnames."
         (subseq url prefix-length)
         url)))
 
-(defun safe-filename-p (path)
-  "Verify that a path, translated to a file doesn't contain any tricky
-bits such as '..'"
-  (let ((directory (pathname-directory (subseq path 1))))
-    (or (stringp directory)
-        (null directory)
-        (and (consp directory)
-             (eql (first directory) :relative)
-             (every #'stringp (rest directory))))))
-
 (defun resolve-file (path document-root)
   (merge-pathnames (subseq (add-index path) 1) document-root))
 
-(defun add-index (filename &key (extension "html"))
-  (format nil "~a~@[index~*~@[.~a~]~]" filename (ends-with #\/ filename) extension))
-
 ;;; Simple composite handler that searches a list of sub-handlers for
 ;;; one that can handle the request.
 

toot.asd

@@ -37,6 +37,7 @@ output.")
 (export '*toot-version*)
 
 (defsystem :toot
+  :description "A minimal web server originally built by stripping down Edi Weitz's Hunchentoot"
   :serial t
   :version #.*toot-version*
   :depends-on (:alexandria