diff --git a/collects/web-server/prototype-web-server/run.ss b/collects/web-server/prototype-web-server/run.ss index f34a61ce8a..409911efca 100644 --- a/collects/web-server/prototype-web-server/run.ss +++ b/collects/web-server/prototype-web-server/run.ss @@ -9,7 +9,7 @@ (prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers"))) (require "hardcoded-configuration.ss" (prefix prototype: "server.ss")) - + (define port 8080) (define listen-ip #f) (define max-waiting 40) @@ -17,12 +17,15 @@ (define host-info hardcoded-host) (define dispatch (sequencer:make - (lambda (conn req) - (prototype:dispatch conn req host-info)) + (prototype:make #:servlet-root (paths-servlet (host-paths host-info)) + #:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info)) + #:responders-servlet-loading (responders-servlet-loading (host-responders host-info)) + #:responders-servlet (responders-servlet (host-responders host-info)) + #:responders-file-not-found (responders-file-not-found (host-responders host-info))) (files:make #:htdocs-path (paths-htdocs (host-paths host-info)) - #:mime-types-path (paths-mime-types (host-paths host-info)) - #:indices (host-indices host-info) - #:file-not-found-responder (responders-file-not-found (host-responders host-info))))) + #:mime-types-path (paths-mime-types (host-paths host-info)) + #:indices (host-indices host-info) + #:file-not-found-responder (responders-file-not-found (host-responders host-info))))) (define-values/invoke-unit dispatch-server@ diff --git a/collects/web-server/prototype-web-server/server.ss b/collects/web-server/prototype-web-server/server.ss index 643bf8b958..dc1902b3a9 100644 --- a/collects/web-server/prototype-web-server/server.ss +++ b/collects/web-server/prototype-web-server/server.ss @@ -1,13 +1,14 @@ (module server mzscheme - (require (lib "connection-manager.ss" "web-server" "private") + (require (lib "kw.ss") + "../private/configuration.ss" + (lib "connection-manager.ss" "web-server" "private") (lib "response.ss" "web-server") (lib "servlet-helpers.ss" "web-server" "private") (lib "response.ss" "web-server" "private") (lib "util.ss" "web-server" "private") (lib "url.ss" "net") (lib "list.ss") - (lib "plt-match.ss") - (lib "configuration-structures.ss" "web-server" "private") + (lib "plt-match.ss") (lib "dispatch.ss" "web-server" "dispatchers") (lib "session.ss" "web-server" "prototype-web-server") (only (lib "abort-resume.ss" "web-server" "prototype-web-server") @@ -18,7 +19,7 @@ "xexpr-extras.ss" "utils.ss") - (provide dispatch) + (provide make) (define myprint printf #;(lambda _ (void))) @@ -26,174 +27,181 @@ (define-struct connection-state (conn req)) (define top-cust (current-custodian)) - ;; ************************************************************ - ;; dispatch: connection request host -> void - ;; trivial dispatcher - (define (dispatch conn req host-info) - (define-values (uri method path) (decompose-request req)) - (myprint "dispatch~n") - (if (regexp-match #rx"^/servlets" path) - (begin - (adjust-connection-timeout! - conn - (timeouts-servlet-connection (host-timeouts host-info))) - ;; more here - make timeouts proportional to size of bindings - (servlet-content-producer conn req host-info)) - (next-dispatcher))) - - ;; ************************************************************ - ;; ************************************************************ - ;; SERVING SERVLETS - - ;; servlet-content-producer: connection request host -> void - (define (servlet-content-producer conn req host-info) - (myprint "servlet-content-producer~n") - (let ([meth (request-method req)]) - (if (eq? meth 'head) - (output-response/method - conn - (make-response/full - 200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE - '() (list "ignored")) - meth) - (let ([uri (request-uri req)]) - (thread-cell-set! thread-connection-state - (make-connection-state conn req)) - (with-handlers ([void - (lambda (the-exn) - (output-response/method - (connection-state-conn (thread-cell-ref thread-connection-state)) - ((responders-servlet-loading (host-responders host-info)) - uri the-exn) - (request-method - (connection-state-req - (thread-cell-ref thread-connection-state)))))]) - (cond - [(resume-session? uri) - => (lambda (session-id) - (resume-session session-id host-info))] - [else - (begin-session host-info)])))))) - - ;; Parameter Parsing - - ;; encodes a simple number: - (define URL-PARAMS:REGEXP (regexp "([0-9]+)")) - - (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x)) - - ;; resume-session? url -> (union number #f) - ;; Determine if the url encodes a session-id and extract it - (define (resume-session? a-url) - (myprint "resume-session?: url-string = ~s~n" (url->string a-url)) - (let ([k-params (filter match-url-params - (apply append - (map path/param-param (url-path a-url))))]) - (myprint "resume-session?: ~S~n" k-params) - (if (empty? k-params) - #f - (match (match-url-params (first k-params)) - [(list _ n) - (myprint "resume-session?: Found ~a~n" n) - (string->number n)] - [_ - #f])))) - - ;; url->param: url -> (union string #f) - (define (url->param a-url) - (let ([l (filter path/param? (url-path a-url))]) - (and (not (null? l)) - (path/param-param (car l))))) - - ;(resume-session? (string->url "http://localhost:9000/;123")) - ;(resume-session? (string->url "http://localhost:9000/;foo")) - ;(resume-session? (string->url "http://localhost:9000/foo/bar")) - - ;; ************************************************************ - - ;; begin-session: connection request host-info - (define (begin-session host-info) - (myprint "begin-session~n") - (let ([uri (request-uri (connection-state-req (thread-cell-ref thread-connection-state)))]) - (let-values ([(a-path url-servlet-path url-path-suffix) - (url->servlet-path - (paths-servlet (host-paths host-info)) - uri)]) - (myprint "a-path = ~s~n" a-path) - (if a-path - (parameterize ([current-directory (directory-part a-path)]) - (let* ([cust (make-custodian top-cust)] - [ns (make-servlet-namespace)] - [ses (new-session cust ns (make-session-url uri url-servlet-path) a-path)]) - (parameterize ([current-custodian cust] - [current-namespace ns] - [current-session ses]) - (let* ([module-name `(file ,(path->string a-path))]) - (myprint "dynamic-require ...~n") - (with-handlers ([exn:fail:contract? - (lambda _ - (dynamic-require module-name #f))]) - (let ([start (dynamic-require module-name 'start)]) - (run-start start-servlet start))))) - (myprint "resume-session~n") - (resume-session (session-id ses) host-info))) + (define/kw (make #:key + [servlet-root "servlets"] + [timeouts-servlet-connection (* 60 60 24)] + [responders-servlet-loading + servlet-loading-responder] + [responders-servlet + (gen-servlet-responder "servlet-error.html")] + [responders-file-not-found + (gen-file-not-found-responder "not-found.html")]) + + ;; ************************************************************ + ;; dispatch: connection request host -> void + ;; trivial dispatcher + (define (dispatch conn req) + (define-values (uri method path) (decompose-request req)) + (myprint "dispatch~n") + (if (regexp-match #rx"^/servlets" path) + (begin + (adjust-connection-timeout! conn timeouts-servlet-connection) + ;; more here - make timeouts proportional to size of bindings + (servlet-content-producer conn req)) + (next-dispatcher))) + + ;; ************************************************************ + ;; ************************************************************ + ;; SERVING SERVLETS + + ;; servlet-content-producer: connection request host -> void + (define (servlet-content-producer conn req) + (myprint "servlet-content-producer~n") + (let ([meth (request-method req)]) + (if (eq? meth 'head) (output-response/method - (connection-state-conn (thread-cell-ref thread-connection-state)) - ((responders-file-not-found (host-responders host-info)) uri) - (request-method (connection-state-req (thread-cell-ref thread-connection-state)))))))) - - (define to-be-copied-module-specs - '(mzscheme - (lib "web-cells.ss" "web-server" "prototype-web-server" "newcont") - (lib "abort-resume.ss" "web-server" "prototype-web-server") - (lib "session.ss" "web-server" "prototype-web-server") - (lib "request.ss" "web-server" "private"))) - - ;; get the names of those modules. - (define to-be-copied-module-names - (let ([get-name - (lambda (spec) - (if (symbol? spec) - spec - ((current-module-name-resolver) spec #f #f)))]) - (map get-name to-be-copied-module-specs))) - - (define (make-servlet-namespace) - (let ([server-namespace (current-namespace)] - [new-namespace (make-namespace)]) - (parameterize ([current-namespace new-namespace]) - (for-each (lambda (name) (namespace-attach-module server-namespace name)) - to-be-copied-module-names) - new-namespace))) - - ;; ************************************************************ - ;; resume-session: connection request number host-info - (define (resume-session ses-id host-info) - ; XXX Check if session is for same servlet! - (myprint "resume-session: ses-id = ~s~n" ses-id) - (cond - [(lookup-session ses-id) - => (lambda (ses) - (parameterize ([current-custodian (session-cust ses)] - [current-session ses]) + conn + (make-response/full + 200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE + '() (list "ignored")) + meth) + (let ([uri (request-uri req)]) + (thread-cell-set! thread-connection-state + (make-connection-state conn req)) (with-handlers ([void (lambda (the-exn) (output-response/method (connection-state-conn (thread-cell-ref thread-connection-state)) - ((responders-servlet (host-responders host-info)) - (request-uri - (connection-state-req - (thread-cell-ref thread-connection-state))) - the-exn) + (responders-servlet-loading uri the-exn) (request-method - (connection-state-req (thread-cell-ref thread-connection-state)))))]) - (printf "session-handler ~S~n" (session-handler ses)) - (output-response - (connection-state-conn (thread-cell-ref thread-connection-state)) - (xexpr+extras->xexpr - ((session-handler ses) - (connection-state-req (thread-cell-ref thread-connection-state))))))))] - [else - (myprint "resume-session: Unknown ses~n") - ;; TODO: should just start a new session here. - (begin-session host-info)]))) \ No newline at end of file + (connection-state-req + (thread-cell-ref thread-connection-state)))))]) + (cond + [(resume-session? uri) + => (lambda (session-id) + (resume-session session-id))] + [else + (begin-session)])))))) + + ;; Parameter Parsing + + ;; encodes a simple number: + (define URL-PARAMS:REGEXP (regexp "([0-9]+)")) + + (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x)) + + ;; resume-session? url -> (union number #f) + ;; Determine if the url encodes a session-id and extract it + (define (resume-session? a-url) + (myprint "resume-session?: url-string = ~s~n" (url->string a-url)) + (let ([k-params (filter match-url-params + (apply append + (map path/param-param (url-path a-url))))]) + (myprint "resume-session?: ~S~n" k-params) + (if (empty? k-params) + #f + (match (match-url-params (first k-params)) + [(list _ n) + (myprint "resume-session?: Found ~a~n" n) + (string->number n)] + [_ + #f])))) + + ;; url->param: url -> (union string #f) + (define (url->param a-url) + (let ([l (filter path/param? (url-path a-url))]) + (and (not (null? l)) + (path/param-param (car l))))) + + ;(resume-session? (string->url "http://localhost:9000/;123")) + ;(resume-session? (string->url "http://localhost:9000/;foo")) + ;(resume-session? (string->url "http://localhost:9000/foo/bar")) + + ;; ************************************************************ + + ;; begin-session: connection request host-info + (define (begin-session) + (myprint "begin-session~n") + (let ([uri (request-uri (connection-state-req (thread-cell-ref thread-connection-state)))]) + (let-values ([(a-path url-servlet-path url-path-suffix) + (url->servlet-path servlet-root uri)]) + (myprint "a-path = ~s~n" a-path) + (if a-path + (parameterize ([current-directory (directory-part a-path)]) + (let* ([cust (make-custodian top-cust)] + [ns (make-servlet-namespace)] + [ses (new-session cust ns (make-session-url uri url-servlet-path) a-path)]) + (parameterize ([current-custodian cust] + [current-namespace ns] + [current-session ses]) + (let* ([module-name `(file ,(path->string a-path))]) + (myprint "dynamic-require ...~n") + (with-handlers ([exn:fail:contract? + (lambda _ + (dynamic-require module-name #f))]) + (let ([start (dynamic-require module-name 'start)]) + (run-start start-servlet start))))) + (myprint "resume-session~n") + (resume-session (session-id ses)))) + (output-response/method + (connection-state-conn (thread-cell-ref thread-connection-state)) + (responders-file-not-found uri) + (request-method (connection-state-req (thread-cell-ref thread-connection-state)))))))) + + (define to-be-copied-module-specs + '(mzscheme + (lib "web-cells.ss" "web-server" "prototype-web-server" "newcont") + (lib "abort-resume.ss" "web-server" "prototype-web-server") + (lib "session.ss" "web-server" "prototype-web-server") + (lib "request.ss" "web-server" "private"))) + + ;; get the names of those modules. + (define to-be-copied-module-names + (let ([get-name + (lambda (spec) + (if (symbol? spec) + spec + ((current-module-name-resolver) spec #f #f)))]) + (map get-name to-be-copied-module-specs))) + + (define (make-servlet-namespace) + (let ([server-namespace (current-namespace)] + [new-namespace (make-namespace)]) + (parameterize ([current-namespace new-namespace]) + (for-each (lambda (name) (namespace-attach-module server-namespace name)) + to-be-copied-module-names) + new-namespace))) + + ;; ************************************************************ + ;; resume-session: connection request number host-info + (define (resume-session ses-id) + ; XXX Check if session is for same servlet! + (myprint "resume-session: ses-id = ~s~n" ses-id) + (cond + [(lookup-session ses-id) + => (lambda (ses) + (parameterize ([current-custodian (session-cust ses)] + [current-session ses]) + (with-handlers ([void + (lambda (the-exn) + (output-response/method + (connection-state-conn (thread-cell-ref thread-connection-state)) + (responders-servlet + (request-uri + (connection-state-req + (thread-cell-ref thread-connection-state))) + the-exn) + (request-method + (connection-state-req (thread-cell-ref thread-connection-state)))))]) + (printf "session-handler ~S~n" (session-handler ses)) + (output-response + (connection-state-conn (thread-cell-ref thread-connection-state)) + (xexpr+extras->xexpr + ((session-handler ses) + (connection-state-req (thread-cell-ref thread-connection-state))))))))] + [else + (myprint "resume-session: Unknown ses~n") + ;; TODO: should just start a new session here. + (begin-session)])) + + dispatch)) \ No newline at end of file