Commit 9dd7819f authored by Dave Cooper's avatar Dave Cooper
Browse files

added patche for publish-shared.

parent e2a31089
Loading
Loading
Loading
Loading
Loading
+44 −2
Original line number Diff line number Diff line
@@ -31,6 +31,48 @@

(export 'wmd)

(defun publish-shared (&key path object-type object host (server *wserver*)
                       (key (make-keyword-sensitive (format nil "~a_~a" host path))))
    "Void. Used to publish a site which is to have a shared toplevel instance tree,  
and no URI rewriting (i.e. no \"/sessions/XXX/\" at the beginning of the path). So,
this site will appear to be a normal non-dynamic site even though the pages are
being generated dynamically. 

:&key ((path nil) \"String. The URI path to be published.\"
       (object-type nil) \"Symbol. The type of the toplevel object to be instantiated.\"
       (host nil) \"hostname for the URI to be published.\"
       (server *wserver*) \"Allegroserve server object. If you have additional servers other than the default
<tt>*wserver*</tt> (e.g. an SSL server) you may want to call this function for each server.\")

:example <pre>
  (publish-shared :path \"/\"
                  :object-type 'site:assembly
                  :host (list \"www.genworks.com\" \"ww2.genworks.com\" \"mccarthy.genworks.com\"))
  </pre>"

  (let ((object (or object (make-object (if (stringp object-type)
					    (read-safe-string object-type)
					    object-type)
					:instance-id key
					:plain-url? t
					:host host))))
    (setf (gethash key *instance-hash-table*) (list object))
    
    (publish :path path
             :server server
             :host host
	     :content-type "text/html"
             :function #'(lambda(req ent)
                         (let ((*req* req) (*ent* ent)
                               (object (first (gethash key *instance-hash-table*))))
                           (with-http-response (req ent :response *response-found*)
			     (setf (reply-header-slot-value req :location) (format nil "~a" (the-object object url)))
                             (setf (reply-header-slot-value req :cache-control) "no-cache")
                             (setf (reply-header-slot-value req :pragma) "no-cache")
                             (with-http-body (req ent))
			     ))))))


(defun crawl (&key
		part
		url-path ;; to give explicit url instead of part type. 
@@ -105,7 +147,7 @@ the files are written into \"/tmp/sites/\".
              (let* ((components (let ((components (remove "" (glisp:split-regexp "/" uri-path) :test #'string-equal)))
				   (if (find "sessions" components :test #'string-equal) (rest (rest components)) components)))
                     (directory (butlast components)))
		(destructuring-bind (name type) (glisp:split-regexp "\\." (lastcar components))
		(destructuring-bind (name &optional type) (glisp:split-regexp "\\." (lastcar components))
                  (make-pathname :directory (append (pathname-directory output-root) directory) :name name :type type)))))

        (let ((lhtml (relativize-lhtml lhtml uri-path output-path host port visited-urls)))
@@ -133,7 +175,7 @@ the files are written into \"/tmp/sites/\".
				     (components (if (find "sessions" components :test #'string-equal)
						     (rest (rest components)) components)))
				(and (null uri-host) (null uri-scheme) (null uri-port)
				     (destructuring-bind (name type) (glisp:split-regexp "\\." (lastcar components))
				     (destructuring-bind (name &optional type) (glisp:split-regexp "\\." (lastcar components))
				       (declare (ignore name))
				       (member type '("htm" "html") :test #'string-equal)))))