From d91ff3b4d9cdcae003420c04609ea736161c7e65 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Fri, 18 Jul 2003 21:34:18 +0000
Subject: [PATCH] r5326: *** empty log message ***

---
 classes.lisp      |  21 +++--
 color-picker.lisp |  46 +++++++++++
 package.lisp      |   4 +-
 project.lisp      | 193 +++++++++++++++++++++++++++++++++++-----------
 uri.lisp          |   6 +-
 wol.asd           |   8 +-
 6 files changed, 219 insertions(+), 59 deletions(-)
 create mode 100644 color-picker.lisp

diff --git a/classes.lisp b/classes.lisp
index 70f01b3..17f12eb 100644
--- a/classes.lisp
+++ b/classes.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: classes.lisp,v 1.2 2003/07/16 16:40:35 kevin Exp $
+;;;; $Id: classes.lisp,v 1.3 2003/07/18 21:34:18 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -43,11 +43,14 @@
 	  :accessor project-index)
    (server :initarg :server :initform nil :accessor project-server)
    (session-master :initform (make-instance 'session-master)
-		   :accessor session-master)))
+		   :accessor session-master)
+   (connector :initarg :connector :accessor project-connector)))
 
 (defclass entity ()
-  ((project :initarg :project :accessor entity-project))
-  )
+  ((project :initarg :project :accessor entity-project)
+   (aserve-entity :initarg :aserve-entity :initform nil
+		  :accessor entity-aserve-entity)))
+
 
 (defclass http-request ()
   ((method  :initarg :method :accessor request-method)
@@ -57,10 +60,11 @@
    (protocol-string :initarg :protocol-string :reader request-protocol-string)
    (socket :initarg :socket :reader request-socket)
    (ml-server :initarg :ml-server :reader request-ml-server)
+   (aserve-server :initarg :aserve-server :reader request-aserve-server)
+   (host :initarg :host :accessor request-host)
    (vhost :initarg :vhost :accessor request-vhost)
    (posted-content :initarg :posted-content :accessor request-posted-content)
    (headers :initarg :headers :accessor request-headers)
-   (project :initarg :project :accessor project)
    (page :initarg :page :initform nil :accessor request-page)
    (plist :initarg :plist :initform nil :accessor request-plist)
    (next-plists :initarg :next-plists :initform nil 
@@ -71,6 +75,8 @@
 		:accessor request-query-alist)
    (session :initarg :session :initform nil
 	    :accessor websession-from-req)
+   (aserve-request :initarg :aserve-request :initform nil
+		   :accessor aserve-request)
    ))
 
 (defvar *reap-interval* 300)
@@ -84,4 +90,7 @@
 (defvar +plist-header+ "/sdata"
   "string that starts an encoded plist")
 
