;;;; 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
;;;; *************************************************************************
(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)
(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)
(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)))
(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)
(typecase next-page
(string
(redirect-entity next-page ent))
+ (cons
+ (redirect-entity (car next-page) ent (cadr next-page)))
(null
t)
(t