From a039d7deeb8c49368244bb7e49c4c4c1b52c91f3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 29 Jun 2007 21:46:27 +0000 Subject: [PATCH] Improving performance of lang servlets svn: r6774 --- .../web-server/dispatchers/dispatch-lang.ss | 115 ++++++------------ .../web-server/dispatchers/dispatch-stat.ss | 32 +++++ .../docs/reference/dispatchers.scrbl | 16 +++ collects/web-server/private/session.ss | 77 ++++++------ collects/web-server/run.ss | 8 +- .../tests/dispatchers/dispatch-lang-test.ss | 3 +- .../web-server/tests/private/session-test.ss | 23 ++-- collects/web-server/tests/util.ss | 4 +- 8 files changed, 140 insertions(+), 138 deletions(-) create mode 100644 collects/web-server/dispatchers/dispatch-stat.ss diff --git a/collects/web-server/dispatchers/dispatch-lang.ss b/collects/web-server/dispatchers/dispatch-lang.ss index 39899c6a40..8238d50382 100644 --- a/collects/web-server/dispatchers/dispatch-lang.ss +++ b/collects/web-server/dispatchers/dispatch-lang.ss @@ -2,13 +2,13 @@ (require (lib "kw.ss") (lib "list.ss") (lib "contract.ss") - (lib "url.ss" "net") (lib "session.ss" "web-server" "private") (only "../lang/web.ss" initialize-servlet) (lib "web-cells.ss" "web-server" "lang") "../private/request-structs.ss" "dispatch.ss" + "../private/web-server-structs.ss" "../private/util.ss" "../private/response.ss" "../configuration/namespace.ss" @@ -18,33 +18,6 @@ [interface-version dispatcher-interface-version?]) (provide make) - (define top-cust (current-custodian)) - - ; same-servlet? : url? url? -> boolean? - (define (same-servlet? req ses) - (define (abstract-url u) - (map path/param-path - (url-path u))) - #;(printf "~S => ~S~n" `(same-servlet? ,(url->string req) ,(url->string ses)) ans) - (list-prefix? (abstract-url ses) (abstract-url req))) - - ;; make-session-url: url (listof string) -> url - ;; produce a new url for this session: - ;; Minimal path to the servlet. - ;; No query. - ;; No fragment. - (define (make-session-url uri new-path) - (make-url - (url-scheme uri) - (url-user uri) - (url-host uri) - (url-port uri) - #t - (map (lambda (p) (make-path/param p empty)) - new-path) - empty - #f)) - ; XXX url->servlet ; XXX optional session manager (define interface-version 'v1) @@ -59,63 +32,49 @@ ;; dispatch : connection request -> void (define (dispatch conn req) - (define uri (request-uri req)) - (cond - [(extract-session uri) - => (lambda (session-id) - (resume-session session-id conn req))] - [else - (begin-session conn req)])) - - ;; XXX Currently there are just sessions, should be servlets and sessions - ;; XXX Control extent of servlet data - ;; begin-session: connection request - (define (begin-session conn req) (define uri (request-uri req)) (with-handlers ([void (lambda (exn) (next-dispatcher))]) (define-values (a-path url-servlet-path) (url->path uri)) - (with-handlers ([void + (define url-servlet-paths (map path->string url-servlet-path)) + (with-handlers ([exn? (lambda (the-exn) (output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))]) - (parameterize ([current-directory (directory-part a-path)]) - (define cust (make-custodian top-cust)) - (define ns (make-servlet-namespace - #:additional-specs - '((lib "web-cells.ss" "web-server" "lang") - (lib "abort-resume.ss" "web-server" "lang") - (lib "session.ss" "web-server" "private") - (lib "request-structs.ss" "web-server" "private")))) - (define ses (new-session cust ns (make-session-url uri (map path->string url-servlet-path)))) - (parameterize ([current-custodian cust] - [current-namespace ns] - [current-session ses]) - (define start - (dynamic-require `(file ,(path->string a-path)) - 'start)) - (set-session-servlet! ses (initialize-servlet start))) - (resume-session (session-id ses) - conn req))))) - - ;; resume-session: number connection request - (define (resume-session ses-id conn req) - (cond - [(lookup-session ses-id) - => (lambda (ses) - (if (same-servlet? (request-uri req) (session-url ses)) - (parameterize ([current-custodian (session-cust ses)] - [current-session ses]) - (with-handlers ([void - (lambda (the-exn) - (output-response/method - conn - (responders-servlet (request-uri req) the-exn) - (request-method req)))]) - (output-response conn ((session-servlet ses) req)))) - (begin-session conn req)))] - [else - (begin-session conn req)])) + + (define ses + (cond + [(lookup-session url-servlet-paths) + => (lambda (ses) ses)] + [else + (let () + (define cust (make-custodian (current-server-custodian))) + (define ns (make-servlet-namespace + #:additional-specs + '((lib "web-cells.ss" "web-server" "lang") + (lib "abort-resume.ss" "web-server" "lang") + (lib "session.ss" "web-server" "private") + (lib "request-structs.ss" "web-server" "private")))) + (define ses (new-session cust ns uri url-servlet-paths)) + (parameterize ([current-custodian cust] + [current-directory (directory-part a-path)] + [current-namespace ns] + [current-session ses]) + (define start + (dynamic-require `(file ,(path->string a-path)) + 'start)) + (set-session-servlet! ses (initialize-servlet start))) + ses)])) + (parameterize ([current-custodian (session-cust ses)] + [current-namespace (session-namespace ses)] + [current-session ses]) + (with-handlers ([exn? + (lambda (the-exn) + (output-response/method + conn + (responders-servlet uri the-exn) + (request-method req)))]) + (output-response conn ((session-servlet ses) req))))))) dispatch)) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-stat.ss b/collects/web-server/dispatchers/dispatch-stat.ss new file mode 100644 index 0000000000..d75f2a1b39 --- /dev/null +++ b/collects/web-server/dispatchers/dispatch-stat.ss @@ -0,0 +1,32 @@ +(module dispatch-stat mzscheme + (require (lib "contract.ss")) + (require "dispatch.ss" + "../private/web-server-structs.ss" + "../private/connection-manager.ss") + (provide/contract + [make-gc-thread (integer? . -> . thread?)] + [interface-version dispatcher-interface-version?] + [make (-> dispatcher?)]) + + (define (bytes->mb b) + (round (exact->inexact (/ b 1024 1024)))) + + (define (print-memory-usage) + (printf "Usage: ~aMB (of ~aMB)~n" + (bytes->mb (current-memory-use (current-server-custodian))) + (bytes->mb (current-memory-use)))) + + (define (make-gc-thread t) + (thread + (lambda () + (let loop () + (sleep t) + (printf ".") + (collect-garbage) + (loop))))) + + (define interface-version 'v1) + (define ((make) conn req) + #;(dump-memory-stats) + (print-memory-usage) + (next-dispatcher))) \ No newline at end of file diff --git a/collects/web-server/docs/reference/dispatchers.scrbl b/collects/web-server/docs/reference/dispatchers.scrbl index dcadb94f28..e3277cae30 100644 --- a/collects/web-server/docs/reference/dispatchers.scrbl +++ b/collects/web-server/docs/reference/dispatchers.scrbl @@ -335,3 +335,19 @@ that runs servlets written in the Web Language. If there is an error when a servlet is invoked, then @scheme[responders-servlet] is used to format a response with the exception. } + +@; ------------------------------------------------------------ +@section[#:tag "dispatch-stat.ss"]{Statistics} + +@file{dispatchers/dispatch-stat.ss} provides services related to performance +statistics. + +@defproc[(make-gc-thread [time integer?]) + thread?]{ + Starts a thread that calls @scheme[(collect-garbage)] every @scheme[time] seconds. +} + +@defproc[(make) + dispatcher?]{ + Returns a dispatcher that prints memory usage on every request. +} \ No newline at end of file diff --git a/collects/web-server/private/session.ss b/collects/web-server/private/session.ss index 098a336224..9777d2d82b 100644 --- a/collects/web-server/private/session.ss +++ b/collects/web-server/private/session.ss @@ -1,57 +1,56 @@ (module session mzscheme (require (lib "contract.ss") + (lib "list.ss") (lib "url.ss" "net") "response-structs.ss" - "request-structs.ss" - "url-param.ss") - (provide current-session) + "request-structs.ss") - (define-struct session (id cust namespace servlet url)) + ;; make-session-url: url (listof string) -> url + ;; produce a new url for this session: + ;; Minimal path to the servlet. + ;; No query. + ;; No fragment. + (define (make-session-url uri new-path) + (make-url + (url-scheme uri) + (url-user uri) + (url-host uri) + (url-port uri) + #t + (map (lambda (p) (make-path/param p empty)) + new-path) + empty + #f)) + + (define-struct session (cust namespace servlet url)) (provide/contract - [struct session ([id number?] - [cust custodian?] + [struct session ([cust custodian?] [namespace namespace?] [servlet (request? . -> . response?)] [url url?])] - [extract-session (url? . -> . (or/c number? false/c))] - [lookup-session (number? . -> . (or/c session? false/c))] - [new-session (custodian? namespace? url? . -> . session?)]) + [lookup-session ((listof string?) . -> . (or/c session? false/c))] + [new-session (custodian? namespace? url? (listof string?) . -> . session?)]) + (provide current-session) (define current-session (make-parameter #f)) - ;; new-session-id : -> number - (define new-session-id - (let ([ses-id 0]) - (lambda () - (set! ses-id (add1 ses-id)) - ses-id))) + (define the-session-table (make-hash-table 'weak 'equal)) - (define the-session-table (make-hash-table)) - - ;; new-session : namespace path -> session - (define (new-session cust ns uri) - (let* ([new-id (new-session-id)] - [ses (make-session - new-id + ;; new-session : namespace path uri (listof string) -> session + (define (new-session cust ns uri paths) + (define ses (make-session cust ns (lambda (req) (error "session not initialized")) - (encode-session uri new-id))]) - (hash-table-put! the-session-table new-id ses) - ses)) + (make-session-url uri paths))) + #;(printf "New session of ~a~n" (hash-table-count the-session-table)) + (hash-table-put! the-session-table paths (make-weak-box ses)) + ses) - ;; lookup-session : number -> (union session #f) - (define (lookup-session ses-id) - (hash-table-get the-session-table ses-id (lambda () #f))) - - ;; encode-session : url number -> url - (define (encode-session a-url ses-id) - (insert-param a-url "s" (number->string ses-id))) - - ;; extract-session : url -> (union number #f) - ;; Determine if the url encodes a session-id and extract it - (define (extract-session a-url) - (define id (extract-param a-url "s")) - (with-handlers ([exn? (lambda _ #f)]) - (string->number id)))) \ No newline at end of file + ;; lookup-session : (listof string) -> (union session #f) + (define (lookup-session paths) + (let/ec esc + (weak-box-value + (hash-table-get the-session-table paths + (lambda () (esc #f))))))) \ No newline at end of file diff --git a/collects/web-server/run.ss b/collects/web-server/run.ss index 43ac8dffa5..662aaefee6 100644 --- a/collects/web-server/run.ss +++ b/collects/web-server/run.ss @@ -11,7 +11,8 @@ (prefix filter: (lib "dispatch-filter.ss" "web-server" "dispatchers")) (prefix lift: (lib "dispatch-lift.ss" "web-server" "dispatchers")) (prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers")) - (prefix lang: (lib "dispatch-lang.ss" "web-server" "dispatchers"))) + (prefix lang: (lib "dispatch-lang.ss" "web-server" "dispatchers")) + (prefix stat: (lib "dispatch-stat.ss" "web-server" "dispatchers"))) (define server-root-path (make-parameter (collection-path "web-server" "default-web-root"))) (define port (make-parameter 8080)) @@ -38,10 +39,13 @@ (fsmap:make-url->path (build-path (server-root-path) "htdocs"))) + (define gc-thread (stat:make-gc-thread 30)) + (serve #:port (port) #:dispatch - (sequencer:make + (sequencer:make (timeout:make (* 5 60)) + (stat:make) (filter:make #rx"\\.ss" (lang:make #:url->path (fsmap:make-url->valid-path url->path) diff --git a/collects/web-server/tests/dispatchers/dispatch-lang-test.ss b/collects/web-server/tests/dispatchers/dispatch-lang-test.ss index ba832841e7..9e98ab0bbd 100644 --- a/collects/web-server/tests/dispatchers/dispatch-lang-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-lang-test.ss @@ -11,7 +11,7 @@ (provide dispatch-lang-tests) (define (mkd p) - (lang:make #:url->path (lambda _ (values p url0s)) + (lang:make #:url->path (lambda _ (values p (list p))) #:make-servlet-namespace (make-make-servlet-namespace) #:responders-servlet-loading @@ -23,7 +23,6 @@ ((error-display-handler) (exn-message exn) exn) (raise exn)))) (define url0 "http://test.com/servlets/example.ss") - (define url0s (list (build-path "servlets") (build-path "example.ss"))) (define example-servlets (build-path (collection-path "web-server") "default-web-root" "htdocs" "lang-servlets/")) diff --git a/collects/web-server/tests/private/session-test.ss b/collects/web-server/tests/private/session-test.ss index e0c9d87316..35c280fee4 100644 --- a/collects/web-server/tests/private/session-test.ss +++ b/collects/web-server/tests/private/session-test.ss @@ -1,10 +1,12 @@ (module session-test mzscheme (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) + (lib "list.ss") (lib "url.ss" "net") (lib "session.ss" "web-server" "private")) (provide session-tests) (define url0 (string->url "http://test.com/foo")) + (define url0ps (list "foo")) (define session-tests (test-suite @@ -12,26 +14,15 @@ (test-case "new-session" - (check-true (session? (new-session (make-custodian) (make-namespace) url0)))) + (check-true (session? (new-session (make-custodian) (make-namespace) url0 url0ps)))) (test-case "lookup-session" - (let ([ses (new-session (make-custodian) (make-namespace) url0)]) - (check-eq? (lookup-session (session-id ses)) + (let ([ses (new-session (make-custodian) (make-namespace) url0 url0ps)]) + (check-eq? (lookup-session url0ps) ses))) (test-case "lookup-session (fail)" - (let ([ses (new-session (make-custodian) (make-namespace) url0)]) - (check-false (lookup-session (* 100 (session-id ses))) - ses))) - - (test-case - "extract-session" - (let ([ses (new-session (make-custodian) (make-namespace) url0)]) - (check-equal? (extract-session (session-url ses)) - (session-id ses)))) - - (test-case - "extract-session (fail)" - (check-false (extract-session url0)))))) \ No newline at end of file + (let ([ses (new-session (make-custodian) (make-namespace) url0 url0ps)]) + (check-false (lookup-session empty))))))) \ No newline at end of file diff --git a/collects/web-server/tests/util.ss b/collects/web-server/tests/util.ss index dcf8247410..16ff2d8496 100644 --- a/collects/web-server/tests/util.ss +++ b/collects/web-server/tests/util.ss @@ -3,6 +3,7 @@ (only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3)) ssax:xml->sxml) (lib "request-structs.ss" "web-server" "private") + (lib "web-server-structs.ss" "web-server" "private") (lib "url.ss" "net") (lib "pretty.ss") (lib "list.ss") @@ -24,7 +25,8 @@ (define (collect d req) (define-values (c i o) (make-mock-connection #"")) - (d c req) + (parameterize ([current-server-custodian (current-custodian)]) + (d c req)) (redact (get-output-bytes o))) (define (make-mock-connection ib)