r5326: *** empty log message ***

diff --git a/classes.lisp b/classes.lisp
index 70f01b33592981b0c4719ce95d0c52dd01f31404..17f12eb267e46ef9ee9ba652276cbf13bd0ace02 100644 (file)
--- 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 (file)
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))"   ")))))
+    (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 78a1e1d2af7c8a2c4405863694e78c748c59ddaa..7b96f97bb1321f6b80c8778c5a149a3bb08e35d7 100644 (file)
--- 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 cc26b2783ff09dfe1348b8db4ac8873b926fcddb..0280a27e9ff88252f33f497ac02059dca0ea49ab 100644 (file)
--- 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 371f04563e78e8ce5a9f968eaea7818104dd4315..afbeb75e26109991780e17fe491b8e38913543d0 100644 (file)
--- 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 664a8fbaf1ff06239f4d4d0c751d940cab55ccb4..7adb3ef9ec3d60bac560e56c1cc7d40538383d1a 100644 (file)
--- 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"))