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

Abstracting url->path process, streamlining such, decoupling parts of api, i.e., no more GETs necessary for servlet refresh, etc

Browse Source 
svn: r6430
This commit is contained in:
Jay McCarthy 2007-06-01 01:47:31 +00:00
parent fcaa2fb5b5
commit a921007b32
17 changed files with 271 additions and 376 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/web-server/configuration/configuration-table-structs.ss
View File

@ -1,7 +1,8 @@
(module configuration-table-structs mzscheme
(require (lib "contract.ss")
(lib "url.ss" "net"))
(require "../response-structs.ss")
(require "../response-structs.ss"
"../request-structs.ss")
; configuration-table = (make-configuration-table nat nat num host-table (listof (cons str host-table)))
(define-struct configuration-table
@ -52,7 +53,7 @@
[authentication (url? (cons/c symbol? string?) . -> . response?)]
[servlets-refreshed (-> response?)]
[passwords-refreshed (-> response?)]
[file-not-found (url? . -> . response?)]
[file-not-found (request? . -> . response?)]
[protocol (url? . -> . response?)]
[collect-garbage (-> response?)])]
[struct messages

16
collects/web-server/configuration/responders.ss
View File

@ -1,10 +1,11 @@
(module responders mzscheme
(require (lib "contract.ss")
(lib "url.ss" "net"))
(require "../response-structs.ss")
(require "../response-structs.ss"
"../request-structs.ss")
; error-response : nat str str [(cons sym str) ...] -> response
; more here - cache files with a refresh option.
; XXX - cache files with a refresh option.
; The server should still start without the files there, so the
; configuration tool still runs. (Alternatively, find an work around.)
(define (error-response code short text-file . extra-headers)
@ -14,7 +15,6 @@
(list (read-file text-file))))
; servlet-loading-responder : url tst -> response
; more here - parameterize error based on a configurable file, perhaps?
; This is slightly tricky since the (interesting) content comes from the exception.
(define (servlet-loading-responder url exn)
((error-display-handler)
@ -61,9 +61,9 @@
(lambda (error-message)
(error-response 400 "Malformed Request" protocol-file)))
; gen-file-not-found-responder : str -> url -> response
; gen-file-not-found-responder : str -> req -> response
(define (gen-file-not-found-responder file-not-found-file)
(lambda (url)
(lambda (req)
(error-response 404 "File not found" file-not-found-file)))
; gen-collect-garbage-responder : str -> -> response
@ -78,12 +78,12 @@
(provide/contract
[error-response ((natural-number/c string? string?) (listof (cons/c symbol? string?)) . ->* . (response?))]
[servlet-loading-responder (string? any/c . -> . response?)]
[servlet-loading-responder (url? any/c . -> . response?)]
[gen-servlet-not-found (path-string? . -> . (url? . -> . response?))]
[gen-servlet-responder (path-string? . -> . (url? any/c . -> . response?))]
[gen-servlets-refreshed (path-string? . -> . (-> response?))]
[gen-passwords-refreshed (path-string? . -> . (-> response?))]
[gen-authentication-responder (path-string? . -> . (url? (cons/c symbol? string?) . -> . response?))]
[gen-protocol-responder (path-string? . -> . (string? . -> . response?))]
[gen-file-not-found-responder (path-string? . -> . (url? . -> . response?))]
[gen-protocol-responder (path-string? . -> . (url? . -> . response?))]
[gen-file-not-found-responder (path-string? . -> . (request? . -> . response?))]
[gen-collect-garbage-responder (path-string? . -> . (-> response?))]))

16
collects/web-server/dispatchers/dispatch-const.ss Normal file
View File

@ -0,0 +1,16 @@
(module dispatch-const mzscheme
(require (lib "contract.ss"))
(require "dispatch.ss"
"../private/response.ss"
"../request-structs.ss"
"../response-structs.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[make ((request? . -> . response?) . -> . dispatcher?)])
(define interface-version 'v1)
(define ((make procedure) conn req)
(output-response/method
conn
(procedure req)
(request-method req))))

90
collects/web-server/dispatchers/dispatch-files.ss
View File

@ -1,9 +1,6 @@
(module dispatch-files mzscheme
(require (lib "url.ss" "net")
(lib "xml.ss" "xml")
(lib "kw.ss")
(lib "list.ss")
(lib "string.ss")
(lib "plt-match.ss")
(lib "contract.ss"))
(require "dispatch.ss"
@ -11,47 +8,26 @@
"../private/util.ss"
"../private/mime-types.ss"
"../request-structs.ss"
"../private/response.ss"
"../response-structs.ss")
"../private/response.ss")
(provide/contract
[interface-version dispatcher-interface-version?])
(provide make)
; more here - ".." should probably raise an error instead of disappearing.
(define (url-path->path base p)
(path->complete-path
(apply build-path base
(reverse!
(foldl (lambda (x acc)
(cond
[(string=? x "") acc]
[(string=? x ".") acc]
[(string=? x "..") (if (pair? acc) (cdr acc) acc)]
[else (cons x acc)]))
null
(regexp-split #rx"/" p))))))
;; looks-like-directory : str -> bool
;; to determine if is url style path looks like it refers to a directory
(define (looks-like-directory? path)
(eq? #\/ (string-ref path (sub1 (string-length path)))))
(define interface-version 'v1)
(define/kw (make #:key
[htdocs-path "htdocs"]
url->path
[mime-types-path "mime.types"]
[indices (list "index.html" "index.htm")]
[file-not-found-responder
(gen-file-not-found-responder "not-found.html")])
[indices (list "index.html" "index.htm")])
(define get-mime-type (make-get-mime-type mime-types-path))
(lambda (conn req)
(define uri (request-uri req))
(define method (request-method req))
;; ************************************************************
;; ************************************************************
;; SERVING FILES
;; serve-file : connection symbol uri host -> void
;; to find the file, including searching for implicit index files, and serve it out
(define path
; XXX Abstract this
(url-path->path htdocs-path
(url-path->string (url-path uri))))
(define-values (path _) (url->path uri))
(cond
[(file-exists? path)
(match (headers-assq* #"Range" (request-headers/raw req))
@ -74,43 +50,13 @@
; XXX: Unhandled range: r
(output-file conn path method (get-mime-type path))])])]
[(directory-exists? path)
(let loop ([dir-defaults indices])
(cond
[(pair? dir-defaults)
(let ([full-name (build-path path (first dir-defaults))])
(if (file-exists? full-name)
(cond
[(looks-like-directory? (url-path->string (url-path uri)))
(output-file conn full-name method (get-mime-type full-name))]
[else
(output-slash-message conn method (url-path->string (url-path uri)))])
(loop (rest dir-defaults))))]
[else
(output-response/method conn (file-not-found-responder uri) method)]))]
(let/ec esc
(for-each (lambda (dir-default)
(define full-name (build-path path dir-default))
(when (and (file-exists? full-name)
(looks-like-directory? (url-path->string (url-path uri))))
(esc (output-file conn full-name method (get-mime-type full-name)))))
indices)
(next-dispatcher))]
[else
(output-response/method conn (file-not-found-responder uri) method)])))
;; looks-like-directory : str -> bool
;; to determine if is url style path looks like it refers to a directory
(define (looks-like-directory? path)
(eq? #\/ (string-ref path (sub1 (string-length path)))))
;; output-slash-message: connection symbol string -> void
;; basically this is just a special error response
(define (output-slash-message conn method url-path-str)
(output-response/method
conn
(make-response/full
301 "Moved Permanently"
(current-seconds)
TEXT/HTML-MIME-TYPE
`([Location . ,(string-append url-path-str "/")])
(list
(xexpr->string
`(html
(head (title "Add a Slash"))
(body "Please use "
(a ([href ,(string-append
url-path-str "/")])
"this url") " instead.")))))
method)))
(next-dispatcher)]))))

1
collects/web-server/dispatchers/dispatch-filter.ss
View File

@ -11,6 +11,7 @@
(define interface-version 'v1)
(define ((make regex inner) conn req)
(define path (url-path->string (url-path (request-uri req))))
#;(printf "~S~n" `(filter ,regex ,(url->string (request-uri req)) ,path ,(regexp-match regex path)))
(if (regexp-match regex path)
(inner conn req)
(next-dispatcher))))

20
collects/web-server/dispatchers/dispatch-passwords.ss
View File

@ -18,9 +18,7 @@
[password-file "passwords"]
[password-connection-timeout 300]
[authentication-responder
(gen-authentication-responder "forbidden.html")]
[passwords-refresh-responder
(gen-passwords-refreshed "passwords-refresh.html")])
(gen-authentication-responder "forbidden.html")])
(define last-read-time (box #f))
(define password-cache (box #f))
(define (update-password-cache!)
@ -30,12 +28,11 @@
(cur-mtime . > . (unbox last-read-time))
(not (unbox password-cache)))
(set-box! last-read-time cur-mtime)
; more here - a malformed password file will kill the connection
(set-box! password-cache (read-passwords password-file))))))
(define (read-password-cache)
(update-password-cache!)
(unbox password-cache))
(lambda (conn req)
(define (dispatch conn req)
(define uri (request-uri req))
(define path (url-path->string (url-path uri)))
(define method (request-method req))
@ -48,15 +45,10 @@
(request-authentication conn method uri
authentication-responder
realm))]
[(string=? "/conf/refresh-passwords" path)
;; more here - send a nice error page
(update-password-cache!)
(output-response/method
conn
(passwords-refresh-responder)
method)]
[else
(next-dispatcher)])))
(next-dispatcher)]))
(values update-password-cache!
dispatch))
;; ****************************************
;; ****************************************
@ -133,4 +125,4 @@
(authentication-responder
uri
`(WWW-Authenticate . ,(format " Basic realm=\"~a\"" realm)))
method)))
method)))

4
collects/web-server/dispatchers/dispatch-pathprocedure.ss
View File

@ -8,7 +8,7 @@
"../response-structs.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[make (string? (-> response?) . -> . dispatcher?)])
[make (string? (request? . -> . response?) . -> . dispatcher?)])
(define interface-version 'v1)
(define ((make the-path procedure) conn req)
@ -16,6 +16,6 @@
(if (string=? the-path path)
(output-response/method
conn
(procedure)
(procedure req)
(request-method req))
(next-dispatcher))))

9
collects/web-server/dispatchers/dispatch-sequencer.ss
View File

@ -9,7 +9,8 @@
(define interface-version 'v1)
(define ((make . dispatchers) conn req)
(let loop ([dispatchers dispatchers])
(let ([c (first dispatchers)])
(with-handlers ([exn:dispatcher?
(lambda (e) (loop (rest dispatchers)))])
(c conn req))))))
(if (empty? dispatchers)
(next-dispatcher)
(with-handlers ([exn:dispatcher?
(lambda (e) (loop (rest dispatchers)))])
((first dispatchers) conn req))))))

101
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -1,8 +1,6 @@
(module dispatch-servlets mzscheme
(require (lib "url.ss" "net")
(lib "kw.ss")
(require (lib "kw.ss")
(lib "plt-match.ss")
(lib "string.ss")
(lib "contract.ss"))
(require "dispatch.ss"
"../private/web-server-structs.ss"
@ -14,7 +12,6 @@
"../servlet/web-cells.ss"
"../servlet/web.ss"
"../configuration/responders.ss"
"../private/util.ss"
"../managers/manager.ss"
"../managers/timeouts.ss"
"../managers/lru.ss"
@ -25,46 +22,14 @@
[interface-version dispatcher-interface-version?])
(provide make)
(define (url-path->path base p)
(path->complete-path
(let ([path-elems (regexp-split #rx"/" p)])
;; Servlets can have extra stuff after them
(let ([build-path
(lambda (b p)
(if (string=? p "")
b
(build-path b p)))])
(let loop
([p-e (if (string=? (car path-elems) "")
(cddr path-elems)
(cdr path-elems))]
[f (build-path base
(if (string=? (car path-elems) "")
(cadr path-elems)
(car path-elems)))])
(cond
[(null? p-e)
f]
[(directory-exists? f)
(loop (cdr p-e) (build-path f (car p-e)))]
[(file-exists? f)
f]
[else
;; Don't worry about e.g. links for now
f]))))))
(define interface-version 'v1)
(define/kw (make config:instances config:scripts config:make-servlet-namespace
#:key
[servlet-root "servlets"]
[responders-servlets-refreshed
(gen-servlets-refreshed "servlet-refresh.html")]
url->path
[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")]
[timeouts-servlet-connection (* 60 60 24)]
[timeouts-default-servlet 30])
;; ************************************************************
@ -75,6 +40,10 @@
(define (servlet-content-producer conn req)
(define meth (request-method req))
(define uri (request-uri req))
;; XXX - make timeouts proportional to size of bindings
(adjust-connection-timeout!
conn
timeouts-servlet-connection)
(case meth
[(head)
(output-response/method
@ -99,7 +68,7 @@
(with-handlers (;; couldn't find the servlet
[exn:fail:filesystem:exists:servlet?
(lambda (the-exn)
(output-response/method conn (responders-file-not-found (request-uri req)) (request-method req)))]
(next-dispatcher))]
;; servlet won't load (e.g. syntax error)
[(lambda (x) #t)
(lambda (the-exn)
@ -110,16 +79,13 @@
; Create the session frame
(with-frame
(define instance-custodian (make-servlet-custodian))
(define servlet-path
(define-values (servlet-path _)
(with-handlers
([void (lambda (e)
(raise (make-exn:fail:filesystem:exists:servlet
(exn-message e)
(exn-continuation-marks e))))])
; XXX Abstract this
(url-path->path
servlet-root
(url-path->string (url-path uri)))))
(url->path uri)))
(parameterize ([current-directory (get-servlet-base-dir servlet-path)]
[current-custodian instance-custodian]
[exit-handler
@ -157,14 +123,6 @@
(the-exit-handler x))])
(with-handlers ([(lambda (x) #t)
(make-servlet-exception-handler)])
;; Two possibilities:
;; - module servlet. start : Request -> Void handles
;; output-response via send/finish, etc.
;; - unit/sig or simple xexpr servlet. These must produce a
;; response, which is then output by the server.
;; Here, we do not know if the servlet was a module,
;; unit/sig, or Xexpr; we do know whether it produces a
;; response.
(send/back ((servlet-handler the-servlet) req)))
((manager-instance-unlock! manager) instance-id))))))))
(output-response conn response)
@ -175,8 +133,7 @@
;; default-server-instance-expiration-handler : (request -> response)
(define (default-servlet-instance-expiration-handler req)
(responders-file-not-found
(request-uri req)))
(next-dispatcher))
;; make-servlet-exception-handler: servlet-instance -> exn -> void
;; This exception handler traps all unhandled servlet exceptions
@ -214,10 +171,7 @@
;; pull the continuation out of the table and apply it
(define (invoke-servlet-continuation conn req instance-id k-id salt)
(define uri (request-uri req))
(define servlet-path
(url-path->path
servlet-root
(url-path->string (url-path uri))))
(define-values (servlet-path _) (url->path uri))
(define the-servlet (cached-load servlet-path))
(define manager (servlet-manager the-servlet))
(thread-cell-set! current-servlet the-servlet)
@ -267,10 +221,6 @@
(thread-cell-set! current-servlet-instance-id #f)
(thread-cell-set! current-servlet #f))
;; ************************************************************
;; ************************************************************
;; Paul's ugly loading code:
;; cached-load : path -> script, namespace
;; timestamps are no longer checked for performance. The cache must be explicitly
;; refreshed (see dispatch).
@ -304,7 +254,6 @@
;; A servlet-file will contain either
;;;; A signed-unit-servlet
;;;; A module servlet, currently only 'v1
;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.)
;;;; A response
(define (load-servlet/path a-path)
(define (v0.response->v1.lambda response-path response)
@ -376,26 +325,8 @@
[else
(error 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))
(define svt-bin-re (regexp "^/servlets(;.*\\*.*\\*.*)?/.*"))
(define (servlet-bin? str)
(regexp-match svt-bin-re str))
;; return dispatcher
(lambda (conn req)
(define path (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!
(cache-table-clear! (unbox config:scripts))
(output-response/method
conn
(responders-servlets-refreshed)
(request-method req))]
[(servlet-bin? path)
(adjust-connection-timeout!
conn
timeouts-servlet-connection)
;; more here - make timeouts proportional to size of bindings
(servlet-content-producer conn req)]
[else
(next-dispatcher)]))))
(values (lambda ()
;; XXX - this is broken - only out of date or specifically mentioned
;; scripts should be flushed. This destroys persistent state!
(cache-table-clear! (unbox config:scripts)))
servlet-content-producer)))

50
collects/web-server/dispatchers/filesystem-map.ss Normal file
View File

@ -0,0 +1,50 @@
(module filesystem-map mzscheme
(require (lib "url.ss" "net")
(lib "list.ss")
(lib "contract.ss"))
(require "../private/util.ss")
(define url-path?
((url?) . ->* . (path? list?)))
(provide/contract
[make-url->path (path? . -> . url-path?)]
[make-url->path/optimism (url-path? . -> . url-path?)])
(define (build-path* . l)
(if (empty? l)
(build-path 'same)
(apply build-path l)))
(define ((make-url->path base) u)
(define nbase (path->complete-path base))
(define the-path
; Complete it against the base
(path->complete-path
; Build a path
(apply build-path*
; Remove all ".."s
; XXX Should error?
(strip-prefix-ups
(map (lambda (p)
(if (string=? "" p) 'same p))
; Extract the paths from the url-path
(map path/param-path
(url-path u)))))
nbase))
(define w/o-base (path-without-base nbase the-path))
#;(printf "~S~n" `(url->path ,base ,nbase ,(url->string u) ,the-path ,w/o-base))
(values the-path w/o-base))
(define ((make-url->path/optimism url->path) u)
(let loop ([up (url-path u)])
#;(printf "~S~n" `(url->path/optimism ,(url->string u) ,up))
(with-handlers ([exn? (lambda (exn)
#;((error-display-handler) (exn-message exn) exn)
(if (empty? up)
(raise exn)
(loop (reverse (rest (reverse up))))))])
(define-values (p w/o-base)
(url->path (url-replace-path (lambda _ up) u)))
(unless (or (file-exists? p) (link-exists? p))
(raise (make-exn:fail:filesystem:exists (string->immutable-string "No valid path") (current-continuation-marks))))
(values p w/o-base)))))

