- renamed USERHOST:xxx to USERHOST-xxx
- renamed HTTP-URL:xxx to HTTP-URL-xxx
This commit is contained in:
parent
68b1f0c386
commit
4e859bc92a
|
@ -103,7 +103,7 @@
|
||||||
(nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ?
|
(nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ?
|
||||||
; why did we had (string-suffix? "-nph" prog) here?
|
; why did we had (string-suffix? "-nph" prog) here?
|
||||||
|
|
||||||
(search (http-url:search (request-url req))) ; Compute the
|
(search (http-url-search (request-url req))) ; Compute the
|
||||||
(argv (if (and search (not (string-index search #\=))) ; argv list.
|
(argv (if (and search (not (string-index search #\=))) ; argv list.
|
||||||
(split-and-decode-search-spec search)
|
(split-and-decode-search-spec search)
|
||||||
'()))
|
'()))
|
||||||
|
@ -181,7 +181,7 @@
|
||||||
(path-translated (path-list->file-name path-info bin-dir))
|
(path-translated (path-list->file-name path-info bin-dir))
|
||||||
|
|
||||||
;; Compute the $SCRIPT_PATH string.
|
;; Compute the $SCRIPT_PATH string.
|
||||||
(url-path (http-url:path (request-url req)))
|
(url-path (http-url-path (request-url req)))
|
||||||
(script-path (take (- (length url-path) (length path-suffix))
|
(script-path (take (- (length url-path) (length path-suffix))
|
||||||
url-path))
|
url-path))
|
||||||
(script-name (uri-path-list->path script-path)))
|
(script-name (uri-path-list->path script-path)))
|
||||||
|
@ -208,7 +208,7 @@
|
||||||
|
|
||||||
,@request-invariant-cgi-env ; Stuff that never changes (see cgi-handler).
|
,@request-invariant-cgi-env ; Stuff that never changes (see cgi-handler).
|
||||||
|
|
||||||
,@(cond ((http-url:search (request-url req)) =>
|
,@(cond ((http-url-search (request-url req)) =>
|
||||||
(lambda (srch) `(("QUERY_STRING" . ,srch))))
|
(lambda (srch) `(("QUERY_STRING" . ,srch))))
|
||||||
(else '()))
|
(else '()))
|
||||||
|
|
||||||
|
|
|
@ -169,7 +169,7 @@
|
||||||
(let ((initial-req (parse-http-request sock options)))
|
(let ((initial-req (parse-http-request sock options)))
|
||||||
(let redirect-loop ((req initial-req))
|
(let redirect-loop ((req initial-req))
|
||||||
(let ((response ((httpd-options-request-handler options)
|
(let ((response ((httpd-options-request-handler options)
|
||||||
(http-url:path (request-url req))
|
(http-url-path (request-url req))
|
||||||
req)))
|
req)))
|
||||||
(if (eq? (response-code response)
|
(if (eq? (response-code response)
|
||||||
http-status/redirect)
|
http-status/redirect)
|
||||||
|
|
|
@ -112,7 +112,7 @@
|
||||||
;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
|
;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
|
||||||
|
|
||||||
(define (make-rooted-file-path-response root file-path file-serve-response req)
|
(define (make-rooted-file-path-response root file-path file-serve-response req)
|
||||||
(if (http-url:search (request-url req))
|
(if (http-url-search (request-url req))
|
||||||
(make-http-error-response http-status/bad-request req
|
(make-http-error-response http-status/bad-request req
|
||||||
"Indexed search not provided for this URL.")
|
"Indexed search not provided for this URL.")
|
||||||
(cond ((dotdot-check root file-path) =>
|
(cond ((dotdot-check root file-path) =>
|
||||||
|
|
|
@ -117,12 +117,12 @@
|
||||||
((list? parse-info) ; it's an info path
|
((list? parse-info) ; it's an info path
|
||||||
(lambda (url)
|
(lambda (url)
|
||||||
(values parse-info
|
(values parse-info
|
||||||
(unescape-uri (http-url:search url)))))
|
(unescape-uri (http-url-search url)))))
|
||||||
(else
|
(else
|
||||||
(let ((info-path ((infix-splitter ":") (getenv "INFOPATH"))))
|
(let ((info-path ((infix-splitter ":") (getenv "INFOPATH"))))
|
||||||
(lambda (url)
|
(lambda (url)
|
||||||
(values info-path
|
(values info-path
|
||||||
(unescape-uri (http-url:search url))))))))
|
(unescape-uri (http-url-search url))))))))
|
||||||
(make-reference
|
(make-reference
|
||||||
(cond
|
(cond
|
||||||
((procedure? reference) reference)
|
((procedure? reference) reference)
|
||||||
|
|
|
@ -107,7 +107,7 @@
|
||||||
(format-internet-host-address host-address))
|
(format-internet-host-address host-address))
|
||||||
(request-method req) ; request method
|
(request-method req) ; request method
|
||||||
(uri-path-list->path
|
(uri-path-list->path
|
||||||
(http-url:path (request-url req))) ; requested file
|
(http-url-path (request-url req))) ; requested file
|
||||||
(version->string (request-version req)) ; protocol version
|
(version->string (request-version req)) ; protocol version
|
||||||
status-code
|
status-code
|
||||||
23 ; filesize (unknown)
|
23 ; filesize (unknown)
|
||||||
|
|
|
@ -26,13 +26,13 @@
|
||||||
((list? finder)
|
((list? finder)
|
||||||
(lambda (url)
|
(lambda (url)
|
||||||
(values finder
|
(values finder
|
||||||
(unescape-uri (http-url:search url))
|
(unescape-uri (http-url-search url))
|
||||||
'())))
|
'())))
|
||||||
(else
|
(else
|
||||||
(let ((man-path ((infix-splitter ":") (getenv "MANPATH"))))
|
(let ((man-path ((infix-splitter ":") (getenv "MANPATH"))))
|
||||||
(lambda (url)
|
(lambda (url)
|
||||||
(values man-path
|
(values man-path
|
||||||
(unescape-uri (http-url:search url))
|
(unescape-uri (http-url-search url))
|
||||||
'()))))))
|
'()))))))
|
||||||
(reference-template
|
(reference-template
|
||||||
(cond
|
(cond
|
||||||
|
|
|
@ -50,7 +50,7 @@
|
||||||
(let ((request-method (request-method request)))
|
(let ((request-method (request-method request)))
|
||||||
(cond
|
(cond
|
||||||
((string=? request-method "GET")
|
((string=? request-method "GET")
|
||||||
(form-query (http-url:search (request-url request))))
|
(form-query (http-url-search (request-url request))))
|
||||||
((string=? request-method "POST")
|
((string=? request-method "POST")
|
||||||
(or (cached-bindings request)
|
(or (cached-bindings request)
|
||||||
(let* ((content-length (get-content-length (request-headers request)))
|
(let* ((content-length (get-content-length (request-headers request)))
|
||||||
|
|
|
@ -26,7 +26,7 @@
|
||||||
(p (URL "/" "Return to main menu") (br)
|
(p (URL "/" "Return to main menu") (br)
|
||||||
(URL "add.scm" "Start new calculation."))))))))
|
(URL "add.scm" "Start new calculation."))))))))
|
||||||
(let* ((bindings (form-query
|
(let* ((bindings (form-query
|
||||||
(http-url:search (request-url result))))
|
(http-url-search (request-url result))))
|
||||||
(number (string->number
|
(number (string->number
|
||||||
(extract-single-binding "number" bindings))))
|
(extract-single-binding "number" bindings))))
|
||||||
(if number
|
(if number
|
||||||
|
|
|
@ -28,7 +28,7 @@
|
||||||
(URL "add2.scm" "Start new calculation."))))))))
|
(URL "add2.scm" "Start new calculation."))))))))
|
||||||
(if result
|
(if result
|
||||||
(or (input-field-value number-input-field
|
(or (input-field-value number-input-field
|
||||||
(form-query (http-url:search (request:url result))))
|
(form-query (http-url-search (request:url result))))
|
||||||
(get-number input-text "Please enter a valid number."))
|
(get-number input-text "Please enter a valid number."))
|
||||||
(get-number input-text "Please enter a number."))))
|
(get-number input-text "Please enter a number."))))
|
||||||
|
|
||||||
|
|
|
@ -56,7 +56,7 @@
|
||||||
,(make-submit-button))
|
,(make-submit-button))
|
||||||
(hr)
|
(hr)
|
||||||
(p (URL "/" "Return to main menu.")))))))
|
(p (URL "/" "Return to main menu.")))))))
|
||||||
(bindings (form-query (http-url:search (request-url req)))))
|
(bindings (form-query (http-url-search (request-url req)))))
|
||||||
(input-field-value byte-input-fields bindings)))
|
(input-field-value byte-input-fields bindings)))
|
||||||
|
|
||||||
(define (main req)
|
(define (main req)
|
||||||
|
|
|
@ -31,11 +31,13 @@
|
||||||
;;; These are frequently used as the initial prefix of URL's describing
|
;;; These are frequently used as the initial prefix of URL's describing
|
||||||
;;; Internet resources.
|
;;; Internet resources.
|
||||||
|
|
||||||
(define-record userhost ; Each slot is a decoded string or #f.
|
(define-record-type userhost :userhost ; Each slot is a decoded string or #f.
|
||||||
user
|
(make-userhost user password host port)
|
||||||
password
|
userhost?
|
||||||
host
|
(user userhost-user)
|
||||||
port)
|
(password userhost-password)
|
||||||
|
(host userhost-host)
|
||||||
|
(port userhost-port))
|
||||||
|
|
||||||
;;; Parse a URI path (a list representing a path, not a string!) into
|
;;; Parse a URI path (a list representing a path, not a string!) into
|
||||||
;;; a userhost record. Default values are taken from the userhost
|
;;; a userhost record. Default values are taken from the userhost
|
||||||
|
@ -61,15 +63,15 @@
|
||||||
; if any.
|
; if any.
|
||||||
(make-userhost (if at
|
(make-userhost (if at
|
||||||
(unescape-uri uhs 0 (or colon1 at))
|
(unescape-uri uhs 0 (or colon1 at))
|
||||||
(userhost:user default))
|
(userhost-user default))
|
||||||
(if colon1
|
(if colon1
|
||||||
(unescape-uri uhs (+ colon1 1) at)
|
(unescape-uri uhs (+ colon1 1) at)
|
||||||
(userhost:password default))
|
(userhost-password default))
|
||||||
(unescape-uri uhs (if at (+ at 1) 0)
|
(unescape-uri uhs (if at (+ at 1) 0)
|
||||||
(or colon2 uhs-len))
|
(or colon2 uhs-len))
|
||||||
(if colon2
|
(if colon2
|
||||||
(unescape-uri uhs (+ colon2 1) uhs-len)
|
(unescape-uri uhs (+ colon2 1) uhs-len)
|
||||||
(userhost:port default))))
|
(userhost-port default))))
|
||||||
|
|
||||||
(fatal-syntax-error "URL must begin with //..." path)))
|
(fatal-syntax-error "URL must begin with //..." path)))
|
||||||
|
|
||||||
|
@ -80,10 +82,10 @@
|
||||||
(string->char-set "@:"))) ; in UH strings.
|
(string->char-set "@:"))) ; in UH strings.
|
||||||
|
|
||||||
(define (userhost->string uh)
|
(define (userhost->string uh)
|
||||||
(let* ((us (userhost:user uh))
|
(let* ((us (userhost-user uh))
|
||||||
(pw (userhost:password uh))
|
(pw (userhost-password uh))
|
||||||
(ho (userhost:host uh))
|
(ho (userhost-host uh))
|
||||||
(po (userhost:port uh))
|
(po (userhost-port uh))
|
||||||
|
|
||||||
;; Encode before assembly in case pieces contain colons or at-signs.
|
;; Encode before assembly in case pieces contain colons or at-signs.
|
||||||
(e (lambda (s) (escape-uri s userhost-escaped-chars)))
|
(e (lambda (s) (escape-uri s userhost-escaped-chars)))
|
||||||
|
@ -104,11 +106,13 @@
|
||||||
;;; These elements are in raw, unescaped format. To convert back to
|
;;; These elements are in raw, unescaped format. To convert back to
|
||||||
;;; a string, use (uri-path-list->path (map escape-uri pathlist)).
|
;;; a string, use (uri-path-list->path (map escape-uri pathlist)).
|
||||||
|
|
||||||
(define-record http-url
|
(define-record-type http-url :http-url
|
||||||
userhost ; Initial //anonymous@clark.lcs.mit.edu:80/
|
(make-http-url userhost path search frag-id)
|
||||||
path ; Rest of path, split at slashes & decoded.
|
http-url?
|
||||||
search
|
(userhost http-url-userhost) ; Initial //anonymous@clark.lcs.mit.edu:80/
|
||||||
frag-id)
|
(path http-url-path) ; Rest of path, split at slashes & decoded.
|
||||||
|
(search http-url-search)
|
||||||
|
(frag-id http-url-frag-id))
|
||||||
|
|
||||||
;;; The URI parser (parse-uri in uri.scm) maps a string to four parts:
|
;;; The URI parser (parse-uri in uri.scm) maps a string to four parts:
|
||||||
;;; <scheme> : <path> ? <search> # <frag-id> <scheme>, <search>, and
|
;;; <scheme> : <path> ? <search> # <frag-id> <scheme>, <search>, and
|
||||||
|
@ -125,7 +129,7 @@
|
||||||
|
|
||||||
(define (parse-http-url path search frag-id)
|
(define (parse-http-url path search frag-id)
|
||||||
(let ((uh (parse-userhost path default-http-userhost)))
|
(let ((uh (parse-userhost path default-http-userhost)))
|
||||||
(if (or (userhost:user uh) (userhost:password uh))
|
(if (or (userhost-user uh) (userhost-password uh))
|
||||||
(fatal-syntax-error
|
(fatal-syntax-error
|
||||||
"HTTP URL's may not specify a user or password field" path))
|
"HTTP URL's may not specify a user or password field" path))
|
||||||
|
|
||||||
|
@ -140,12 +144,12 @@
|
||||||
|
|
||||||
(define (http-url->string url)
|
(define (http-url->string url)
|
||||||
(string-append "http://"
|
(string-append "http://"
|
||||||
(userhost->string (http-url:userhost url))
|
(userhost->string (http-url-userhost url))
|
||||||
"/"
|
"/"
|
||||||
(uri-path-list->path (map escape-uri (http-url:path url)))
|
(uri-path-list->path (map escape-uri (http-url-path url)))
|
||||||
(cond ((http-url:search url) =>
|
(cond ((http-url-search url) =>
|
||||||
(lambda (s) (string-append "?" s)))
|
(lambda (s) (string-append "?" s)))
|
||||||
(else ""))
|
(else ""))
|
||||||
(cond ((http-url:frag-id url) =>
|
(cond ((http-url-frag-id url) =>
|
||||||
(lambda (fi) (string-append "#" fi)))
|
(lambda (fi) (string-append "#" fi)))
|
||||||
(else ""))))
|
(else ""))))
|
||||||
|
|
|
@ -66,15 +66,10 @@
|
||||||
(export userhost? ; USERHOST
|
(export userhost? ; USERHOST
|
||||||
make-userhost ; record struct
|
make-userhost ; record struct
|
||||||
|
|
||||||
userhost:user
|
userhost-user
|
||||||
userhost:password
|
userhost-password
|
||||||
userhost:host
|
userhost-host
|
||||||
userhost:port
|
userhost-port
|
||||||
|
|
||||||
set-userhost:user
|
|
||||||
set-userhost:password
|
|
||||||
set-userhost:host
|
|
||||||
set-userhost:port
|
|
||||||
|
|
||||||
parse-userhost ; parse &
|
parse-userhost ; parse &
|
||||||
userhost->string ; unparse.
|
userhost->string ; unparse.
|
||||||
|
@ -82,15 +77,10 @@
|
||||||
http-url? ; HTTP-URL
|
http-url? ; HTTP-URL
|
||||||
make-http-url ; record struct
|
make-http-url ; record struct
|
||||||
|
|
||||||
http-url:userhost
|
http-url-userhost
|
||||||
http-url:path
|
http-url-path
|
||||||
http-url:search
|
http-url-search
|
||||||
http-url:frag-id
|
http-url-frag-id
|
||||||
|
|
||||||
set-http-url:userhost
|
|
||||||
set-http-url:path
|
|
||||||
set-http-url:search
|
|
||||||
set-http-url:frag-id
|
|
||||||
|
|
||||||
parse-http-url ; parse &
|
parse-http-url ; parse &
|
||||||
http-url->string))
|
http-url->string))
|
||||||
|
@ -469,7 +459,7 @@
|
||||||
(define-structure url url-interface
|
(define-structure url url-interface
|
||||||
(open scheme-with-scsh
|
(open scheme-with-scsh
|
||||||
scsh-utilities
|
scsh-utilities
|
||||||
defrec-package
|
define-record-types
|
||||||
receiving
|
receiving
|
||||||
srfi-13
|
srfi-13
|
||||||
srfi-14
|
srfi-14
|
||||||
|
@ -717,7 +707,7 @@
|
||||||
locks ; make-lock obtain-lock release-lock
|
locks ; make-lock obtain-lock release-lock
|
||||||
receiving ; receive
|
receiving ; receive
|
||||||
uri ; uri-path-list->path
|
uri ; uri-path-list->path
|
||||||
url ; http-url:path
|
url ; http-url-path
|
||||||
httpd-requests ; request record
|
httpd-requests ; request record
|
||||||
formats ; format
|
formats ; format
|
||||||
format-net ; format-internet-host-address
|
format-net ; format-internet-host-address
|
||||||
|
|
Loading…
Reference in New Issue