-(defvar *wol-version* "0.1.0")
+(defparameter *wol-version* '(0 1 0))
+
+(defvar *wol-stream* nil
+  "The output stream for the current request")
diff --git a/color-picker.lisp b/color-picker.lisp
new file mode 100644
index 0000000..2122e9e
--- /dev/null
+++ b/color-picker.lisp
@@ -0,0 +1,46 @@
+(defun luminance (r g b)
+  (+ (* r 0.299) (* g 0.587) (* b 0.114)))
+
+(defun std-pick-color-html-fn ()
+  (flet ((color-td (r g b)
+           (let ((color (format nil "#~2,'0x~2,'0x~2,'0x" r g b)))
+             (html ((:td :bgcolor color
+			 :fformat (:onclick "f42('~a');"
+					    color))"&nbsp;&nbsp;&nbsp;")))))
+    (let* ((colors nil))
+      (dotimes (r 6)
+        (dotimes (g 6)
+          (dotimes (b 6)
+            (push (list (* r 51) (* g 51) (* b 51)(luminance r g b))
+		  colors))))
+      (setf colors (sort colors #'> :key 'fourth))
+      (html
+       (:head
+        (:title "Choose a color")
+        ((:link :rel "stylesheet" :type "text/css" :href "/pcol.css")))
+       (:body
+        :br
+        (:h1 "Choose a color")
+        (:jscript "function
+f42(d){window.opener.change_color(d);window.close();};")
+        ((:table :class "pcolt" :align "center")
+         (loop for x below 18
+               for row = (loop repeat 12 collect (pop colors))
+               for bl = (round (* 255 (- 1 (/ x 17))))
+               do
+               (html
+                (:tr
+                 (color-td  bl bl bl)
+                 (color-td  bl  0  0)
+                 (color-td   0 bl  0)
+                 (color-td   0  0 bl)
+                 (color-td   0 bl bl)
+                 (color-td  bl  0 bl)
+                 (color-td  bl bl  0)
+                 (loop for (r g b l) in row
+                       do (color-td r g b))))))
+        :br
+        ((:div :align "center")
+         ((:a :class "call" :href "javascript:window.close();")
+	  "Close")))))))
+
diff --git a/package.lisp b/package.lisp
index 78a1e1d..7b96f97 100644
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  April 2001
 ;;;;
-;;;; $Id: package.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $
+;;;; $Id: package.lisp,v 1.2 2003/07/18 21:34:18 kevin Exp $
 ;;;;
 ;;;; This file and wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -35,7 +35,9 @@
    #:wol-project
    #:header-slot-value
    #:request-query
+   #:request-query-value
    #:websession-variable
+   #:with-wol-page
    
    ;; sessions.lisp
 
diff --git a/project.lisp b/project.lisp
index cc26b27..0280a27 100644
--- a/project.lisp
+++ b/project.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: project.lisp,v 1.2 2003/07/16 20:40:43 kevin Exp $
+;;;; $Id: project.lisp,v 1.3 2003/07/18 21:34:18 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -15,8 +15,16 @@
 (in-package #:wol)
 
 (defun wol-project (name &key (project-prefix "/") map index
-			      (sessions t) (session-lifetime 18000)
-			      (reap-interval 300) (server *ml-server*))
+		    (sessions t) (session-lifetime 18000)
+		    (reap-interval 300) server
+		    (connector :modlisp))
+
+  (unless server
+    (setq server 
+	  (ecase connector
+	    (:modlisp ml:*ml-server*)
+	    (:aserve net.aserve:*wserver*))))
+  
   (unless server
     (warn "Can't start project without server")
     (return-from wol-project nil))
@@ -31,6 +39,7 @@
     (setf (project-map project) map)
     (setf (project-index project) index) 
     (setf (project-server project) server)
+    (setf (project-connector project) connector)
     (setf (lifetime (session-master project)) session-lifetime)
     (setf (cookie-name (session-master project)) name)
 
@@ -38,10 +47,16 @@
       (dolist (map-item map)
 	(setf (gethash (first map-item) hash) (second map-item)))
       (setf (project-hash-map project) hash))
-    
-    (setf (ml::processor server) 'wol-ml-processor)
 
-    (if sessions
+    (ecase connector
+      (:modlisp
+       (setf (ml::processor server) 'wol-ml-processor))
+      (:aserve
+       (net.aserve:publish-prefix :prefix project-prefix
+				  :server server
+				  :function 'wol-aserve-processor)))
+  
+  (if sessions
 	(when (null (sessions (session-master project)))
 	  (setf (sessions (session-master project))
 	    (make-hash-table :test 'eq)))
@@ -54,17 +69,49 @@
     
 (defun wol-ml-processor (command)
   "Processes an incoming modlisp command"
-  (let ((req (command->request command
-			       :ml-server *ml-server*)))
-    (unless (dispatch-request req)
-      (no-url-handler req))))
+  (let* ((req (command->request command
+				:ml-server *ml-server*))
+	 (ent (make-entity-for-request req)))
+    (if ent
+	(dispatch-request req ent)
+	(no-url-handler req ent))))
+
+
+(defun wol-aserve-processor (as-req as-ent)
+  "Processes an incoming modlisp command"
+  (let* ((req (make-request-from-aserve as-req))
+	 (ent (make-entity-from-aserve req as-ent)))
+    (dispatch-request req ent)))
+
+(defun make-request-from-aserve (as-req)
+  (make-instance 'http-request
+		 :method (net.aserve:request-method as-req)
+		 ;;:host (net.aserve:request-host as-req)
+		 :raw-uri (net.uri:render-uri
+			   (net.aserve:request-raw-uri as-req)
+			   nil)
+		 :uri (net.uri:render-uri
+		       (net.aserve:request-uri as-req)
+		       nil)
+		 :protocol (net.aserve:request-protocol as-req)
+		 :protocol-string
+		 (net.aserve:request-protocol-string as-req)
+		 :posted-content (net.aserve::request-request-body as-req)
+		 :socket (net.aserve:request-socket as-req)
+		 :aserve-server net.aserve:*wserver*
+		 :aserve-request as-req))
+
+(defun make-entity-from-aserve (req as-ent)
+  (make-instance 'entity
+		 :project (find-project-for-request req)
+		 :aserve-entity as-ent))
 
 
 (defun command->request (command &key ml-server)
   "Convert a cl-modlisp command into a wol request"
   (let ((req
 	 (make-instance 'http-request
-	   :vhost (header-value command :host)
+	   :host (header-value command :host)
 	   :raw-uri (header-value command :url)
 	   :uri (create-uri (header-value command :host)
 			    (awhen (header-value
@@ -93,30 +140,28 @@
 (defun redirect-entity (page ent)
   (redirect-to-location 
    (format nil "~A~A" (project-prefix (entity-project ent)) page)))
-  
-(defun dispatch-request (req)
-  (let ((ent (find-entity-for-request req)))
-    (when ent
-      (let ((proj (entity-project ent)))
-	(if (is-index-request req ent)
-	    (progn
-	      (redirect-entity (project-index proj) ent)
-	      t)
-	  (progn
-	    (request-decompile-uri req ent)
-	    (compute-session req ent)
-	    (dispatch-entity req ent))))
-      ent)))
+
+(defun dispatch-request (req ent)
+  (let ((proj (entity-project ent)))
+    (if (is-index-request req ent)
+	(redirect-entity (project-index proj) ent)
+	(progn
+	  (request-decompile-uri req ent)
+	  (compute-session req ent)
+	  (dispatch-to-handler req ent)))))
 
 (defun make-entity (&key project)
   (make-instance 'entity :project project))
 
-(defun find-entity-for-request (req)
+(defun make-entity-for-request (req)
+  (awhen (find-project-for-request req)
+	 (make-entity :project it)))
+
+(defun find-project-for-request (req)
   (maphash (lambda (name project)
 	     (declare (ignore name))
 	     (when (request-matches-prefix req (project-prefix project))
-	       (return-from find-entity-for-request 
-		 (make-entity :project project))))
+	       (return-from find-project-for-request project)))
 	   *active-projects*))
 
 (defun request-matches-prefix (req prefix)
@@ -124,11 +169,12 @@
   (string-starts-with prefix (request-raw-uri req)))
 
 
-(defun dispatch-entity (req ent)
-  (let ((handler (request-find-handler req ent)))
+(defun dispatch-to-handler (req ent)
+  (let ((handler (request-find-handler req ent))
+	(*wol-stream* (request-socket req)))
     (if handler
 	(handle-request handler req ent)
-      (no-url-handler req))))
+      (no-url-handler req ent))))
 
 (defun request-find-handler (req ent)
   (nth-value 0 (gethash (request-page req) 
@@ -159,23 +205,10 @@
      (cmsg "unknown handler type: ~S" handler)
      nil)))
 
-(defun no-url-handler (req)
-  (print (request-socket req))
-  (with-ml-page ()
-    (html-stream
-     *modlisp-socket*
-     (:html
-      (:head
-       (:title "404 - NotFound"))
-      (:body
-       (:h1 "Not Found")
-       (:p "The request for "
-	   (:b (:write-string (request-uri req)))
-	   " was not found on this server.")
-       (:hr)
-       (:div (:i "WOL "
-		 (:write-string *wol-version*))))))))
 
+
+(defun wol-version-string ()
+  (format nil "~{~D~^.~}" *wol-version*))
   
 (defun request-query (req &key (uri t) (post t))
   (append
@@ -187,6 +220,10 @@
     (when (and post (request-posted-content req))
       (query-to-alist (request-posted-content req)))))
 
+(defun request-query-value (key req &key (uri t) (post t))
+  (cdr (assoc key (request-query req :uri uri :post post)
+	      :test 'equal)))
+    
 (defun websession-variable (ws name)
   (when ws
     (gethash name (websession-variables ws))))
@@ -194,3 +231,65 @@
 (defun (setf websession-variable) (value ws name)
   (when ws
     (setf (gethash name (websession-variables ws)) value)))
+
+
+(defmacro with-wol-page ((req ent
+			      &key (format :html) (precompute t) headers)
+			 &body body)
+  (let ((fmt (gensym "FMT-"))
+	(precomp (gensym "PRE-"))
+	(result (gensym "RES-"))
+	(outstr (gensym "STR-"))
+	(stream (gensym "STRM-"))
+	(hdr (gensym "HDR-")))
+    `(let ((,fmt ,format)
+	   (,precomp ,precompute)
+	   ,result ,outstr ,stream)
+       (declare (ignorable ,stream))
+       (write-header-line "Status" "200 OK")
+       (write-header-line "Content-Type" (ml::format-string ,fmt))
+       (dolist (,hdr ,headers)
+	 (write-header-line (car ,hdr) (cdr ,hdr)))
+       (unless ,precomp
+	 (write-string "end" *wol-stream*)
+	 (write-char #\NewLine *wol-stream*))
+       (setq ,outstr
+	 (with-output-to-string (,stream)
+	   (let ((*html-stream* (if ,precomp
+				   ,stream
+				   *wol-stream*))
+		 (*wol-stream* (if ,precomp
+				   ,stream
+				   *wol-stream*)))
+	     (setq ,result (progn ,@body)))))
+       (cond
+	(,precomp
+	 (write-header-line "Content-Length" 
+			    (write-to-string (length ,outstr)))
+	 (write-header-line "Keep-Socket" "1")
+	 (write-header-line "Connection" "Keep-Alive")
+	 (write-string "end" *wol-stream*)
+	 (write-char #\NewLine *wol-stream*)
+	 (write-string ,outstr *wol-stream*)
+	 (finish-output *wol-stream*)
+	 (setq *close-modlisp-socket* nil))
+	(t
+	 (finish-output *wol-stream*)
+	 (setq *close-modlisp-socket* t)))
+       ,result)))
+
+
+(defun no-url-handler (req ent)
+  (with-wol-page (req ent)
+    (html
+     (:html
+      (:head
+       (:title "404 - NotFound"))
+      (:body
+       (:h1 "Not Found")
+       (:p "The request for "
+	   (:b (:write-string (request-uri req)))
+	   " was not found on this server.")
+       (:hr)
+       (:div (:i "WOL "
+		 (:write-string (wol-version-string)))))))))
diff --git a/uri.lisp b/uri.lisp
index 371f045..afbeb75 100644
--- a/uri.lisp
+++ b/uri.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: uri.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $
+;;;; $Id: uri.lisp,v 1.2 2003/07/18 21:34:18 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -112,8 +112,8 @@
 	prefix
 	(if html
 	    (concatenate 'string page ".lsp")
-	  (concatenate 'string
-	    +asp-header+ +plist-header+ (plist-to-url-string plist)))))))
+	  +asp-header+)	  
+	(concatenate 'string +plist-header+ (plist-to-url-string plist))))))
 
 (defun parameters-null (&rest params)
   (every #'(lambda (p) (or (null p) (eq p *unspecified*))) params))
diff --git a/wol.asd b/wol.asd
index 664a8fb..7adb3ef 100644
--- a/wol.asd
+++ b/wol.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  July 2003
 ;;;;
-;;;; $Id: wol.asd,v 1.2 2003/07/16 16:40:35 kevin Exp $
+;;;; $Id: wol.asd,v 1.3 2003/07/18 21:34:18 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -15,6 +15,7 @@
 (in-package #:cl-user)
 
 #+(or cmu lispworks (and allegro (not common-lisp-controller))) (require :aserve)
+#+(and allegro common-lisp-controller) (c-l-c::original-require :aserve)
 #+allegro (require :smtp)
 #+allegro (require :phtml)
 #+allegro (require :pxml)
@@ -30,7 +31,10 @@
     :components
     ((:file "package")
      (:file "classes" :depends-on ("package"))
-     (:file "project" :depends-on ("classes"))
+     ;;(:file "c-modlisp" :depends-on ("classes"))
+     ;;(:file "c-aserve" :depends-on ("classes"))
+     (:file "project" :depends-on ("classes")
+	    #+ignore ("c-modlisp" "c-aserve"))
      (:file "sessions" :depends-on ("classes"))
      (:file "uri" :depends-on ("classes"))
      (:file "log" :depends-on ("classes"))
-- 
2.34.1