r5381: *** empty log message ***

[wol.git] / project.lisp

diff --git a/project.lisp b/project.lisp
index 0280a27e9ff88252f33f497ac02059dca0ea49ab..ad94d48f2aa99087ff062300aa2130098eb1f4cd 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.3 2003/07/18 21:34:18 kevin Exp $
+;;;; $Id: project.lisp,v 1.5 2003/07/23 23:08:28 kevin Exp $
 ;;;;
 ;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -87,12 +87,12 @@
   (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)
+                :raw-uri (puri:intern-uri
+                          (net.uri:render-uri
+                           (net.aserve:request-raw-uri as-req) nil))
+                :uri (puri:intern-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)
@@ -112,13 +112,10 @@
   (let ((req
         (make-instance 'http-request
           :host (header-value command :host)
-          :raw-uri (header-value command :url)
-          :uri (create-uri (header-value command :host)
-                           (awhen (header-value
-                                 command :server-ip-port)
-                                (parse-integer it))
-                           (header-value command :url))
-          :protocol (ensure-keyword (header-value command :server-protocol))
+          :raw-uri (puri:intern-uri (header-value command :url))
+          :uri (puri:intern-uri (command->uri command))
+          :protocol (ensure-keyword
+                     (header-value command :server-protocol))
           :protocol-string (header-value command :server-protocol)
           :method (ensure-keyword (header-value command :method))
           :posted-content (header-value command :posted-content)
@@ -130,16 +127,20 @@
 (defun header-slot-value (req slot)
   (header-value (request-headers req) slot))
 
-(defun create-uri (host port page)
-  (format nil "http://~A:~D~A" host port page))
+(defun command->uri (command)
+  (format nil "http://~A:~D~A"
+         (header-value command :host)
+         (awhen (header-value
+                 command :server-ip-port)
+                (parse-integer it))
+         (header-value command :url)))
 
 (defun is-index-request (req ent)
-  (string= (request-raw-uri req) 
+  (string= (puri:uri-path (request-raw-uri req)) 
           (project-prefix (entity-project ent))))
 
-(defun redirect-entity (page ent)
-  (redirect-to-location 
-   (format nil "~A~A" (project-prefix (entity-project ent)) page)))
+(defun redirect-entity (page ent &optional plist)
+  (redirect-to-location (apply #'make-wol-url page ent plist)))
 
 (defun dispatch-request (req ent)
   (let ((proj (entity-project ent)))
@@ -166,7 +167,7 @@
 
 (defun request-matches-prefix (req prefix)
   "Returns project if request matches project"
-  (string-starts-with prefix (request-raw-uri req)))
+  (string-starts-with prefix (puri:uri-path (request-raw-uri req))))
 
 
 (defun dispatch-to-handler (req ent)
@@ -193,6 +194,8 @@
        (typecase next-page
         (string
          (redirect-entity next-page ent))
+        (cons
+         (redirect-entity (car next-page) ent (cadr next-page)))
         (null
          t)
         (t