diff --git a/collects/web-server/configuration/configuration-table-structs.ss b/collects/web-server/configuration/configuration-table-structs.ss index 4047994066..98c56ae66d 100644 --- a/collects/web-server/configuration/configuration-table-structs.ss +++ b/collects/web-server/configuration/configuration-table-structs.ss @@ -27,7 +27,7 @@ (provide/contract [struct configuration-table - ([port natural-number/c] + ([port (between/c 1 65535)] [max-waiting natural-number/c] [initial-connection-timeout natural-number/c] [default-host host-table?] diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index 54ab37a8cf..db50d9dd0a 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -41,7 +41,8 @@ (gen-file-not-found-responder "not-found.html")]) (define get-mime-type (make-get-mime-type mime-types-path)) (lambda (conn req) - (define-values (uri method _path) (decompose-request req)) + (define uri (request-uri req)) + (define method (request-method req)) ;; ************************************************************ ;; ************************************************************ ;; SERVING FILES diff --git a/collects/web-server/dispatchers/dispatch-filter.ss b/collects/web-server/dispatchers/dispatch-filter.ss index ed0d224b58..70f11cc5c0 100644 --- a/collects/web-server/dispatchers/dispatch-filter.ss +++ b/collects/web-server/dispatchers/dispatch-filter.ss @@ -1,6 +1,9 @@ (module dispatch-filter mzscheme - (require (lib "contract.ss")) + (require (lib "contract.ss") + (lib "url.ss" "net") + (lib "uri-codec.ss" "net")) (require "dispatch.ss" + "../request-structs.ss" "../private/util.ss") (provide/contract [interface-version dispatcher-interface-version?] @@ -8,7 +11,7 @@ (define interface-version 'v1) (define ((make regex inner) conn req) - (define-values (uri method path) (decompose-request req)) + (define path (uri-decode (url-path->string (url-path (request-uri req))))) (if (regexp-match regex path) (inner conn req) (next-dispatcher)))) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index 6661b9e31f..5797f5e6a2 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -1,5 +1,7 @@ (module dispatch-passwords mzscheme (require (lib "kw.ss") + (lib "url.ss" "net") + (lib "uri-codec.ss" "net") (lib "contract.ss")) (require "dispatch.ss" "../private/util.ss" @@ -35,7 +37,9 @@ (update-password-cache!) (unbox password-cache)) (lambda (conn req) - (define-values (uri method path) (decompose-request req)) + (define uri (request-uri req)) + (define path (uri-decode (url-path->string (url-path uri)))) + (define method (request-method req)) (define denied? (read-password-cache)) (cond [(and denied? diff --git a/collects/web-server/dispatchers/dispatch-pathprocedure.ss b/collects/web-server/dispatchers/dispatch-pathprocedure.ss index 616589f752..ee9d89ccd7 100644 --- a/collects/web-server/dispatchers/dispatch-pathprocedure.ss +++ b/collects/web-server/dispatchers/dispatch-pathprocedure.ss @@ -1,8 +1,11 @@ (module dispatch-pathprocedure mzscheme - (require (lib "contract.ss")) + (require (lib "contract.ss") + (lib "url.ss" "net") + (lib "uri-codec.ss" "net")) (require "dispatch.ss" "../private/util.ss" "../private/response.ss" + "../request-structs.ss" "../response-structs.ss") (provide/contract [interface-version dispatcher-interface-version?] @@ -10,10 +13,10 @@ (define interface-version 'v1) (define ((make the-path procedure) conn req) - (let-values ([(uri method path) (decompose-request req)]) - (if (string=? the-path path) - (output-response/method - conn - (procedure) - method) - (next-dispatcher))))) \ No newline at end of file + (define path (uri-decode (url-path->string (url-path (request-uri req))))) + (if (string=? the-path path) + (output-response/method + conn + (procedure) + (request-method req)) + (next-dispatcher)))) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index f3292e4909..7823f78b18 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -3,7 +3,8 @@ (lib "kw.ss") (lib "plt-match.ss") (lib "string.ss") - (lib "contract.ss")) + (lib "contract.ss") + (lib "uri-codec.ss" "net")) (require "dispatch.ss" "../private/web-server-structs.ss" "../private/connection-manager.ss" @@ -383,7 +384,7 @@ ;; return dispatcher (lambda (conn req) - (define-values (uri method path) (decompose-request req)) + (define path (uri-decode (url-path->string (url-path (request-uri req))))) (cond [(string=? "/conf/refresh-servlets" path) ;; more here - this is broken - only out of date or specifically mentioned ;; scripts should be flushed. This destroys persistent state! @@ -391,7 +392,7 @@ (output-response/method conn (responders-servlets-refreshed) - method)] + (request-method req))] [(servlet-bin? path) (adjust-connection-timeout! conn diff --git a/collects/web-server/private/launch.ss b/collects/web-server/private/launch.ss index 4fe3077704..63159afb7e 100644 --- a/collects/web-server/private/launch.ss +++ b/collects/web-server/private/launch.ss @@ -25,10 +25,7 @@ ("Use an alternate configuration table" "file-name")] [("-p" "--port") ,(lambda (flag port) - (let ([p (string->number port)]) - (if (valid-port? p) - (cons 'port p) - (error 'web-server "port expects an argument of type ; given ~s" port)))) + (cons 'port (string->number port))) ("Use an alternate network port." "port")] [("-a" "--ip-address") ,(lambda (flag ip-address) diff --git a/collects/web-server/private/setup-launch.ss b/collects/web-server/private/setup-launch.ss index e4f3a25d77..770c1374e1 100644 --- a/collects/web-server/private/setup-launch.ss +++ b/collects/web-server/private/setup-launch.ss @@ -13,10 +13,7 @@ `((once-each [("-p" "--port") ,(lambda (flag port) - (let ([p (string->number port)]) - (if (valid-port? p) - (cons 'port p) - (error 'web-server-setup "port expects an argument of type ; given ~s" port)))) + (cons 'port (string->number port))) ("Use an alternate network port." "port")] [("-d" "--destination") ,(lambda (flag destination) diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss index 993626f9db..8454221d27 100644 --- a/collects/web-server/private/util.ss +++ b/collects/web-server/private/util.ss @@ -5,10 +5,6 @@ (lib "uri-codec.ss" "net")) (require "../request-structs.ss") - ;; valid-port? : any/c -> boolean? - (define (valid-port? p) - (and (integer? p) (exact? p) (<= 1 p 65535))) - ;; ripped this off from url-unit.ss (define (url-path->string strs) (apply string-append @@ -29,13 +25,6 @@ [else (error 'maybe-join-params "bad value from path/param-path: ~e" s)]))))) - ;; decompse-request : request -> uri * symbol * string - (define (decompose-request req) - (let* ([uri (request-uri req)] - [method (request-method req)] - [path (uri-decode (url-path->string (url-path uri)))]) - (values uri method path))) - ;; network-error: symbol string . values -> void ;; throws a formatted exn:fail:network (define (network-error src fmt . args) @@ -63,28 +52,7 @@ s)]) (string-lowercase! s) (string->symbol s))) - - ; prefix? : str -> str -> bool - ; more here - consider moving this to mzlib's string.ss - ;; Notes: (GregP) - ;; 1. What's the significance of char # 255 ??? - ;; 2. 255 isn't an ascii character. ascii is 7-bit - ;; 3. OK f this. It is only used in three places, some of them - ;; will involve bytes while the others may involve strings. So - ;; I will just use regular expressions and get on with life. - (define (prefix?-old prefix) - (let* ([len (string-length prefix)] - [last (string-ref prefix (sub1 len))] - [ascii (char->integer last)]) - (if (= 255 ascii) - ; something could be done about this - ab255 -> ac - ; and all 255's eliminates upper range check - (error 'prefix? "prefix can't end in the largest character") - (let ([next (string-append (substring prefix 0 (sub1 len)) - (string (integer->char (add1 ascii))))]) - (lambda (x) - (and (string<=? prefix x) (string bool - (define (hash-table-empty? table) - (zero? (hash-table-count table))) - (provide/contract [url-path->string ((listof (or/c string? path/param?)) . -> . string?)] [extract-flag (symbol? (listof (cons/c symbol? any/c)) any/c . -> . any/c)] - [hash-table-empty? (any/c . -> . boolean?)] - [valid-port? (any/c . -> . boolean?)] - [decompose-request ((request?) . ->* . (url? symbol? string?))] [network-error ((symbol? string?) (listof any/c) . ->* . (void))] [path->list (path? . -> . (cons/c (or/c path? (symbols 'up 'same)) (listof (or/c path? (symbols 'up 'same)))))]