*new predicate ABSOLUTE-URL?

*remove URI-HAS-PROTOCOL?
This commit is contained in:
vibr 2005-04-14 11:32:38 +00:00
parent f605367c1a
commit 96b485294f
2 changed files with 6 additions and 5 deletions

View File

@ -263,7 +263,7 @@
(request-method req)) (request-method req))
(if loc (if loc
(if (uri-has-protocol? (string-trim loc)) (if (absolute-url? (url-string->http-url (string-trim loc)))
(make-error-response (status-code moved-perm) req loc) (make-error-response (status-code moved-perm) req loc)
(make-redirect-response (string-trim loc))) (make-redirect-response (string-trim loc)))
;; Send the response header back to the client ;; Send the response header back to the client
@ -286,9 +286,6 @@
(make-writer-body (lambda (out options) (make-writer-body (lambda (out options)
(copy-inport->outport script-port out))))) (copy-inport->outport script-port out)))))
(define (uri-has-protocol? loc)
(if (http-url-host (url-string->http-url loc)) #t #f))
(define (extract-status-code-and-text status req) (define (extract-status-code-and-text status req)
(with-fatal-error-handler* (with-fatal-error-handler*
(lambda (c d) (lambda (c d)

View File

@ -1,6 +1,7 @@
;;; HTTP 1.1 Request-URI parsing and unparsing -*- Scheme -*- ;;; HTTP 1.1 Request-URI parsing and unparsing -*- Scheme -*-
;;; Copyright (c) 2005 by Viola Brunner. ;;; This file is part of the Scheme Untergrund Networking package.
;;; For copyright information, see the file COPYING which comes with ;;; For copyright information, see the file COPYING which comes with
;;; the distribution. ;;; the distribution.
@ -252,6 +253,9 @@
(path http-url-path) (path http-url-path)
(query http-url-query)) (query http-url-query))
;;; Is http-url of the form http_URL, i.e. absolute?
(define (absolute-url? http-url)
(http-url-host http-url))
;;; parse a HTTP 1.1. Request_URI into a http-url record ;;; parse a HTTP 1.1. Request_URI into a http-url record