suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixing url induced bugs

Browse Source 
svn: r1811
This commit is contained in:
Jay McCarthy 2006-01-12 00:33:25 +00:00
parent 4f4a6353c0
commit 723bf14c5b
2 changed files with 17 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
collects/web-server/servlet-helpers.ss
View File

@ -108,95 +108,6 @@
k-instance k-id k-salt
servlet-path
path))))
(define uri->servlet-url2
(opt-lambda (uri [default-host #f] [default-port #f])
(let-values ([(k-instance k-id k-salt)
(let ([k-parts (continuation-url? uri)])
(if k-parts
(apply values k-parts)
(values #f #f #f)))])
(let loop ([path (url-path uri)]
[servlets-root empty]
[found-servlets-root? #f]
[servlet-path empty]
[found-servlet-path? #f]
[extra-path empty])
(printf "~S~n" (list uri (list k-instance k-id k-salt)
path
servlets-root found-servlets-root?
servlet-path found-servlet-path?
extra-path))
(let ([top (if (empty? path)
#f
(first path))])
(cond
;; Find the servlets-root
[(and top
(not found-servlets-root?)
; XXX: Ack!
(not (or (and (not (empty? servlets-root))
(string=? "servlets" (first (reverse servlets-root))))
(path/param? top))))
(loop (rest path)
(append servlets-root (list top)) #f
servlet-path #f
extra-path)]
;;; if there is a continuation part
[(and top
(not found-servlets-root?)
(path/param? top))
(loop (rest path)
(append servlets-root (list (path/param-path top))) #t
servlet-path #f
extra-path)]
;;; if there is not
[(and top
(not found-servlets-root?)
; XXX: Ack!
(not (empty? servlets-root))
(string=? "servlets" (first (reverse servlets-root))))
(loop path
servlets-root #t
servlet-path #f
extra-path)]
;; Find the servlet path
[(and top
found-servlets-root?
(not found-servlet-path?)
(not (and (string? top)
(regexp-match ".ss$" top))))
(loop (rest path)
servlets-root #t
(append servlet-path (list top)) #f
extra-path)]
[(and top
found-servlets-root?
(not found-servlet-path?)
(and (string? top)
(regexp-match ".ss$" top)))
(loop (rest path)
servlets-root #t
(append servlet-path (list top)) #t
extra-path)]
;; Compute the servlet-url
[(and found-servlets-root?
found-servlet-path?)
(make-servlet-url (url-scheme uri)
(or (url-host uri) default-host)
(or (url-port uri) default-port)
servlets-root
k-instance
k-id
k-salt
servlet-path
path)]
[(empty? path)
(error 'request->servlet-url "Not servlet-url: ~S; parsed: ~S"
(url->string uri)
(list path
servlets-root found-servlets-root?
servlet-path found-servlet-path?
extra-path))]))))))
;; get-host : Url (listof (cons Symbol String)) -> Symbol
;; host names are case insesitive---Internet RFC 1034

19
collects/web-server/util.ss
View File

@ -26,7 +26,7 @@
[exn->string ((union exn? any/c) . -> . string?)]
[get-mime-type (path? . -> . bytes?)]
[build-path-unless-absolute (path? (union string? path?) . -> . path?)])
;; ripped this off from url-unit.ss
(define (url-path->string strs)
(apply
@ -178,7 +178,7 @@
[(eq? 'relative base) (current-directory)]
[(not base) (error 'directory-part "~a is a top-level directory" path)]
[(path? base) base])))
; more here - ".." should probably raise an error instead of disappearing.
(define (url-path->path base p)
(let ((path-elems (chop-string #\/ p)))
@ -292,5 +292,20 @@
(cond
((char=? first #\+)
(values #\space rest))
((char=? first #\%)
; MF: I rewrote this code so that Spidey could eliminate all checks.
; I am more confident this way that this hairy expression doesn't barf.
(if (pair? rest)
(let ([rest-rest (cdr rest)])
(if (pair? rest-rest)
(values (integer->char
(or (string->number (string (car rest) (car rest-rest)) 16)
(raise (make-invalid-%-suffix
(if (string->number (string (car rest)) 16)
(car rest-rest)
(car rest))))))
(cdr rest-rest))
(raise (make-incomplete-%-suffix rest))))
(raise (make-incomplete-%-suffix rest))))
(else (values first rest)))))
(cons this (loop rest)))))))))