33
collects/web-server/private/configure.ss
View File

@ -29,7 +29,18 @@
; - change all configuration paths (in the configure servlet and in the server) to
; use a platform independent representation (i.e. a listof strings)
; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
; to convert a platform dependent path into a listof path parts such that
; (forall x (equal? (path->list x) (path->list (apply build-path (path->list x)))))
(define (path->list p)
(let loop ([p p] [acc null])
(let-values ([(base name must-be-dir?) (split-path p)])
(let ([new-acc (cons name acc)])
(cond
[(string? base) (loop base new-acc)]
[else ; conflate 'relative and #f
new-acc])))))
; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
(define build-suspender
(opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])
(lambda (k-url)
@ -41,7 +52,7 @@
(body ,body-attributes
(form ([action ,k-url] [method "post"])
,@content))))))
; write-to-file : str TST -> void
(define (write-to-file file-name x)
(call-with-output-file file-name
@ -96,7 +107,7 @@
(unless (string=? "127.0.0.1" (request-host-ip request))
(send/finish access-error-page))
request)
(define web-base (directory-part default-configuration-path))
; more here - abstract with static pages?
@ -194,14 +205,14 @@
; doesn't work - the browser doesn't send the port and it wouldn't be reliable anyway
; perhaps the server could include it?
#;(define (switch-to-current-port old)
(let ([current-port (url-port (request-uri initial-request))])
(and (not (= current-port (configuration-table-port old)))
(make-configuration-table
current-port
(configuration-table-max-waiting old)
(configuration-table-initial-connection-timeout old)
(configuration-table-default-host old)
(configuration-table-virtual-hosts old)))))
(let ([current-port (url-port (request-uri initial-request))])
(and (not (= current-port (configuration-table-port old)))
(make-configuration-table
current-port
(configuration-table-max-waiting old)
(configuration-table-initial-connection-timeout old)
(configuration-table-default-host old)
(configuration-table-virtual-hosts old)))))
; send-exn : tst -> doesn't
(define (send-exn exn)

1
collects/web-server/private/response.ss
View File

@ -180,6 +180,7 @@
data-length
(response/full-body resp/f))))
; XXX Get rid of method restriction
;; **************************************************
;; output-file: connection path symbol bytes -> void
(define (output-file conn file-path method mime-type)

64
collects/web-server/private/util.ss
View File

@ -1,21 +1,68 @@
(module util mzscheme
(require (lib "list.ss")
(lib "plt-match.ss")
(lib "contract.ss")
(lib "string.ss")
(lib "url.ss" "net"))
(provide
url-replace-path)
(provide/contract
[path-without-base (path? path? . -> . list?)]
[list-prefix (list? list? . -> . (or/c list? false/c))]
[strip-prefix-ups (list? . -> . list?)] ; XXX need path-element?
[url-path->string ((listof (or/c string? path/param?)) . -> . string?)]
[extract-flag (symbol? (listof (cons/c symbol? any/c)) any/c . -> . any/c)]
[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)))))]
[directory-part (path? . -> . path?)]
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
[exn->string ((or/c exn? any/c) . -> . string?)]
[build-path-unless-absolute (path-string? path-string? . -> . path?)])
; explode-path* : path? -> (listof path?)
(define (explode-path* p)
(let loop ([p p] [r empty])
(cond
[(eq? 'relative p) r]
[(not p) r]
[else
(let-values ([(base name dir?) (split-path p)])
(loop base (list* name r)))])))
; strip-prefix-ups : (listof path-element?) -> (listof path-element?)
(define (strip-prefix-ups l)
(define prefix? (box #t))
(filter (lambda (p)
(if (unbox prefix?)
(if (eq? 'up p)
#f
(begin #t
(set-box! prefix? #f)))
#t))
l))
; list-prefix : list? list? -> (or/c list? false/c)
; Is l a prefix or r?, and what is that prefix?
(define (list-prefix ls rs)
(match ls
[(list)
(list)]
[(list-rest l0 ls)
(match rs
[(list)
#f]
[(list-rest r0 rs)
(if (equal? l0 r0)
(let ([ps (list-prefix ls rs)])
(if ps (list* l0 ps) (list l0)))
#f)])]))
; path-without-base : path? path? -> (listof path-element?)
; Expects paths in normal form
(define (path-without-base base path)
(define b (explode-path* base))
(define p (explode-path* path))
(list-tail p (length (list-prefix b p))))
;; 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
@ -86,18 +133,7 @@
[(eq? 'relative base) (current-directory)]
[(not base) (error 'directory-part "~a is a top-level directory" path)]
[(path? base) base])))
; to convert a platform dependent path into a listof path parts such that
; (forall x (equal? (path->list x) (path->list (apply build-path (path->list x)))))
(define (path->list p)
(let loop ([p p] [acc null])
(let-values ([(base name must-be-dir?) (split-path p)])
(let ([new-acc (cons name acc)])
(cond
[(string? base) (loop base new-acc)]
[else ; conflate 'relative and #f
new-acc])))))
; this is used by launchers
; extract-flag : sym (listof (cons sym alpha)) alpha -> alpha
; XXX remove

62
collects/web-server/prototype-web-server/dispatch-servlets2.ss
View File

@ -2,7 +2,6 @@
(require (lib "kw.ss")
(lib "contract.ss")
(lib "url.ss" "net")
(lib "plt-match.ss")
(lib "request-structs.ss" "web-server")
(lib "session.ss" "web-server" "prototype-web-server" "private")
(only "private/web.ss"
@ -24,44 +23,40 @@
(define interface-version 'v1)
(define/kw (make #:key
[htdocs-path "servlets"]
url->path
[make-servlet-namespace
(make-make-servlet-namespace)]
[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")])
(gen-servlet-responder "servlet-error.html")])
;; dispatch : connection request -> void
(define (dispatch conn req)
(define uri (request-uri req))
(adjust-connection-timeout! conn timeouts-servlet-connection)
;; XXX - make timeouts proportional to size of bindings
(with-handlers ([void
(lambda (the-exn)
(output-response/method
conn
(responders-servlet-loading uri the-exn)
(request-method req)))])
(cond
[(extract-session uri)
=> (lambda (session-id)
(resume-session session-id conn req))]
[else
(begin-session conn 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
;; begin-session: connection request
(define (begin-session conn req)
(define uri (request-uri req))
(define-values (a-path url-servlet-path url-path-suffix)
; XXX Abstract this, so they don't need to live on disk.
(url->servlet-path htdocs-path uri))
(if a-path
(with-handlers ([void (lambda (exn) (next-dispatcher))])
(define-values (a-path url-servlet-path) (url->path uri))
(with-handlers ([void
(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
@ -71,7 +66,7 @@
(lib "abort-resume.ss" "web-server" "prototype-web-server" "private")
(lib "session.ss" "web-server" "prototype-web-server" "private")
(lib "request.ss" "web-server" "private"))))
(define ses (new-session cust ns (make-session-url uri url-servlet-path)))
(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])
@ -80,33 +75,16 @@
'start))
(set-session-servlet! ses (initialize-servlet start)))
(resume-session (session-id ses)
conn req))
(output-response/method
conn
(responders-file-not-found uri)
(request-method req))))
conn req)))))
; same-servlet? : url? url? -> boolean?
(define (same-servlet? req ses)
(define (abstract-url u)
(map path/param-path
(url-path u)))
(define ans
(let loop ([rp (abstract-url req)]
[sp (abstract-url ses)])
(match sp
[(list)
#t]
[(list-rest s sp)
(match rp
[(list)
#f]
[(list-rest r rp)
(if (string=? s r)
(loop rp sp)
#f)])])))
(define ans (list-prefix (abstract-url ses) (abstract-url req)))
#;(printf "~S => ~S~n" `(same-servlet? ,(url->string req) ,(url->string ses)) ans)
ans)
(and ans #t))
;; resume-session: number connection request
(define (resume-session ses-id conn req)

94
collects/web-server/prototype-web-server/private/utils.ss
View File

@ -1,16 +1,13 @@
(module utils mzscheme
(require (lib "contract.ss")
(lib "url.ss" "net")
(lib "plt-match.ss")
(lib "list.ss")
(lib "serialize.ss"))
(provide/contract
[read/string (string? . -> . serializable?)]
[write/string (serializable? . -> . string?)]
[url->servlet-path ((path? url?) . ->* . ((or/c path? false/c) (or/c (listof string?) false/c) (or/c (listof string?) false/c)))]
[make-session-url (url? (listof string?) . -> . url?)]
[split-url-path (url? url? . -> . (or/c (listof string?) false/c))])
[make-session-url (url? (listof string?) . -> . url?)])
(define (read/string str)
(read (open-input-string str)))
@ -35,91 +32,4 @@
new-path)
'()
#f
))
;; build-root-path: -> path
;; build the root path for whatever this OS is
(define (build-root-path)
(let loop ([prev (simplify-path (build-path 'same))]
[next (simplify-path (build-path 'up))])
(if (equal? prev next)
prev
(loop next
(simplify-path (build-path next 'up))))))
(define the-root-path (build-root-path))
;; simplify-url-path: url -> (listof string)
;; take the dots out of the url-path
;; Note: we simplify the url path relative to a hypothetical root,
;; so that a malicious url can't cause the server to chase ".."
;; up beyond the legitimate servlet root.
(define (simplify-url-path uri)
(path->list
(simplify-path
(apply build-path
(cons the-root-path
(map
(lambda (str)
(if (string=? str "")
'same
str))
(map
(lambda (path-elt)
(if (path/param? path-elt)
(path/param-path path-elt)
path-elt))
(url-path uri))))))))
;; path->list pth
;; convert an absolute path to a list of strings
(define (path->list pth)
(reverse
(let path->list ([pth pth])
(let-values ([(base name must-be-dir?) (split-path pth)])
(if base
(cons (path->string name) (path->list base))
'())))))
;; url->servlet-path: path url -> (values (union path #f)
;; (union (listof url->string) #f)
;; (union (listof string) #f))
;; Given a servlet directory and url, find a servlet.
;; The first value is the servlet path.
;; The second value is the prefix of the url-path used to find the servlet.
;; The third value is the remaining suffix of the url-path.
(define (url->servlet-path servlet-dir uri)
#;(printf "~S~n" `(url->servlet-path ,servlet-dir ,uri))
#;(printf " current-directory = ~s~n" (current-directory))
(let loop ([base-path servlet-dir]
[servlet-path '()]
[path-list (simplify-url-path uri)])
#;(printf "~S~n" `(loop ,base-path ,servlet-path ,path-list))
(match path-list
[(list)
(values #f #f #f)]
[(list-rest next-path-segment rest-of-path)
(let ([new-base (build-path base-path next-path-segment)])
#;(printf " new-base = ~s~n" new-base)
(cond
[(file-exists? new-base)
(values new-base
(reverse (list* next-path-segment servlet-path))
rest-of-path)]
[else (loop new-base
(list* next-path-segment servlet-path)
rest-of-path)]))])))
;; split-url-path: url url -> (union (listof string) #f)
;; the first url's path is a prefix of the path of the second
;; find the suffix and return it as a list of strings
(define (split-url-path pref-url suff-url)
(let loop ([pref-path (simplify-url-path pref-url)]
[suff-path (simplify-url-path suff-url)])
(cond
[(null? pref-path) suff-path]
[(string=? (car pref-path) (car suff-path))
(loop (cdr pref-path) (cdr suff-path))]
[else
(error "split-url-path: first path is not a preffix of the second")]))))
)))

20
collects/web-server/prototype-web-server/run.ss
View File

@ -1,30 +1,34 @@
(module run mzscheme
(require (lib "web-server.ss" "web-server")
(lib "responders.ss" "web-server" "configuration")
(prefix fsmap: (lib "filesystem-map.ss" "web-server" "dispatchers"))
(prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers"))
(prefix filter: (lib "dispatch-filter.ss" "web-server" "dispatchers"))
(prefix const: (lib "dispatch-const.ss" "web-server" "dispatchers"))
(prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers"))
(prefix servlets2: (lib "dispatch-servlets2.ss" "web-server" "prototype-web-server")))
(define server-root-path (build-path "~" "Development" "plt" "default-web-root"))
(define default-host-path (build-path server-root-path "conf"))
(define htdocs-path (build-path server-root-path "htdocs"))
(define file-not-found-file (build-path default-host-path "not-found.html"))
(define servlet-error-file (build-path default-host-path "servlet-error.html"))
(define url->path
(fsmap:make-url->path
(build-path server-root-path "htdocs")))
(serve
#:port 8080
#:dispatch (sequencer:make
(filter:make
#rx"\\.ss"
(servlets2:make #:htdocs-path htdocs-path
(servlets2:make #:url->path (fsmap:make-url->path/optimism url->path)
#:timeouts-servlet-connection 86400
#:responders-servlet-loading (gen-servlet-responder servlet-error-file)
#:responders-servlet (gen-servlet-responder servlet-error-file)
#:responders-file-not-found (gen-file-not-found-responder file-not-found-file)))
(files:make #:htdocs-path htdocs-path
#:responders-servlet (gen-servlet-responder servlet-error-file)))
(files:make #:url->path url->path
#:mime-types-path (build-path server-root-path "mime.types")
#:indices (list "index.html" "index.htm")
#:file-not-found-responder (gen-file-not-found-responder file-not-found-file))))
#:indices (list "index.html" "index.htm"))
(const:make (gen-file-not-found-responder file-not-found-file))))
(do-not-return))

61
collects/web-server/web-server-unit.ss
View File

@ -8,23 +8,25 @@
"private/web-server-structs.ss"
"configuration/configuration-table-structs.ss"
"private/cache-table.ss"
(rename "private/request.ss"
the-read-request read-request))
(require (prefix sequencer: "dispatchers/dispatch-sequencer.ss")
(prefix http: "private/request.ss"))
(require (prefix fsmap: "dispatchers/filesystem-map.ss")
(prefix sequencer: "dispatchers/dispatch-sequencer.ss")
(prefix passwords: "dispatchers/dispatch-passwords.ss")
(prefix files: "dispatchers/dispatch-files.ss")
(prefix servlets: "dispatchers/dispatch-servlets.ss")
(prefix path-procedure: "dispatchers/dispatch-pathprocedure.ss")
(prefix log: "dispatchers/dispatch-log.ss")
(prefix host: "dispatchers/dispatch-host.ss"))
(prefix host: "dispatchers/dispatch-host.ss")
(prefix filter: "dispatchers/dispatch-filter.ss")
(prefix const: "dispatchers/dispatch-const.ss"))
(provide web-server@)
(define-unit web-config@->dispatch-server-config@
(import (prefix config: web-config^))
(export dispatch-server-config^)
(init-depend web-config^)
(define read-request the-read-request)
(define read-request http:read-request)
(define port config:port)
(define listen-ip config:listen-ip)
@ -48,26 +50,41 @@
(sequencer:make
(log:make #:log-format (host-log-format host-info)
#:log-path (host-log-path host-info))
(passwords:make #:password-file (host-passwords host-info)
#:password-connection-timeout (timeouts-password (host-timeouts host-info))
#:authentication-responder (responders-authentication (host-responders host-info))
#:passwords-refresh-responder (responders-passwords-refreshed (host-responders host-info)))
(let-values ([(update-password-cache! password-check)
(passwords:make #:password-file (host-passwords host-info)
#:password-connection-timeout (timeouts-password (host-timeouts host-info))
#:authentication-responder (responders-authentication (host-responders host-info)))])
(sequencer:make
password-check
(path-procedure:make "/conf/refresh-passwords"
(lambda _
(update-password-cache!)
((responders-passwords-refreshed (host-responders host-info)))))))
(path-procedure:make "/conf/collect-garbage"
(lambda ()
(lambda _
(collect-garbage)
((responders-collect-garbage (host-responders host-info)))))
(servlets:make config:instances config:scripts config:make-servlet-namespace
#:servlet-root (paths-servlet (host-paths host-info))
#:responders-servlets-refreshed (responders-servlets-refreshed (host-responders 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))
#:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))
(files:make #:htdocs-path (paths-htdocs (host-paths host-info))
(let-values ([(clear-cache! servlet-dispatch)
(servlets:make config:instances config:scripts config:make-servlet-namespace
#:url->path
(fsmap:make-url->path/optimism
(fsmap:make-url->path (paths-servlet (host-paths host-info))))
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
#:responders-servlet (responders-servlet (host-responders host-info))
#:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))])
(sequencer:make
(path-procedure:make "/conf/refresh-servlets"
(lambda _
(clear-cache!)
((responders-servlets-refreshed (host-responders host-info)))))
(filter:make
#rx"^/servlets"
servlet-dispatch)))
(files:make #:url->path (fsmap:make-url->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))))))
#:indices (host-indices host-info))
(const:make (responders-file-not-found (host-responders host-info))))))
(define-compound-unit/infer web-server@
(import tcp^ web-config^)