*work around scsh bug (?) in definition of charset UNRESERVED
*new procs for encoding URIs: -general proc ESCAPE taking an RegExp representing forbidden chars as argument -specialized procs ESCAPE-SEGMENT, ESCAPE-QUERY *new helper proc ASCII->ESCAPED *use ESCAPE-SEGMENT and ESCAPE-URI in HTTP-URL->URI-STRING
This commit is contained in:
parent
c48446ba7f
commit
584bfa2cdb
|
@ -50,7 +50,7 @@
|
|||
|
||||
(define mark (rx ( "-_.!~*'()")))
|
||||
|
||||
(define unreserved (rx (| ,alphanum ,mark)))
|
||||
(define unreserved (rx (~ (~ (| ,alphanum ,mark)))))
|
||||
|
||||
(define reserved (rx ( ";/?:@&=+$,")))
|
||||
|
||||
|
@ -238,18 +238,17 @@
|
|||
(path-string
|
||||
(fold-right
|
||||
(lambda (segment res)
|
||||
(string-append "/" (escape-uri segment) res))
|
||||
(string-append "/" (escape-segment segment) res))
|
||||
""
|
||||
path))
|
||||
|
||||
(query (http-url-query http-url))
|
||||
(query-string (if query
|
||||
(string-append "?" (escape-uri query))
|
||||
(string-append "?" (escape-query query))
|
||||
"")))
|
||||
|
||||
(string-append scheme-and-host-string port-string path-string query-string)))
|
||||
|
||||
;;TODO: separate procedures for encoding path and query
|
||||
|
||||
|
||||
|
||||
|
@ -262,7 +261,7 @@
|
|||
;;; represents to a char.
|
||||
|
||||
;;; Caution:
|
||||
;;; a URI must be separated into its components (i.e. parsed by
|
||||
;;; a URI must be separated into its components (e.g. parsed by
|
||||
;;; PARSE-URI) before the escaped characters within those components
|
||||
;;; can be safely decoded. Don't use UNESCAPE on an unparsed URI.
|
||||
|
||||
|
@ -297,3 +296,57 @@
|
|||
10))))
|
||||
|
||||
|
||||
;;; encode URIs:
|
||||
;;; replace characters which are reserved or excluded by their escaped representation.
|
||||
|
||||
;;; Caution:
|
||||
;;; Each component of a URI may have its own set of characters that are reserved,
|
||||
;;; -> differentiate between components.
|
||||
|
||||
;;; Caution:
|
||||
;;; don't encode an already encoded string; #\% chars would be escaped again.
|
||||
|
||||
;;; not allowed within component 'segment' in 'abs_path'
|
||||
(define segment-reserved-and-excluded (rx (~ ,unreserved ,pchar-charset (";"))))
|
||||
|
||||
;;; not allowed within component 'query'
|
||||
(define query-reserved-and-excluded (rx (~ ,unreserved ,reserved )))
|
||||
|
||||
;;; encode 'abs_path' portion of a URI:
|
||||
;;; use SPLIT-PATH to split abs_path into its segments,
|
||||
;;; then apply UNESCAPE-SEGMENT to the segments.
|
||||
(define (escape-segment segment)
|
||||
(escape segment segment-reserved-and-excluded))
|
||||
|
||||
;;; encode 'query' portion of a URI
|
||||
(define (escape-query query)
|
||||
(escape query query-reserved-and-excluded))
|
||||
|
||||
(define (escape s regexp)
|
||||
(regexp-fold
|
||||
regexp
|
||||
(lambda (start-search match res)
|
||||
(let* ((start-match (match:start match))
|
||||
(forbidden-char (string-ref s start-match)))
|
||||
(string-append
|
||||
res
|
||||
(substring s start-search start-match)
|
||||
(ascii->escaped (char->ascii forbidden-char)))))
|
||||
""
|
||||
s
|
||||
(lambda (start-search res)
|
||||
(string-append res (substring s start-search (string-length s))))))
|
||||
|
||||
(define (ascii->escaped dec-int)
|
||||
(let* ((hex-int-high (bitwise-and (arithmetic-shift dec-int -4) #xF))
|
||||
(hex-int-low (bitwise-and dec-int #xF)))
|
||||
(string-append
|
||||
"%" (int->hexstring hex-int-high) (int->hexstring hex-int-low))))
|
||||
|
||||
(define int->hexstring
|
||||
(let ((table '#("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
|
||||
"A" "B" "C" "D" "E" "F")))
|
||||
(lambda (i) (vector-ref table i))))
|
||||
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue