r5483: *** empty log message ***

diff --git a/package.lisp b/package.lisp
index 557c4459ce58957d707f70250a5ea320556b126a..c13e9a1eb616a2f24ec125980c471fb1f7e59aba 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.3 2003/07/19 20:32:48 kevin Exp $
+;;;; $Id: package.lisp,v 1.4 2003/08/10 05:16:52 kevin Exp $
 ;;;;
 ;;;; This file and wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -33,6 +33,7 @@
    
    ;; projects.lisp
    #:wol-project
+   #:stop-wol-project
    #:header-slot-value
    #:request-query
    #:request-query-value

diff --git a/project.lisp b/project.lisp
index d5213f95c295debfdab0c64d9fc1fae7365cae63..119c929e00b93096c9462e584bc9c841b29dee7f 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.10 2003/08/09 22:18:32 kevin Exp $
+;;;; $Id: project.lisp,v 1.11 2003/08/10 05:16:52 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -65,7 +65,10 @@
     (setq *reap-interval* reap-interval)
     (when (and sessions (null *reaper-process*))
       (setq *reaper-process* (start-reaper)))))
-    
+
+(defun stop-wol-project (name)
+  (remhash name *active-projects*))
+
 (defun wol-ml-processor (command)
   "Processes an incoming modlisp command"
   (let* ((req (command->request command
@@ -79,8 +82,9 @@
 (defun wol-aserve-processor (as-req as-ent)
   "Processes an incoming modlisp command"
   (multiple-value-bind (req ent) (make-request/ent-from-aserve as-req as-ent)
-    (dispatch-request req ent)))
-
+    (if (entity-project ent)
+       (dispatch-request req ent)
+      (no-url-handler req ent))))
 
     
 (defun make-request/ent-from-aserve (as-req as-ent)
@@ -105,8 +109,8 @@
               :headers (net.aserve::request-headers as-req)
               :aserve-server net.aserve:*wserver*
               :aserve-request as-req))
-        (ent (make-instance 'entity
-                            :project (find-project-for-request req)
+        (project (find-project-for-request req))
+        (ent (make-instance 'entity :project project
                             :aserve-entity as-ent)))
     (values req ent)))
 
@@ -203,7 +207,13 @@
 (defun find-project-for-request (req)
   (maphash (lambda (name project)
             (declare (ignore name))
-            (when (request-matches-prefix req (project-prefix project))
+            (setq cl-user::p project)
+            (setq cl-user::r req)
+            (when (and (eq (project-server project)
+                           (or (request-aserve-server req)
+                               (request-ml-server req)))
+                       (request-matches-prefix
+                        req (project-prefix project)))
               (return-from find-project-for-request project)))
           *active-projects*))
 
@@ -292,29 +302,41 @@
 
 
 (defmacro with-wol-page ((req ent
-                         &key (format :html) (precompute t) headers)
+                         &key (format :html) (precompute t) headers
+                              (response-code 200))
                         &body body)
-  `(ecase (project-connector (entity-project ,ent))
-     (:aserve
+  `(if (request-aserve-server ,req)
       (net.aserve:with-http-response 
          ((aserve-request ,req) 
           (entity-aserve-entity ,ent)
-          :content-type (ml::format-string ,format))
+          :content-type (ml::format-string ,format)
+          :response
+          (case ,response-code
+            (302 net.aserve::*response-moved-permanently*)
+            (307 net.aserve::*response-temporary-redirect*)
+            (404 net.aserve::*response-not-found*)
+            (otherwise net.aserve::*response-ok*)))
        (set-cookie ,req ,ent)
-       (net.aserve:with-http-body 
-           ((aserve-request ,req) 
-            (entity-aserve-entity ,ent)
-            :headers ,headers)
-         (let ((*html-stream* net.html.generator:*html-stream*))
-           ,@body))))
-     (:modlisp
-      (%with-wol-page (,req ,ent :format ,format :precompute ,precompute
-                           :headers ,headers)
-                     ,@body))))
+         (net.aserve:with-http-body 
+             ((aserve-request ,req) 
+              (entity-aserve-entity ,ent)
+              :headers ,headers)
+           (let ((*html-stream* net.html.generator:*html-stream*))
+             ,@body)))
+     (%with-wol-page (,req ,ent :format ,format :precompute ,precompute
+                          :headers ,headers 
+                          :response-string 
+                          (case ,response-code
+                            (302 "302 Moved Permanently")
+                            (307 "307 Temporary Redirect")
+                            (404 "404 Not Found")
+                             (otherwise "200 OK")))
+                    ,@body)))
   
 
 (defmacro %with-wol-page ((req ent
-                             &key (format :html) (precompute t) headers)
+                          &key (format :html) (precompute t) headers
+                               (response-string "200 OK"))
                         &body body)
   (declare (ignore req ent))
   (let ((fmt (gensym "FMT-"))
@@ -327,7 +349,7 @@
           (,precomp ,precompute)
           ,result ,outstr ,stream)
        (declare (ignorable ,stream))
-       (write-header-line "Status" "200 OK")
+       (write-header-line "Status" ,response-string)
        (write-header-line "Content-Type" (ml::format-string ,fmt))
        (dolist (,hdr ,headers)
         (write-header-line (car ,hdr) (cdr ,hdr)))
@@ -361,7 +383,7 @@
 
 
 (defun no-url-handler (req ent)
-  (with-wol-page (req ent)
+  (with-wol-page (req ent :response-code 404)
     (html
      (:html
       (:head

diff --git a/tests.lisp b/tests.lisp
index 0ab814f6a579b350d61bdcc046bc47619ae72ddb..6fceef89e377decc1cae2ffa4e7ef80e279819be 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -1,48 +1,314 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol-tests -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Id:      $Id: tests.lisp,v 1.1 2003/08/09 21:42:24 kevin Exp $
+;;;; Id:      $Id: tests.lisp,v 1.2 2003/08/10 05:16:52 kevin Exp $
 ;;;; Purpose: Self Test suite for WOL
 ;;;;
 ;;;; *************************************************************************
 
 (in-package #:cl-user)
+
 (defpackage #:wol-tests
-  (:use #:xlunit #:cl #:wol #:puri)
-  (:export #:do-tests))
+  (:use #:xlunit #:cl #:wol #:puri #:lml2 #:kmrcl)
+  (:export #:do-tests #:*all-tests*))
+  
 (in-package #:wol-tests)
 
-(import '(wol::req-recode-uri-sans-session-id wol::request-uri
-         wol::request-decoded-uri-path))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (import '(wol::req-recode-uri-sans-session-id wol::request-uri
+           wol::request-decoded-uri-path wol::websession-from-req
+           wol::websession-key wol::+length-session-id+
+           wol::set-cookies-in-headers)))
+
 
-;; Helper test fixture
+;; Keyed URL Tests
 
-(defclass test-url (test-case)
+(defclass test-keyed-url (test-case)
   ((req :accessor req)))
 
-(defmethod set-up ((self test-url))
+(defmethod set-up ((self test-keyed-url))
   (let ((uri (parse-uri "/~abcdefg~/index.html")))
     (setf (req self) (make-instance 'wol::http-request
                       :raw-uri uri
+                      :decoded-uri-path (render-uri uri nil)
                       :uri uri))))
 
-(def-test-method test-returned-session ((self test-url) :run nil)
+(def-test-method test-returned-session ((self test-keyed-url) :run nil)
   (assert-equal "abcdefg" (req-recode-uri-sans-session-id (req self))))
  
-(def-test-method test-recomputed-uri ((self test-url) :run nil)
+(def-test-method test-recomputed-uri ((self test-keyed-url) :run nil)
   (req-recode-uri-sans-session-id (req self))
   (assert-equal (render-uri (request-uri (req self)) nil)
                "/index.html"))
 
-(def-test-method test-decoded-uri ((self test-url) :run nil)
+(def-test-method test-decoded-uri ((self test-keyed-url) :run nil)
   (req-recode-uri-sans-session-id (req self))
   (assert-equal (request-decoded-uri-path (req self))
                "/index.html"))
 
+;;; Non-keyed URL tests
+
+(defclass test-non-keyed-url (test-case)
+  ((req :accessor req)))
+
+(defmethod set-up ((self test-non-keyed-url))
+  (let ((uri (parse-uri "/index.html")))
+    (setf (req self) (make-instance 'wol::http-request
+                      :raw-uri uri
+                      :decoded-uri-path (render-uri uri nil)
+                      :uri uri))))
+
+(def-test-method test-returned-session ((self test-non-keyed-url) :run nil)
+  (assert-false (req-recode-uri-sans-session-id (req self))))
+ 
+(def-test-method test-recomputed-uri ((self test-non-keyed-url) :run nil)
+  (req-recode-uri-sans-session-id (req self))
+  (assert-equal (render-uri (request-uri (req self)) nil)
+               "/index.html"))
+
+(def-test-method test-decoded-uri ((self test-non-keyed-url) :run nil)
+  (req-recode-uri-sans-session-id (req self))
+  (assert-equal (request-decoded-uri-path (req self))
+               "/index.html"))
+
+;;; Test server
+
+(defclass test-server (test-case)
+  ((wserver :accessor wserver)
+   (name :accessor name :initform "testproj")
+   (port :accessor port :initform 31322)
+   ))
+
+(defmethod set-up ((self test-server))
+  (setf (wserver self) (net.aserve:start :port (port self) :server :new)) 
+  (setq net.aserve::*enable-logging* nil)
+  (wol-project (name self) :index "index" :connector :aserve
+              :server (wserver self)))
+  
+
+(defmethod tear-down ((self test-server))
+  (net.aserve:shutdown :server (wserver self))
+  (stop-wol-project (name self)))
+
+(def-test-method test-server-index ((self test-server) :run nil)
+  (multiple-value-bind (body response-code headers uri)
+      (net.aserve.client:do-http-request 
+         (render-uri (copy-uri (parse-uri "http://localhost/") 
+                               :port (port self)) nil) 
+       :redirect nil)
+    (declare (ignore uri))
+    (assert-true (zerop (length body)))
+    (let ((redir (parse-uri
+                 (cdr (assoc "Location" headers :test #'string-equal)))))
+      (assert-equal (uri-path redir) "/index.html"))
+    (assert-equal response-code 307)
+    ))
+
+(def-test-method test-prefix-index-1 ((self test-server) :run nil)
+  (wol-project (name self) :index "index" :connector :aserve
+              :project-prefix "/aprefix/" :server (wserver self))
+
+  (multiple-value-bind (body response-code headers uri)
+      (net.aserve.client:do-http-request 
+         (render-uri (copy-uri (parse-uri "http://localhost/aprefix/") 
+                               :port (port self)) nil) 
+       :redirect nil)
+    (declare (ignore uri))
+    (assert-equal "" body)
+    (let ((redir (parse-uri
+                 (cdr (assoc "Location" headers :test #'string-equal)))))
+      (assert-equal (uri-path redir) "/aprefix/index.html"))
+    (assert-equal response-code 307)))
+
+
+(def-test-method test-prefix-index-2 ((self test-server) :run nil)
+  (wol-project (name self) :index "index" :connector :aserve
+              :project-prefix "/aprefix/" :server (wserver self))
+
+    (multiple-value-bind (body response-code headers uri)
+      (net.aserve.client:do-http-request 
+         (render-uri (copy-uri (parse-uri "http://localhost/ab") 
+                               :port (port self)) nil) 
+       :redirect nil)
+    (declare (ignore uri headers))
+    (assert-equal response-code 404)
+    (assert-true (plusp (length body))))
+    
+    (multiple-value-bind (body response-code headers uri)
+      (net.aserve.client:do-http-request 
+         (render-uri (copy-uri (parse-uri "http://localhost/") 
+                               :port (port self)) nil) 
+       :redirect nil)
+    (declare (ignore uri headers))
+    (assert-true (plusp (length body)))
+    (assert-equal response-code 404))
+  
+)
+
+
+;;; Test two projects
+
+(defclass test-two-projects (test-case)
+  ((wserver :accessor wserver)
+   (name1 :accessor name1 :initform "testproj")
+   (prefix1 :accessor prefix1 :initform "/testprefix/")
+   (name2 :accessor name2 :initform "projtest")
+   (prefix12 :accessor prefix2 :initform "/prefixtest/")
+   (port :accessor port :initform 31323)
+   ))
+
+(defmethod set-up ((self test-two-projects))
+  (setf (wserver self) (net.aserve:start :port (port self) :server :new)) 
+  (setq net.aserve::*enable-logging* nil)
+  (wol-project (name1 self) :index "index1" :connector :aserve
+              :project-prefix (prefix1 self)
+              :server (wserver self))
+  (wol-project (name2 self) :index "index2" :connector :aserve
+              :project-prefix (prefix2 self)
+              :server (wserver self))
+  ) 
+  
+
+(defmethod tear-down ((self test-two-projects))
+  (net.aserve:shutdown :server (wserver self))
+  (stop-wol-project (name1 self))
+  (stop-wol-project (name2 self)))
+
+(def-test-method test-two-project-index ((self test-two-projects) :run nil)
+  (multiple-value-bind (body response-code headers uri)
+      (net.aserve.client:do-http-request 
+         (render-uri (copy-uri (parse-uri "http://localhost/testprefix/") 
+                               :port (port self)) nil) 
+       :redirect nil)
+    (declare (ignore uri))
+    (assert-true (zerop (length body)))
+    (let ((redir (parse-uri
+                 (cdr (assoc "Location" headers :test #'string-equal)))))
+      (assert-equal (uri-path redir) "/testprefix/index1.html"))
+    (assert-equal response-code 307))
+  (multiple-value-bind (body response-code headers uri)
+      (net.aserve.client:do-http-request 
+         (render-uri (copy-uri (parse-uri "http://localhost/prefixtest/") 
+                               :port (port self)) nil) 
+       :redirect nil)
+    (declare (ignore uri))
+    (assert-true (zerop (length body)))
+    (let ((redir (parse-uri
+                 (cdr (assoc "Location" headers :test #'string-equal)))))
+      (assert-equal (uri-path redir) "/prefixtest/index2.html"))
+    (assert-equal response-code 307)
+    ))
+
+
+;;; Test sessions
+
+(defclass test-sessions (test-case)
+  ((wserver :accessor wserver)
+   (name :accessor name :initform "sessions")
+   (prefix :accessor prefix :initform "/")
+   (port :accessor port :initform 31324)
+   ))
+
+(defmethod set-up ((self test-sessions))
+  (setf (wserver self) (net.aserve:start :port (port self) :server :new)) 
+  (setq net.aserve::*enable-logging* nil)
+  (wol-project (name self) :index "index" :connector :aserve
+              :sessions t
+              :map '(("index" test-sessions-index))
+              :project-prefix (prefix self)
+              :server (wserver self)))
+  
+
+(defmethod tear-down ((self test-sessions))
+  (net.aserve:shutdown :server (wserver self))
+  (stop-wol-project (name self)))
+
+(defun test-sessions-index (req ent)
+  (let ((session (websession-from-req req)))
+    (with-wol-page (req ent)
+      (let ((url (make-wol-url "page" req ent)))
+       (format *html-stream* "index~%")
+       (format *html-stream* "~A~%" (websession-key session))
+       (format *html-stream* "~A~%" url)
+       ))))
+
+(def-test-method test-sessions ((self test-sessions) :run nil)
+  (multiple-value-bind (body response-code headers uri)
+      (net.aserve.client:do-http-request 
+         (render-uri (copy-uri (parse-uri "http://localhost/index.html") 
+                               :port (port self)) nil)) 
+    (declare (ignore uri))
+    (assert-equal response-code 200)
+    (let ((cookies (set-cookies-in-headers headers)))
+      (assert-equal (length cookies) 1))
+    (let ((lines (delimited-string-to-list body #\newline t)))
+      (assert-equal (length lines) 3)
+      (assert-equal (first lines) "index")
+      (assert-equal (length (second lines)) +length-session-id+)
+      (assert-equal (third lines)
+                   (format nil "/~~~A~~/page.html" (second lines))))))
+
+
+;;; Test no sessions
+
+(defclass test-no-sessions (test-case)
+  ((wserver :accessor wserver)
+   (name :accessor name :initform "sessions")
+   (prefix :accessor prefix :initform "/")
+   (port :accessor port :initform 31325)
+   ))
+
+(defmethod set-up ((self test-no-sessions))
+  (setf (wserver self) (net.aserve:start :port (port self) :server :new)) 
+  (setq net.aserve::*enable-logging* nil)
+  (wol-project (name self) :index "index" :connector :aserve
+              :sessions nil
+              :map '(("index" test-no-sessions-index))
+              :project-prefix (prefix self)
+              :server (wserver self)))
+
+(defun test-no-sessions-index (req ent)
+  (let ((session (websession-from-req req)))
+    (with-wol-page (req ent)
+      (let ((url (make-wol-url "page" req ent)))
+       (format *html-stream* "index~%")
+       (format *html-stream* "~(~A~)~%" session)
+       (format *html-stream* "~A~%" url)
+       ))))
+
+(defmethod tear-down ((self test-no-sessions))
+  (net.aserve:shutdown :server (wserver self))
+  (stop-wol-project (name self)))
+
+(def-test-method test-no-sessions ((self test-no-sessions) :run nil)
+  (multiple-value-bind (body response-code headers uri)
+      (net.aserve.client:do-http-request 
+         (render-uri (copy-uri (parse-uri "http://localhost/index.html") 
+                               :port (port self)) nil)) 
+    (declare (ignore uri))
+    (assert-equal response-code 200)
+    (let ((cookies (set-cookies-in-headers headers)))
+      (assert-equal (length cookies) 0))
+    (let ((lines (delimited-string-to-list body #\newline t)))
+      (assert-equal (length lines) 3)
+      (assert-equal (first lines) "index")
+      (assert-equal (second lines) "nil")
+      (assert-equal (third lines) "/page.html"))))
+
+
+;;; All tests
+
+(defclass all-tests (test-suite) ())
+(defparameter *all-tests* (make-instance 'all-tests))
 
-(textui-test-run (get-suite test-url))
+(add-test *all-tests* (get-suite test-keyed-url))
+(add-test *all-tests* (get-suite test-non-keyed-url))
+(add-test *all-tests* (get-suite test-server))
+(add-test *all-tests* (get-suite test-two-projects))
+(add-test *all-tests* (get-suite test-sessions))
+(add-test *all-tests* (get-suite test-no-sessions))
 
 (defun do-tests ()
-  (or (was-successful (run (get-suite test-url)))
+  (or (was-successful (textui-test-run *all-tests*))
       (error "Failed tests")))

diff --git a/uri.lisp b/uri.lisp
index 7c38f304226c95c1c43d190cb8aadb25143fff39..1f2e22467d476acc74bef7a907befbeb8a4e6ced 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.7 2003/08/09 21:42:24 kevin Exp $
+;;;; $Id: uri.lisp,v 1.8 2003/08/10 05:16:52 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -15,7 +15,6 @@
 (in-package #:wol)
 
 (defun req-recode-uri-sans-session-id (req)
-  (setq cl-user::r req)
   (let ((ppath (puri:uri-parsed-path (request-uri req))))
     (when (is-raw-session-id (second ppath))
       (let ((new-path (list* (car ppath) (cddr ppath))))
@@ -32,7 +31,19 @@
           when (eq :cookie (car h))
           collect (cdr h))))
 
+(defun header-lines-matching (key headers)
+  (loop for hdr in headers
+      when (eq key (car hdr))
+      collect (cdr hdr)))
+
+(defun set-cookies-in-headers (headers)
+  (header-lines-matching :set-cookie headers))
+
+(defun cookies-in-headers (headers)
+  (header-lines-matching :cookie headers))
+
 (defun cookie-session-key (ent cookies)
+  "Return the session key from the alist of cookies"
   (let ((name (project-name (entity-project ent))))
     (cdr (assoc name cookies :test #'string-equal))))
 

diff --git a/wol.asd b/wol.asd
index 65eeb7022a134416cc8737cbbd68b083914a2db8..e4ab74854e5f51bdc567050f731db9cc5b9be72e 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.6 2003/08/09 21:42:24 kevin Exp $
+;;;; $Id: wol.asd,v 1.7 2003/08/10 05:16:52 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -43,7 +43,7 @@
 
 (defmethod perform ((o test-op) (c (eql (find-system 'wol))))
   (operate 'load-op 'wol-tests)
-  (operate 'test-op 'wol-tests))
+  (operate 'test-op 'wol-tests :force t))
 
 (defsystem wol-tests
     :depends-on (wol xlunit)