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

Improving performance of lang servlets

Browse Source 
svn: r6774
This commit is contained in:
Jay McCarthy 2007-06-29 21:46:27 +00:00
parent 0214f207e7
commit a039d7deeb
8 changed files with 140 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

115
collects/web-server/dispatchers/dispatch-lang.ss
View File

@ -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))

32
collects/web-server/dispatchers/dispatch-stat.ss Normal file
View File

@ -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)))

16
collects/web-server/docs/reference/dispatchers.scrbl
View File

@ -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.
}

77
collects/web-server/private/session.ss
View File

@ -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))))
;; 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)))))))

8
collects/web-server/run.ss
View File

@ -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)

3
collects/web-server/tests/dispatchers/dispatch-lang-test.ss
View File

@ -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/"))

23
collects/web-server/tests/private/session-test.ss
View File

@ -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))))))
(let ([ses (new-session (make-custodian) (make-namespace) url0 url0ps)])
(check-false (lookup-session empty)))))))

4
collects/web-server/tests/util.ss
View File

@ -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)