Commit 1f40858d authored by Dave Cooper's avatar Dave Cooper

Added back clobbered changes to support test-serve.lisp.

parent c748b33d
......@@ -33,3 +33,6 @@
capture output when compile/loading any lispy html content files
wrapped with calls to add-content. Global value should always be
(defvar *aserve-port* 8008)
(defvar *aserve-listeners* 5)
(defpackage #:cl-site
(:use :cl)
(:export #:make-site #:make-clean #:add-content #:wmd :with-cl-who-string))
(:export #:make-site #:make-clean #:add-content #:wmd #:with-cl-who-string
#:start-aserve #:publish-cl-site))
(defpackage #:cl-site-content
(in-package :cl-site)
(defun publish-cl-site ()
(dolist (file (directory (make-pathname :defaults *OUTPUT-DIR* :name :wild :type "html")))
(dolist (format-string (list "/~a" "/~a.htm" "/~a.html"))
(net.aserve:publish-file :path (format nil format-string (pathname-name file))
:file (namestring file))))
(net.aserve:publish-directory :prefix "/"
:destination (namestring *output-dir*)))
;; FLAG -- below utility functions borrowed from Gendl Remove when/if
;; Gendl is included in cl-site. On the other hand, these are a bit
;; of a mess and any feedback is welcome, to clean them up before
;; blindly :use'ing them as-is from Gendl.
(defun client-test (port)
"Check if a port is busy" ;; FLAG there must be a better way to check for
;; a busy port than this...
(multiple-value-bind (result error)
(bt:with-timeout (2)
(net.aserve.client:do-http-request (format nil "" port))))
(declare (ignore result))
(when (typep error 'error)
;; CCL has socket problems after calling do-http-request within an
;; ignore-errors, when it throws an error. So we do something
;; different. But this different thing apparently doesn't work so
;; reliably on non-CCL.
(let* ((result
(let ((sock (usocket:socket-listen "" port)))
(usocket:socket-close sock))
(usocket:address-in-use-error (e) (declare (ignore e)) :in-use)
(t (e) (declare (ignore e)) :unknown))))
(unless (or (member result '(:in-use :unknown))
(format nil "" port)))) port)))
(defun start-aserve (&key (port *aserve-port*) (listeners *aserve-listeners*)
;; FLAG -- figure out correct external-format for the other Lisps.
(external-format #+allegro :utf8-base #-allegro :utf8) aserve-start-args)
(let ((wait-time 1))
(block :outer
(do () (nil)
(let ((port port))
(block :inner
(do ((port-free? (client-test port) (client-test port)))
(format t (if (> wait-time 1) "~&Retrying aserve on ~a...~%"
"~&Trying to start aserve on ~a...~%") port)
(if (ignore-errors
(apply #'net.aserve:start
:port port :listeners listeners
:external-format external-format
(return-from :outer port)
(progn (sleep (random wait-time)) (return-from :inner))))
(incf port))))
(incf wait-time 0.1)))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment