From 15381cd7f5cc3c0b270f30422cda07b196c2a8ce Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 12 May 2006 16:37:05 +0000 Subject: [PATCH] reorganization svn: r2921 --- collects/web-server/configuration.ss | 2 +- collects/web-server/connection-manager.ss | 2 +- collects/web-server/dispatch-servlets.ss | 3 +- .../web-server/{ => private}/cache-table.ss | 0 collects/web-server/private/url.ss | 76 +++++++++++++++ collects/web-server/servlet-env.ss | 11 +-- collects/web-server/servlet-helpers.ss | 92 +------------------ collects/web-server/servlet-tables.ss | 86 ++--------------- collects/web-server/servlet.ss | 13 ++- collects/web-server/url.ss | 91 ++++++++++++++++++ collects/web-server/web-server-unit.ss | 40 ++++---- 11 files changed, 212 insertions(+), 204 deletions(-) rename collects/web-server/{ => private}/cache-table.ss (100%) create mode 100644 collects/web-server/private/url.ss create mode 100644 collects/web-server/url.ss diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss index 4d4ace9686..f56cc8face 100644 --- a/collects/web-server/configuration.ss +++ b/collects/web-server/configuration.ss @@ -5,7 +5,7 @@ "sig.ss" "util.ss" "parse-table.ss" - "cache-table.ss" + "private/cache-table.ss" "response.ss") (require (lib "unitsig.ss") (lib "contract.ss")) diff --git a/collects/web-server/connection-manager.ss b/collects/web-server/connection-manager.ss index 175a2d536b..8b2c98eebf 100644 --- a/collects/web-server/connection-manager.ss +++ b/collects/web-server/connection-manager.ss @@ -1,4 +1,4 @@ -;; this is an trivial implementation of the connection-manger interface that +;; this is a trivial implementation of the connection-manger interface that ;; uses timeouts instead of a queued-model. ;; the queued-model is also fully implemented but won't be used at this time. diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index 577309756b..bcee7eb4da 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -10,7 +10,8 @@ "sig.ss" "timer.ss" "util.ss" - "cache-table.ss") + "private/url.ss" + "private/cache-table.ss") (provide interface-version gen-dispatcher) diff --git a/collects/web-server/cache-table.ss b/collects/web-server/private/cache-table.ss similarity index 100% rename from collects/web-server/cache-table.ss rename to collects/web-server/private/cache-table.ss diff --git a/collects/web-server/private/url.ss b/collects/web-server/private/url.ss new file mode 100644 index 0000000000..5cfed950dc --- /dev/null +++ b/collects/web-server/private/url.ss @@ -0,0 +1,76 @@ +(module url mzscheme + (require (lib "contract.ss") + (lib "url.ss" "net") + (lib "list.ss") + (lib "plt-match.ss")) + + (provide + match-url-params) + (provide/contract + [continuation-url? (url? . -> . (or/c boolean? (list/c symbol? number? number?)))] + [embed-ids ((list/c symbol? number? number?) url? . -> . string?)]) + + ;; ******************************************************************************** + ;; Parameter Embedding + + (define URL-PARAMS:REGEXP (regexp "([^\\*]*)\\*([^\\*]*)\\*([^\\*]*)")) + + (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x)) + + ;; embed-ids: (list number number number) url -> string + (define embed-ids + (match-lambda* + [(list (list inst-id k-id salt) in-url) + (insert-param + in-url + (format "~a*~a*~a" inst-id k-id salt))])) + + ;; continuation-url?: url -> (or/c (list number number number) #f) + ;; determine if this url encodes a continuation and extract the instance id and + ;; continuation id. + (define (continuation-url? a-url) + (let ([k-params (filter match-url-params + (apply append (map path/param-param (url-path a-url))))]) + (if (empty? k-params) + #f + (match (match-url-params (first k-params)) + [(list s instance k-id salt) + (let ([k-id/n (string->number k-id)] + [salt/n (string->number salt)]) + (if (and (number? k-id/n) + (number? salt/n)) + (list (string->symbol instance) + k-id/n + salt/n) + ; XXX: Maybe log this in some way? + #f))])))) + + ;; insert-param: url string -> string + ;; add a path/param to the path in a url + ;; (assumes that there is only one path/param) + (define (insert-param in-url new-param-str) + (url->string + (replace-path + (lambda (old-path) + (if (empty? old-path) + (list (make-path/param "" (list new-param-str))) + (list* (make-path/param (path/param-path (first old-path)) + (list new-param-str)) + (rest old-path)))) + in-url))) + + ;; replace-path: (url-path -> url-path) url -> url + ;; make a new url by replacing the path part of a url with a function + ;; of the url's old path + ;; also remove the query + (define (replace-path proc in-url) + (let ([new-path (proc (url-path in-url))]) + (make-url + (url-scheme in-url) + (url-user in-url) + (url-host in-url) + (url-port in-url) + (url-path-absolute? in-url) + new-path + empty + (url-fragment in-url))))) \ No newline at end of file diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 5070393a7f..72bd05311d 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -1,17 +1,14 @@ (module servlet-env mzscheme + (require (lib "sendurl.ss" "net") + (lib "unitsig.ss")) (require "configuration.ss" "web-server.ss" "sig.ss" - "servlet.ss" - "connection-manager.ss" "servlet-tables.ss" "util.ss" "response.ss" - "cache-table.ss") - (require (lib "url.ss" "net") - (lib "sendurl.ss" "net") - (lib "unitsig.ss") - (lib "tcp-sig.ss" "net")) + "private/cache-table.ss") + (require "servlet.ss") (provide (rename on-web:syntax on-web) (all-from "servlet.ss")) diff --git a/collects/web-server/servlet-helpers.ss b/collects/web-server/servlet-helpers.ss index 6c67cb7132..d66537dfa6 100644 --- a/collects/web-server/servlet-helpers.ss +++ b/collects/web-server/servlet-helpers.ss @@ -3,12 +3,10 @@ (lib "etc.ss") (lib "xml.ss" "xml") (lib "base64.ss" "net") - (lib "url.ss" "net") - (lib "struct.ss")) + (lib "url.ss" "net")) (require "util.ss" "response.ss" - "request-parsing.ss" - "servlet-tables.ss") + "request-parsing.ss") (provide get-host extract-binding/single extract-bindings @@ -23,91 +21,7 @@ see-other (all-from "request-parsing.ss") (rename get-parsed-bindings request-bindings) - translate-escapes) - - ;; URL parsing - (provide (struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path)) - servlet-url->url-string - servlet-url->url-string/no-continuation - servlet-url->servlet-url/no-extra-path - request->servlet-url - uri->servlet-url) - (define-struct servlet-url (protocol host port - servlets-root - instance-id k-id nonce - servlet-path extra-path)) - (define (servlet-url->url-string/no-continuation su) - (url->string - (make-url (servlet-url-protocol su) - #f - #f ;(servlet-url-host su) - #f ;(servlet-url-port su) - #t - (append (map (lambda (p/p) - (if (and (not (empty? (path/param-param p/p))) - ; XXX: not robust - (match-url-params (first (path/param-param p/p)))) - (make-path/param (path/param-path p/p) empty) - p/p)) - (servlet-url-servlets-root su)) - (servlet-url-servlet-path su) - (servlet-url-extra-path su)) - empty - #f))) - (define (servlet-url->url-string su) - (let ([the-url - (make-url (servlet-url-protocol su) - #f - #f ;(servlet-url-host su) - #f ;(servlet-url-port su) - #t - (append (reverse (rest (reverse (servlet-url-servlets-root su)))) - (list (make-path/param (path/param-path (first (reverse (servlet-url-servlets-root su)))) - empty)) - (servlet-url-servlet-path su) - (servlet-url-extra-path su)) - empty - #f)]) - (if (and (servlet-url-instance-id su) - (servlet-url-k-id su) - (servlet-url-nonce su)) - (embed-ids (servlet-url-instance-id su) - (servlet-url-k-id su) - (servlet-url-nonce su) - the-url) - (url->string the-url)))) - (define (servlet-url->servlet-url/no-extra-path su) - (copy-struct servlet-url su - [servlet-url-extra-path empty])) - (define (request->servlet-url req) - (uri->servlet-url (request-uri req) - (request-host-ip req) - (request-host-port req))) - (define uri->servlet-url - (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)))] - [(servlet-path path) - (let loop ([servlet-path empty] - [path (rest (url-path uri))]) - (if (empty? path) - (values servlet-path path) - (let ([cur (first path)]) - (if (regexp-match "\\.ss$" (path/param-path cur)) - (values (append servlet-path (list cur)) - (rest path)) - (loop (append servlet-path (list cur)) - (rest path))))))]) - (make-servlet-url (url-scheme uri) - (or (url-host uri) default-host) - (or (url-port uri) default-port) - (list (first (url-path uri))) - k-instance k-id k-salt - servlet-path - path)))) + translate-escapes) ;; get-host : Url (listof (cons Symbol String)) -> Symbol ;; host names are case insesitive---Internet RFC 1034 diff --git a/collects/web-server/servlet-tables.ss b/collects/web-server/servlet-tables.ss index 58bb1f4c3d..3b877ccebf 100644 --- a/collects/web-server/servlet-tables.ss +++ b/collects/web-server/servlet-tables.ss @@ -1,9 +1,6 @@ (module servlet-tables mzscheme - (require (lib "contract.ss") - (lib "url.ss" "net") - (lib "list.ss") - (lib "plt-match.ss") - "timer.ss") + (require (lib "contract.ss")) + (require "timer.ss") (provide (struct exn:servlet:instance ()) (struct exn:servlet:no-current-instance ()) (struct exn:servlet:continuation (expiration-handler)) @@ -35,12 +32,8 @@ ;; * The servlet-instance-mutex is used to guarentee mutual-exclusion in the ;; case when it is attempted to invoke multiple continuations ;; simultaneously. - (provide - match-url-params) (provide/contract - [continuation-url? (url? . -> . (or/c boolean? (list/c symbol? number? number?)))] - [embed-ids (symbol? number? number? url? . -> . string?)] - [store-continuation! (procedure? procedure? url? servlet-instance? . -> . string?)] + [store-continuation! (procedure? procedure? servlet-instance? . -> . (list/c symbol? integer? integer?))] [create-new-instance! (hash-table? custodian? execution-context? semaphore? timer? . -> . servlet-instance?)] [remove-instance! (hash-table? servlet-instance? . -> . any)] @@ -78,7 +71,7 @@ (hash-table-put! k-table1 id v) ; Replace continuations with #f (hash-table-put! k-table1 id (list* #f (cdr v)))))) - k-table1)) + k-table1)) ;; get-k-id!: hash-table -> number ;; get the current-continuation id and increment the internal value @@ -87,14 +80,14 @@ (hash-table-put! k-table id-slot (add1 id)) id))))) - ;; store-continuation!: continuation expiration-handler uri servlet-instance -> url-string + ;; store-continuation!: continuation expiration-handler servlet-instance -> (list symbol? integer? integer?) ;; store a continuation in a k-table for the provided servlet-instance - (define (store-continuation! k expiration-handler uri inst) + (define (store-continuation! k expiration-handler inst) (let ([k-table (servlet-instance-k-table inst)]) (let ([next-k-id (get-k-id! k-table)] [salt (random 100000000)]) (hash-table-put! k-table next-k-id (list k expiration-handler salt)) - (embed-ids (servlet-instance-id inst) next-k-id salt uri)))) + (list (servlet-instance-id inst) next-k-id salt)))) ;; clear-continuations!: servlet-instance -> void ;; replace the k-table for the given servlet-instance @@ -115,67 +108,4 @@ ;; remove-instance!: hash-table servlet-instance -> void (define (remove-instance! instance-table inst) - (hash-table-remove! instance-table (servlet-instance-id inst))) - - ;; ******************************************************************************** - ;; Parameter Embedding - - (define URL-PARAMS:REGEXP (regexp "([^\\*]*)\\*([^\\*]*)\\*([^\\*]*)")) - - (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x)) - - ;; embed-ids: number number number url -> string - (define (embed-ids inst-id k-id salt in-url) - (insert-param - in-url - (format "~a*~a*~a" inst-id k-id salt))) - - ;; continuation-url?: url -> (or/c (list number number number) #f) - ;; determine if this url encodes a continuation and extract the instance id and - ;; continuation id. - (define (continuation-url? a-url) - (let ([k-params (filter match-url-params - (apply append (map path/param-param (url-path a-url))))]) - (if (empty? k-params) - #f - (match (match-url-params (first k-params)) - [(list s instance k-id salt) - (let ([k-id/n (string->number k-id)] - [salt/n (string->number salt)]) - (if (and (number? k-id/n) - (number? salt/n)) - (list (string->symbol instance) - k-id/n - salt/n) - ; XXX: Maybe log this in some way? - #f))])))) - - ;; insert-param: url string -> string - ;; add a path/param to the path in a url - ;; (assumes that there is only one path/param) - (define (insert-param in-url new-param-str) - (url->string - (replace-path - (lambda (old-path) - (if (empty? old-path) - (list (make-path/param "" (list new-param-str))) - (list* (make-path/param (path/param-path (first old-path)) - (list new-param-str)) - (rest old-path)))) - in-url))) - - ;; replace-path: (url-path -> url-path) url -> url - ;; make a new url by replacing the path part of a url with a function - ;; of the url's old path - ;; also remove the query - (define (replace-path proc in-url) - (let ([new-path (proc (url-path in-url))]) - (make-url - (url-scheme in-url) - (url-user in-url) - (url-host in-url) - (url-port in-url) - (url-path-absolute? in-url) - new-path - empty - (url-fragment in-url))))) \ No newline at end of file + (hash-table-remove! instance-table (servlet-instance-id inst)))) \ No newline at end of file diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index 153f334694..b4ae2533c4 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -4,6 +4,7 @@ (lib "xml.ss" "xml")) (require "servlet-tables.ss" "response.ss" + "private/url.ss" "servlet-helpers.ss" "timer.ss" "web-cells.ss") @@ -72,9 +73,11 @@ [send/suspend/dispatch ((embed/url? . -> . servlet-response?) . -> . any/c)] [send/suspend/callback (xexpr/callback? . -> . any/c)]) + (require "url.ss") (provide (all-from "web-cells.ss") - (all-from "servlet-helpers.ss")) + (all-from "servlet-helpers.ss") + (all-from "url.ss")) ;; ************************************************************ ;; EXPORTS @@ -123,10 +126,10 @@ (let/cc k (let* ([inst (get-current-servlet-instance)] [ctxt (servlet-instance-context inst)] - [k-url (store-continuation! - k expiration-handler - (request-uri (execution-context-request ctxt)) - inst)] + [k-embedding (store-continuation! k expiration-handler inst)] + [k-url (embed-ids + k-embedding + (request-uri (execution-context-request ctxt)))] [k-url ((current-url-transform) k-url)] [response (response-generator k-url)]) (output-response (execution-context-connection ctxt) response) diff --git a/collects/web-server/url.ss b/collects/web-server/url.ss new file mode 100644 index 0000000000..b5094a8a11 --- /dev/null +++ b/collects/web-server/url.ss @@ -0,0 +1,91 @@ +(module url mzscheme + (require (lib "list.ss") + (lib "etc.ss") + (lib "url.ss" "net") + (lib "struct.ss")) + (require "private/url.ss" + "request-parsing.ss") + + ;; URL parsing + (provide (struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path)) + servlet-url->url-string + servlet-url->url-string/no-continuation + servlet-url->servlet-url/no-extra-path + request->servlet-url + uri->servlet-url) + (define-struct servlet-url (protocol host port + servlets-root + instance-id k-id nonce + servlet-path extra-path)) + (define (servlet-url->url-string/no-continuation su) + (url->string + (make-url (servlet-url-protocol su) + #f + #f ;(servlet-url-host su) + #f ;(servlet-url-port su) + #t + (append (map (lambda (p/p) + (if (and (not (empty? (path/param-param p/p))) + ; XXX: not robust + (match-url-params (first (path/param-param p/p)))) + (make-path/param (path/param-path p/p) empty) + p/p)) + (servlet-url-servlets-root su)) + (servlet-url-servlet-path su) + (servlet-url-extra-path su)) + empty + #f))) + (define (servlet-url->url-string su) + (let ([the-url + (make-url (servlet-url-protocol su) + #f + #f ;(servlet-url-host su) + #f ;(servlet-url-port su) + #t + (append (reverse (rest (reverse (servlet-url-servlets-root su)))) + (list (make-path/param (path/param-path (first (reverse (servlet-url-servlets-root su)))) + empty)) + (servlet-url-servlet-path su) + (servlet-url-extra-path su)) + empty + #f)]) + (if (and (servlet-url-instance-id su) + (servlet-url-k-id su) + (servlet-url-nonce su)) + (embed-ids (list (servlet-url-instance-id su) + (servlet-url-k-id su) + (servlet-url-nonce su)) + the-url) + (url->string the-url)))) + (define (servlet-url->servlet-url/no-extra-path su) + (copy-struct servlet-url su + [servlet-url-extra-path empty])) + (define (request->servlet-url req) + (uri->servlet-url (request-uri req) + (request-host-ip req) + (request-host-port req))) + (define uri->servlet-url + (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)))] + [(servlet-path path) + (let loop ([servlet-path empty] + [path (rest (url-path uri))]) + (if (empty? path) + (values servlet-path path) + (let ([cur (first path)]) + (if (regexp-match "\\.ss$" (path/param-path cur)) + (values (append servlet-path (list cur)) + (rest path)) + (loop (append servlet-path (list cur)) + (rest path))))))]) + (make-servlet-url (url-scheme uri) + (or (url-host uri) default-host) + (or (url-port uri) default-port) + (list (first (url-path uri))) + k-instance k-id k-salt + servlet-path + path))))) \ No newline at end of file diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 92b2f12372..9e07c83f1b 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -4,7 +4,7 @@ "connection-manager.ss" "configuration-structures.ss" "servlet.ss" - "cache-table.ss" + "private/cache-table.ss" (rename "request-parsing.ss" the-read-request read-request)) (require (prefix sequencer: "dispatch-sequencer.ss") @@ -31,33 +31,29 @@ (let ([the-server-custodian (make-custodian)]) (start-connection-manager the-server-custodian) (parameterize ([current-custodian the-server-custodian] - [current-server-custodian the-server-custodian]) + [current-server-custodian the-server-custodian] + [current-thread-initial-stack-size 3]) (thread (lambda () - (listener-loop)))) + (start-listener)))) (lambda () (custodian-shutdown-all the-server-custodian)))) - ;; listener-loop : -> void + ;; start-listener : -> void ;; loops around starting a listener if the current listener dies - (define (listener-loop) - (let loop () - (thread-wait - (let* ([listener (tcp-listen config:port config:max-waiting - #t config:listen-ip)] - [get-ports - (lambda () (tcp-accept listener))]) - (thread - (lambda () - (with-handlers ([void (lambda (e) - ; If the exception did not kill the listener - (with-handlers ([void void]) - (tcp-close listener)) - ; Rethrow the error to this thread's error printer - (raise e))]) - (server-loop get-ports - tcp-addresses)))))) - (loop))) + (define (start-listener) + (let* ([listener (tcp-listen config:port config:max-waiting + #t config:listen-ip)] + [get-ports + (lambda () (tcp-accept listener))]) + (with-handlers ([void (lambda (e) + ; If the exception did not kill the listener + (with-handlers ([void void]) + (tcp-close listener)) + ; Rethrow the error to this thread's error printer + (raise e))]) + (server-loop get-ports + tcp-addresses)))) ;; server-loop: (-> input-port output-port) (input-port -> string string) -> void ;; start a thread to handle each incoming connection