diff --git a/scheme/httpd/cgi-server.scm b/scheme/httpd/cgi-server.scm index 825b68c..42e13c1 100644 --- a/scheme/httpd/cgi-server.scm +++ b/scheme/httpd/cgi-server.scm @@ -263,7 +263,7 @@ (request-method req)) (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-redirect-response (string-trim loc))) ;; Send the response header back to the client @@ -286,9 +286,6 @@ (make-writer-body (lambda (out options) (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) (with-fatal-error-handler* (lambda (c d) diff --git a/scheme/lib/url.scm b/scheme/lib/url.scm index 0bd870a..16880bc 100644 --- a/scheme/lib/url.scm +++ b/scheme/lib/url.scm @@ -1,6 +1,7 @@ ;;; 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 ;;; the distribution. @@ -252,6 +253,9 @@ (path http-url-path) (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