Suffix Handling.

Brendan Burns <[email protected]> Fri, 17 May 2002 12:18:31 -0400 (EDT)
Newsgroups gmane.lisp.open-source.franz
Message-ID <[email protected]>
Hey folks,
I added suffix handling to aserve:  The following forms are added to
publish.cl:
(defclass locator-suffix (locator)
  ;; used to map suffixes to entites
  ()
  (:default-initargs :info (make-hash-table :test #'equal))
  )

(defmethod standard-locator ((req http-request)
			     (locator locator-suffix))
  ;; standard function for finding an entity in a suffix locator
  ;; return the entity if one is found, else return nil

  (if* (uri-scheme (request-raw-uri req))
     then ; ignore proxy requests
	  (return-from standard-locator nil))

  (let* ((file (car (last (net.uri:uri-parsed-path (request-uri req)))))
	 (ix (last-index-of file ".")))
    (if (= ix -1) nil
      (let ((ents (gethash (subseq file ix)
			   (locator-info locator))))
	(cdr
	 (or (assoc (request-vhost req) ents :test #'eq)
	     (assoc :wild ents :test #'eq)))))))


(defun index-of (seq subseq &key (index 0))
  (let ((first (elt subseq 0)))
    (loop for ix from index to (1- (length seq))
	when (eql (elt seq ix) first)
	do (if (equal subseq (subseq seq ix (+ ix (length subseq))))
	       (return-from index-of ix)))
    -1))

(defun last-index-of (seq subseq &key (index -1))
  (let ((first (elt subseq 0)))
    (loop for ix from (if (= index -1) (1- (length seq)) index) downto 0
	when (eql (elt seq ix) first)
	do (if (equal subseq (subseq seq ix (+ ix (length subseq))))
	       (return-from last-index-of ix)))
    -1))

(defun publish-suffix (&key (host nil host-p) port suffix
			    function class format
			    content-type
			    (server *wserver*)
			    locator
			    remove
			    authorizer
			    timeout
			    plist
			    )
  ;; publish a handler for all urls with a certain prefix
  ;;
  (let (hval)
    (if* (null locator)
       then (setq locator (find-locator :suffix server)))

    (setq hval (convert-to-vhosts (if* (and host (atom host))
				     then (list host)
				     else host)
				  server))

    (if* remove
       then				; eliminate the entity if it
exists
	    (publish-suffix-entity nil locator suffix hval)
	    nil
       else

	    (let ((ent (make-instance (or class 'computed-entity)
			 :host hval
			 :port port
			 :prefix prefix
			 :function function
			 :format format
			 :content-type content-type
			 :authorizer authorizer
			 :plist plist
			 :timeout timeout)))
	      (publish-suffix-entity ent locator suffix hval)
	      ent))))



(defmethod publish-suffix-entity ((ent entity)
				  (locator locator-suffix)
				  suffix
				  hosts)
  ;; handle  putting an entity in hash
  ;; table of a locator-exact.
  ;;
  ;; assert: hosts is a non-null list of vhosts
  ;;
  (let ((ents (gethash suffix (locator-info locator))))
    ;; must replace entry with matching host parameter
    (dolist (host hosts)
      (let ((xent (assoc host ents :test #'eq)))
	(if* (null xent)
	   then ; add new one
		(push (cons host ent) ents)
	   else ; replace
		(setf (cdr xent) ent))))
    (setf (gethash suffix (locator-info locator)) ents)
    ent))

Also the definition of the server has to be changed a little:
(defclass wserver
...
 (locators
    ;; list of locators objects in search order
    :initform (list (make-instance 'locator-exact
		      :name :exact)
		    (make-instance 'locator-prefix
		      :name :prefix)
		    (make-instance 'locator-suffix
		      :name :suffix))
...)

An example of how this is used would be:
(publish-suffix :suffix ".lsp"
		:function (lambda (req ent)
			    (with-http-response (req ent)
			      (with-http-body (req ent)
				(html (:html
				  (:body "Coming Soon")))))))

Thanks,
Brendan Burns