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

contracts

Browse Source 
svn: r3559
This commit is contained in:
Jay McCarthy 2006-06-30 20:40:11 +00:00
parent 27270cad3f
commit e123925d31
38 changed files with 595 additions and 527 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/web-server/bindings.ss
View File

@ -1,8 +1,6 @@
(module bindings mzscheme (module bindings mzscheme
(require (lib "list.ss")) (require (lib "list.ss")
(provide extract-binding/single (lib "contract.ss"))
extract-bindings
exists-binding?)
; extract-binding/single : sym (listof (cons str str)) -> str ; extract-binding/single : sym (listof (cons str str)) -> str
(define (extract-binding/single name bindings) (define (extract-binding/single name bindings)
@ -24,4 +22,9 @@
(define (exists-binding? name bindings) (define (exists-binding? name bindings)
(if (assq name bindings) (if (assq name bindings)
#t #t
#f))) #f))
(provide/contract
[extract-binding/single (symbol? (listof (cons/c symbol? any/c)) . -> . any/c)]
[extract-bindings (symbol? (listof (cons/c symbol? any/c)) . -> . (listof any/c))]
[exists-binding? (symbol? (listof (cons/c symbol? any/c)) . -> . boolean?)]))

46
collects/web-server/configuration-structures.ss
View File

@ -1,15 +1,18 @@
(module configuration-structures mzscheme (module configuration-structures mzscheme
(require "util.ss" (require (lib "unitsig.ss")
(lib "contract.ss")
(lib "url.ss" "net"))
(require "response-structs.ss"
"configuration-table-structs.ss") "configuration-table-structs.ss")
(provide (struct timeouts (default-servlet password servlet-connection file-per-byte file-base))
(struct paths (host-base log htdocs mime-types servlet)))
; configuration is now a unit. See sig.ss ; configuration is now a unit. See sig.ss
; XXX contract
(define configuration?
unit/sig?)
; host = (make-host (listof str) sym string ; host = (make-host (listof str) sym string
; passwords resopnders timeouts paths) ; passwords responders timeouts paths)
(provide-define-struct (define-struct host (indices log-format log-path passwords responders timeouts paths))
host (indices log-format log-path passwords responders timeouts paths))
; passwords = (listof (list* relm:str protected-dir-regexp:str ; passwords = (listof (list* relm:str protected-dir-regexp:str
; (listof (list user:sym password:str)))) ; (listof (list user:sym password:str))))
@ -22,6 +25,31 @@
; (url -> response) ; (url -> response)
; response ; response
; response) ; response)
(provide-define-struct (define-struct responders
responders (servlet servlet-loading authentication servlets-refreshed passwords-refreshed file-not-found protocol collect-garbage))
(servlet servlet-loading authentication servlets-refreshed passwords-refreshed file-not-found protocol collect-garbage)))
(provide ; all-from
(struct timeouts (default-servlet password servlet-connection file-per-byte file-base))
(struct paths (host-base log htdocs mime-types servlet)))
(provide/contract
[configuration? (any/c . -> . boolean?)]
[struct host
([indices (listof string?)]
[log-format symbol?]
[log-path (or/c false/c path? string?)]
[passwords (or/c false/c path? string?)]
#;[passwords (listof (cons/c string?
(cons/c string?
(listof (list/c symbol? string?)))))]
[responders responders?]
[timeouts timeouts?]
[paths paths?])]
[struct responders
([servlet (url? any/c . -> . response?)]
[servlet-loading (url? any/c . -> . response?)]
[authentication (url? (cons/c symbol? string?) . -> . response?)]
[servlets-refreshed (-> response?)]
[passwords-refreshed (-> response?)]
[file-not-found (url? . -> . response?)]
[protocol (url? . -> . response?)]
[collect-garbage (-> response?)])]))

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

@ -1,24 +1,55 @@
(module configuration-table-structs mzscheme (module configuration-table-structs mzscheme
(require "util.ss") (require (lib "contract.ss"))
; configuration-table = (make-configuration-table nat nat num host-table (listof (cons str host-table))) ; configuration-table = (make-configuration-table nat nat num host-table (listof (cons str host-table)))
(provide-define-struct (define-struct configuration-table
configuration-table (port max-waiting initial-connection-timeout default-host virtual-hosts))
(port max-waiting initial-connection-timeout default-host virtual-hosts))
; host-table = (make-host-table (listof str) sym messages timeouts paths) ; host-table = (make-host-table (listof str) sym messages timeouts paths)
(provide-define-struct host-table (indices log-format messages timeouts paths)) (define-struct host-table (indices log-format messages timeouts paths))
; passwords = (listof (list* relm:str protected-dir-regexp:str (listof (list user:sym password:str))))
; passwords moved back to a separate file
; messages = (make-messages str^6) ; messages = (make-messages str^6)
(provide-define-struct messages (define-struct messages
(servlet ;servlet-loading (servlet authentication servlets-refreshed passwords-refreshed file-not-found protocol collect-garbage))
authentication servlets-refreshed passwords-refreshed file-not-found protocol collect-garbage))
; timeouts = (make-timeouts nat^5) ; timeouts = (make-timeouts nat^5)
(provide-define-struct timeouts (default-servlet password servlet-connection file-per-byte file-base)) (define-struct timeouts (default-servlet password servlet-connection file-per-byte file-base))
; paths = (make-paths str^6) ; paths = (make-paths str^6)
(provide-define-struct paths (conf host-base log htdocs servlet mime-types passwords))) (define-struct paths (conf host-base log htdocs servlet mime-types passwords))
(provide/contract
[struct configuration-table
([port natural-number/c]
[max-waiting natural-number/c]
[initial-connection-timeout natural-number/c]
[default-host host-table?]
[virtual-hosts (listof (cons/c string? host-table?))])]
[struct host-table
([indices (listof string?)]
[log-format symbol?]
[messages messages?]
[timeouts timeouts?]
[paths paths?])]
[struct messages
([servlet string?]
[authentication string?]
[servlets-refreshed string?]
[passwords-refreshed string?]
[file-not-found string?]
[protocol string?]
[collect-garbage string?])]
[struct timeouts
([default-servlet number?]
[password number?]
[servlet-connection number?]
[file-per-byte number?]
[file-base number?])]
[struct paths
([conf (or/c false/c path? string?)]
[host-base (or/c false/c path? string?)]
[log (or/c false/c path? string?)]
[htdocs (or/c false/c path? string?)]
[servlet (or/c false/c path? string?)]
[mime-types (or/c false/c path? string?)]
[passwords (or/c false/c path? string?)])]))

11
collects/web-server/configuration-util.ss
View File

@ -1,8 +1,8 @@
(module configuration-util mzscheme (module configuration-util mzscheme
(require (lib "file.ss") (require (lib "contract.ss")
(lib "file.ss")
(lib "pretty.ss")) (lib "pretty.ss"))
(require "configuration-table-structs.ss") (require "configuration-table-structs.ss")
(provide (all-defined))
; write-configuration-table : configuration-table path -> void ; write-configuration-table : configuration-table path -> void
; writes out the new configuration file ; writes out the new configuration file
@ -55,4 +55,9 @@
(define (write-to-file file-name x) (define (write-to-file file-name x)
(call-with-output-file file-name (call-with-output-file file-name
(lambda (out) (pretty-print x out)) (lambda (out) (pretty-print x out))
'truncate))) 'truncate))
(provide/contract
[write-configuration-table (configuration-table? string? . -> . void)]
[format-host (host-table? . -> . list?)]
[write-to-file (string? list? . -> . void)]))

58
collects/web-server/configuration.ss
View File

@ -1,5 +1,6 @@
; configuration language example
(module configuration mzscheme (module configuration mzscheme
(require (lib "unitsig.ss")
(lib "contract.ss"))
(require "configuration-structures.ss" (require "configuration-structures.ss"
"configuration-table-structs.ss" "configuration-table-structs.ss"
"sig.ss" "sig.ss"
@ -7,30 +8,6 @@
"parse-table.ss" "parse-table.ss"
"private/cache-table.ss" "private/cache-table.ss"
"response.ss") "response.ss")
(require (lib "unitsig.ss")
(lib "contract.ss"))
(provide complete-configuration
get-configuration
build-developer-configuration
build-developer-configuration/vhosts ;; added 2/3/05 by Jacob
default-configuration-table-path
update-configuration)
(provide/contract
[load-configuration (path? . -> . unit/sig?)]
[load-developer-configuration (path? . -> . unit/sig?)])
(provide error-response
servlet-loading-responder
gen-servlet-not-found
gen-servlet-responder
gen-servlets-refreshed
gen-passwords-refreshed
gen-authentication-responder
gen-protocol-responder
gen-file-not-found-responder
gen-collect-garbage-responder)
(define default-configuration-table-path (define default-configuration-table-path
(build-path (collection-path "web-server") "configuration-table")) (build-path (collection-path "web-server") "configuration-table"))
@ -111,8 +88,6 @@
; begin stolen from commander.ss, which was stolen from private/drscheme/eval.ss ; begin stolen from commander.ss, which was stolen from private/drscheme/eval.ss
; FIX - abstract this out to a namespace library somewhere (ask Robby and Matthew) ; FIX - abstract this out to a namespace library somewhere (ask Robby and Matthew)
(define to-be-copied-module-specs (define to-be-copied-module-specs
'(mzscheme '(mzscheme
;; allow people (SamTH) to use MrEd primitives from servlets. ;; allow people (SamTH) to use MrEd primitives from servlets.
@ -122,7 +97,6 @@
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "servlet.ss" "web-server"))) (lib "servlet.ss" "web-server")))
; JBC : added error-handler hack; the right answer is only to transfer the 'mred' ; JBC : added error-handler hack; the right answer is only to transfer the 'mred'
; module binding when asked to, e.g. by a field in the configuration file. ; module binding when asked to, e.g. by a field in the configuration file.
; GregP: put this back in if Sam's code breaks ; GregP: put this back in if Sam's code breaks
@ -203,7 +177,7 @@
; gen-servlet-responder : str -> url tst -> response ; gen-servlet-responder : str -> url tst -> response
(define (gen-servlet-responder servlet-error-file) (define (gen-servlet-responder servlet-error-file)
(lambda (url exn) (lambda (url exn)
; more here - use separate log file ; XXX use separate log file
((error-display-handler) ((error-display-handler)
(format "Servlet exception:\n~a\n" (exn-message exn)) (format "Servlet exception:\n~a\n" (exn-message exn))
exn) exn)
@ -296,4 +270,28 @@
(and (regexp-match (car x) host-name-possibly-followed-by-a-collon-and-a-port-number) (and (regexp-match (car x) host-name-possibly-followed-by-a-collon-and-a-port-number)
(cadr x))) (cadr x)))
expanded-virtual-host-table) expanded-virtual-host-table)
default-host)))) default-host)))
(provide/contract
[complete-configuration (string? configuration-table? . -> . configuration?)]
[get-configuration (string? . -> . configuration-table?)]
; XXX contract
[build-developer-configuration (list? . -> . configuration?)]
; XXX contract
[build-developer-configuration/vhosts (list? . -> . configuration?)]
[default-configuration-table-path path?]
[update-configuration (configuration? (listof (cons/c symbol? any/c)) . -> . configuration?)]
[load-configuration (path? . -> . configuration?)]
[load-developer-configuration (path? . -> . configuration?)])
(provide/contract
[error-response ((natural-number/c string? string?) (listof (cons/c symbol? string?)) . ->* . (response?))]
; XXX contract
[servlet-loading-responder (string? any/c . -> . response?)]
[gen-servlet-not-found (string? . -> . (string? . -> . response?))]
[gen-servlet-responder (string? . -> . (string? any/c . -> . response?))]
[gen-servlets-refreshed (string? . -> . (-> response?))]
[gen-passwords-refreshed (string? . -> . (-> response?))]
[gen-authentication-responder (string? . -> . (string? (cons/c symbol? string?) . -> . response?))]
[gen-protocol-responder (string? . -> . (string? . -> . response?))]
[gen-file-not-found-responder (string? . -> . (string? . -> . response?))]
[gen-collect-garbage-responder (string? . -> . (-> response?))]))

6
collects/web-server/configure.ss
View File

@ -1,5 +1,4 @@
(module configure mzscheme (module configure mzscheme
(provide servlet servlet-maker)
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(lib "servlet-sig.ss" "web-server") (lib "servlet-sig.ss" "web-server")
(lib "url.ss" "net") (lib "url.ss" "net")
@ -7,12 +6,17 @@
(lib "list.ss") (lib "list.ss")
(lib "pretty.ss") (lib "pretty.ss")
(lib "file.ss") (lib "file.ss")
(lib "contract.ss")
(only (lib "configuration.ss" "web-server") (only (lib "configuration.ss" "web-server")
default-configuration-table-path) default-configuration-table-path)
(lib "configuration-table-structs.ss" "web-server") (lib "configuration-table-structs.ss" "web-server")
(lib "parse-table.ss" "web-server") (lib "parse-table.ss" "web-server")
(lib "configuration-util.ss" "web-server") (lib "configuration-util.ss" "web-server")
(all-except (lib "util.ss" "web-server") translate-escapes)) (all-except (lib "util.ss" "web-server") translate-escapes))
(provide/contract
[servlet unit/sig?]
; XXX contract
[servlet-maker (string? . -> . unit/sig?)])
;; FIX ;; FIX
; - fuss with changing absolute paths into relative ones internally ; - fuss with changing absolute paths into relative ones internally

13
collects/web-server/dispatch-server-sig.ss Normal file
View File

@ -0,0 +1,13 @@
(module dispatch-server-sig mzscheme
(require (lib "unitsig.ss"))
(define-signature dispatch-server^
(serve
serve-ports))
(define-signature dispatch-server-config^
(port listen-ip max-waiting initial-connection-timeout
read-request dispatch))
(provide ; XXX contract signature
dispatch-server^ dispatch-server-config^))

81
collects/web-server/dispatch-server-unit.ss Normal file
View File

@ -0,0 +1,81 @@
(module dispatch-server-unit mzscheme
(require (lib "tcp-sig.ss" "net")
(lib "unitsig.ss")
(lib "thread.ss")
(lib "contract.ss")
(lib "kw.ss"))
(require "web-server-structs.ss"
"connection-manager.ss"
"dispatch-server-sig.ss")
(provide/contract
; XXX contract
[dispatch-server@ unit/sig?])
;; ****************************************
(define dispatch-server@
(unit/sig dispatch-server^
(import net:tcp^ (config : dispatch-server-config^))
;; serve: -> -> void
;; start the server and return a thunk to shut it down
(define (serve)
(define the-server-custodian (make-custodian))
(start-connection-manager the-server-custodian)
(parameterize ([current-custodian the-server-custodian]
[current-server-custodian the-server-custodian]
[current-thread-initial-stack-size 3])
(thread
(lambda ()
(run-server config:port
handle-connection
#f
(lambda (exn)
#f)
(lambda (p mw re)
(tcp-listen p config:max-waiting #t config:listen-ip))
tcp-close
tcp-accept
tcp-accept/enable-break))))
(lambda ()
(custodian-shutdown-all the-server-custodian)))
;; serve-ports : input-port output-port -> void
;; returns immediately, spawning a thread to handle
;; the connection
;; NOTE: (GregP) should allow the user to pass in a connection-custodian
(define (serve-ports ip op)
(define server-cust (make-custodian))
(start-connection-manager server-cust)
(parameterize ([current-custodian server-cust]
[current-server-custodian server-cust])
(define connection-cust (make-custodian))
(parameterize ([current-custodian connection-cust])
(thread
(lambda ()
(handle-connection ip op
(lambda (ip)
(values "127.0.0.1"
"127.0.0.1"))))))))
;; handle-connection : input-port output-port (input-port -> string string) -> void
;; returns immediately, spawning a thread to handle
(define/kw (handle-connection ip op
#:optional
[port-addresses tcp-addresses])
(define conn
(new-connection config:initial-connection-timeout
ip op (current-custodian) #f))
(with-handlers ([exn:fail:network?
(lambda (e)
(kill-connection! conn)
(raise e))])
(let connection-loop ()
(define-values (req close?) (config:read-request conn config:port port-addresses))
(adjust-connection-timeout! conn config:initial-connection-timeout)
(config:dispatch conn req)
(unless (connection-close? conn)
(set-connection-close?! conn close?))
(cond
[(connection-close? conn) (kill-connection! conn)]
[else (connection-loop)])))))))

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

@ -2,14 +2,17 @@
(require (lib "url.ss" "net") (require (lib "url.ss" "net")
(lib "xml.ss" "xml") (lib "xml.ss" "xml")
(lib "kw.ss") (lib "kw.ss")
(lib "list.ss")) (lib "list.ss")
(lib "contract.ss"))
(require "dispatch.ss" (require "dispatch.ss"
"../configuration.ss" "../configuration.ss"
"../util.ss" "../util.ss"
"../mime-types.ss" "../mime-types.ss"
"../response.ss") "../response.ss")
(provide interface-version (provide/contract
make) [interface-version dispatcher-interface-version?])
(provide ; XXX contract kw
make)
(define interface-version 'v1) (define interface-version 'v1)
(define/kw (make #:key (define/kw (make #:key

13
collects/web-server/dispatchers/dispatch-host.ss
View File

@ -1,11 +1,12 @@
(module dispatch-host mzscheme (module dispatch-host mzscheme
(require (lib "contract.ss"))
(require "dispatch.ss" (require "dispatch.ss"
"../servlet-helpers.ss") "../servlet-helpers.ss")
(provide interface-version (provide/contract
make) [interface-version dispatcher-interface-version?]
[make ((symbol? . -> . dispatcher?) . -> . dispatcher?)])
(define interface-version 'v1) (define interface-version 'v1)
(define (make lookup-dispatcher) (define ((make lookup-dispatcher) conn req)
(lambda (conn req) (define host (get-host (request-uri req) (request-headers/raw req)))
(let* ([host (get-host (request-uri req) (request-headers/raw req))]) ((lookup-dispatcher host) conn req)))
((lookup-dispatcher host) conn req)))))

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

@ -3,11 +3,14 @@
(lib "date.ss") (lib "date.ss")
(lib "kw.ss") (lib "kw.ss")
(lib "async-channel.ss") (lib "async-channel.ss")
(lib "plt-match.ss")) (lib "plt-match.ss")
(lib "contract.ss"))
(require "dispatch.ss" (require "dispatch.ss"
"../servlet-helpers.ss") "../servlet-helpers.ss")
(provide interface-version (provide/contract
make) [interface-version dispatcher-interface-version?])
(provide ; XXX contract kw
make)
(define interface-version 'v1) (define interface-version 'v1)
(define/kw (make #:key (define/kw (make #:key

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

@ -1,13 +1,16 @@
(module dispatch-passwords mzscheme (module dispatch-passwords mzscheme
(require (lib "kw.ss")) (require (lib "kw.ss")
(lib "contract.ss"))
(require "dispatch.ss" (require "dispatch.ss"
(all-except "../util.ss" translate-escapes) (all-except "../util.ss" translate-escapes)
"../configuration.ss" "../configuration.ss"
"../servlet-helpers.ss" "../servlet-helpers.ss"
"../connection-manager.ss" "../connection-manager.ss"
"../response.ss") "../response.ss")
(provide interface-version (provide/contract
make) [interface-version dispatcher-interface-version?])
(provide ; XXX contract kw
make)
(define interface-version 'v1) (define interface-version 'v1)
(define/kw (make #:key (define/kw (make #:key

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

@ -1,9 +1,11 @@
(module dispatch-pathprocedure mzscheme (module dispatch-pathprocedure mzscheme
(require (lib "contract.ss"))
(require "dispatch.ss" (require "dispatch.ss"
"../util.ss" "../util.ss"
"../response.ss") "../response.ss")
(provide interface-version (provide/contract
make) [interface-version dispatcher-interface-version?]
[make (string? (-> response?) . -> . dispatcher?)])
(define interface-version 'v1) (define interface-version 'v1)
(define ((make the-path procedure) conn req) (define ((make the-path procedure) conn req)

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

@ -1,8 +1,11 @@
(module dispatch-sequencer mzscheme (module dispatch-sequencer mzscheme
(require (lib "list.ss")) (require (lib "list.ss")
(lib "contract.ss"))
(require "dispatch.ss") (require "dispatch.ss")
(provide interface-version (provide/contract
make) [interface-version dispatcher-interface-version?])
(provide ; XXX contract kw
make)
(define interface-version 'v1) (define interface-version 'v1)
(define ((make . dispatchers) conn req) (define ((make . dispatchers) conn req)

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

@ -2,7 +2,8 @@
(require (lib "url.ss" "net") (require (lib "url.ss" "net")
(lib "kw.ss") (lib "kw.ss")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "unitsig.ss")) (lib "unitsig.ss")
(lib "contract.ss"))
(require "dispatch.ss" (require "dispatch.ss"
"../web-server-structs.ss" "../web-server-structs.ss"
"../connection-manager.ss" "../connection-manager.ss"
@ -13,11 +14,15 @@
(all-except "../util.ss" translate-escapes) (all-except "../util.ss" translate-escapes)
"../managers/manager.ss" "../managers/manager.ss"
"../managers/timeouts.ss" "../managers/timeouts.ss"
"../managers/lru.ss"
"../private/url.ss" "../private/url.ss"
"../private/servlet.ss" "../private/servlet.ss"
"../private/cache-table.ss") "../private/cache-table.ss")
(provide interface-version (provide/contract
make) [interface-version dispatcher-interface-version?])
(provide ; XXX contract improve
; XXX contract kw
make)
(define interface-version 'v1) (define interface-version 'v1)
(define/kw (make config:instances config:scripts config:make-servlet-namespace (define/kw (make config:instances config:scripts config:make-servlet-namespace

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

@ -1,14 +1,18 @@
(module dispatch mzscheme (module dispatch mzscheme
(require (lib "contract.ss"))
(require "../connection-structs.ss" (require "../connection-structs.ss"
"../request-structs.ss" "../request-structs.ss"
"../response-structs.ss") "../response-structs.ss")
(require (lib "contract.ss")
(lib "list.ss"))
(provide dispatcher?) (define dispatcher?
(define dispatcher? (connection? request? . -> . response?)) (connection? request? . -> . void))
(define dispatcher-interface-version?
(provide next-dispatcher symbol?)
[struct exn:dispatcher ()])
(define-struct exn:dispatcher ()) (define-struct exn:dispatcher ())
(define (next-dispatcher) (raise (make-exn:dispatcher)))) (define (next-dispatcher) (raise (make-exn:dispatcher)))
(provide/contract
[dispatcher? contract?]
[dispatcher-interface-version? (any/c . -> . boolean?)]
[next-dispatcher (-> void)]
[struct exn:dispatcher ()]))

11
collects/web-server/launch.ss
View File

@ -2,12 +2,14 @@
(module launch mzscheme (module launch mzscheme
(require (lib "cmdline.ss") (require (lib "cmdline.ss")
(lib "pregexp.ss") (lib "pregexp.ss")
"util.ss" (lib "contract.ss")
(lib "unitsig.ss")
(lib "tcp-sig.ss" "net"))
(require "util.ss"
"web-server-unit.ss" "web-server-unit.ss"
"sig.ss" "sig.ss"
"configuration.ss" "configuration.ss"
(lib "unitsig.ss") "configuration-structures.ss")
(lib "tcp-sig.ss" "net"))
(define configuration@ (define configuration@
(parse-command-line (parse-command-line
@ -58,4 +60,5 @@
(export (open S))) (export (open S)))
#f net:tcp^) #f net:tcp^)
(provide serve)) (provide ; XXX contract
serve))

8
collects/web-server/managers/lru.ss
View File

@ -1,8 +1,12 @@
(module lru mzscheme (module lru mzscheme
(require (lib "plt-match.ss") (require (lib "plt-match.ss")
(lib "contract.ss")
(lib "kw.ss")) (lib "kw.ss"))
(require "manager.ss") (require "manager.ss"
(provide create-LRU-manager) "../servlet-structs.ss")
(provide/contract
; XXX contract kw
[create-LRU-manager ((expiration-handler? number? number? (-> boolean?)) any/c . ->* . (manager?))])
;; Utility ;; Utility
(define (make-counter) (define (make-counter)

21
collects/web-server/managers/manager.ss
View File

@ -1,5 +1,6 @@
(module manager mzscheme (module manager mzscheme
(provide (all-defined)) (require (lib "contract.ss"))
(require "../servlet-structs.ss")
(define-struct manager (create-instance (define-struct manager (create-instance
adjust-timeout! adjust-timeout!
@ -9,4 +10,20 @@
continuation-lookup)) continuation-lookup))
(define-struct (exn:fail:servlet-manager:no-instance exn:fail) (expiration-handler)) (define-struct (exn:fail:servlet-manager:no-instance exn:fail) (expiration-handler))
(define-struct (exn:fail:servlet-manager:no-continuation exn:fail) (expiration-handler))) (define-struct (exn:fail:servlet-manager:no-continuation exn:fail) (expiration-handler))
(provide/contract
[struct manager ([create-instance (any/c (-> void) . -> . number?)]
[adjust-timeout! (number? number? . -> . void)]
[instance-lookup-data (number? . -> . any/c)]
[clear-continuations! (number? . -> . void)]
[continuation-store! (number? procedure? expiration-handler? . -> . (list/c number? number?))]
[continuation-lookup (number? number? number? . -> . procedure?)])]
[struct (exn:fail:servlet-manager:no-instance exn:fail)
([msg string?]
[continuation-marks continuation-mark-set?]
[expiration-handler expiration-handler?])]
[struct (exn:fail:servlet-manager:no-continuation exn:fail)
([msg string?]
[continuation-marks continuation-mark-set?]
[expiration-handler expiration-handler?])]))

9
collects/web-server/managers/timeouts.ss
View File

@ -1,8 +1,11 @@
(module timeouts mzscheme (module timeouts mzscheme
(require (lib "plt-match.ss")) (require (lib "plt-match.ss")
(lib "contract.ss"))
(require "manager.ss") (require "manager.ss")
(require "../timer.ss") (require "../timer.ss"
(provide create-timeout-manager) "../servlet-structs.ss")
(provide/contract
[create-timeout-manager (expiration-handler? number? number? . -> . manager?)])
;; Utility ;; Utility
(define (make-counter) (define (make-counter)

18
collects/web-server/monitor-server.ss
View File

@ -1,13 +1,9 @@
(module monitor-server mzscheme (module monitor-server mzscheme
(require (lib "etc.ss") (require (lib "etc.ss")
"monitor-poke-web-server.ss" (lib "contract.ss")
"monitor-emailer.ss"
(lib "match.ss")) (lib "match.ss"))
(require "monitor-poke-web-server.ss"
(provide monitor "monitor-emailer.ss")
default-server-port
default-poll-frequency-seconds
default-server-response-timeout-seconds)
(define default-server-port 80) (define default-server-port 80)
(define default-poll-frequency-seconds 3600) (define default-poll-frequency-seconds 3600)
@ -33,4 +29,10 @@
[`(ok) (void)] [`(ok) (void)]
[else (send-email (result->message result))]) [else (send-email (result->message result))])
(sleep poll-frequency-seconds) (sleep poll-frequency-seconds)
(check-server)))))) (check-server)))))
(provide/contract
[monitor ((string? string?) (number? number? number?) . -> . void)]
[default-server-port number?]
[default-poll-frequency-seconds number?]
[default-server-response-timeout-seconds number?]))

10
collects/web-server/parse-table.ss
View File

@ -1,8 +1,8 @@
(module parse-table mzscheme (module parse-table mzscheme
(require (lib "list.ss")) (require (lib "list.ss")
(lib "contract.ss"))
(require "configuration-table-structs.ss" (require "configuration-table-structs.ss"
"bindings.ss") "bindings.ss")
(provide parse-configuration-table)
(define (get-binding key bindings default) (define (get-binding key bindings default)
(first (get-binding* key bindings (list default)))) (first (get-binding* key bindings (list default))))
@ -83,4 +83,8 @@
; nat? : tst -> bool ; nat? : tst -> bool
(define (nat? x) (define (nat? x)
(and (number? x) (exact? x) (integer? x) (<= 0 x)))) (and (number? x) (exact? x) (integer? x) (<= 0 x)))
(provide/contract
; XXX contract
[parse-configuration-table (list? . -> . configuration-table?)]))

4
collects/web-server/private/cache-table.ss
View File

@ -36,5 +36,5 @@
[rename new-cache-table make-cache-table [rename new-cache-table make-cache-table
(-> cache-table?)] (-> cache-table?)]
[cache-table-lookup! (cache-table? symbol? (-> any/c) . -> . any/c)] [cache-table-lookup! (cache-table? symbol? (-> any/c) . -> . any/c)]
[cache-table-clear! (cache-table? . -> . void?)]) [cache-table-clear! (cache-table? . -> . void?)]
(provide cache-table?)) [cache-table? (any/c . -> . boolean?)]))

31
collects/web-server/private/servlet.ss
View File

@ -1,10 +1,13 @@
(module servlet mzscheme (module servlet mzscheme
(require "../managers/manager.ss") (require (lib "contract.ss"))
(require "../managers/manager.ss"
"../servlet-structs.ss"
"../connection-structs.ss"
"../request-structs.ss")
(define-struct (exn:fail:servlet:instance exn:fail) ()) (define-struct (exn:fail:servlet:instance exn:fail) ())
(define-struct servlet (custodian namespace manager handler)) (define-struct servlet (custodian namespace manager handler))
(define-struct servlet-instance-data (mutex context)) (define-struct servlet-instance-data (mutex context))
(define-struct execution-context (connection request suspend)) (define-struct execution-context (connection request suspend))
(define current-servlet (make-thread-cell #f)) (define current-servlet (make-thread-cell #f))
@ -27,4 +30,26 @@
(define instance-id (thread-cell-ref current-servlet-instance-id)) (define instance-id (thread-cell-ref current-servlet-instance-id))
((manager-instance-lookup-data manager) instance-id)) ((manager-instance-lookup-data manager) instance-id))
(provide (all-defined))) (provide/contract
[struct (exn:fail:servlet:instance exn:fail)
([msg string?]
[continuation-marks continuation-mark-set?])]
[struct servlet
([custodian custodian?]
[namespace namespace?]
[manager manager?]
[handler (request? . -> . servlet-response?)])]
[struct servlet-instance-data
([mutex semaphore?]
[context execution-context?])]
[struct execution-context
([connection connection?]
[request request?]
[suspend procedure?])]
; XXX contract maybe
[current-servlet thread-cell?]
; XXX contract maybe
[current-servlet-instance-id thread-cell?]
[get-current-servlet-instance-id (-> number?)]
[current-servlet-manager (-> manager?)]
[current-servlet-instance-data (-> servlet-instance-data?)]))

4
collects/web-server/private/url.ss
View File

@ -4,9 +4,9 @@
(lib "list.ss") (lib "list.ss")
(lib "plt-match.ss")) (lib "plt-match.ss"))
(provide
match-url-params)
(provide/contract (provide/contract
; XXX contract maybe
[match-url-params (string? . -> . (or/c false/c (list/c string? string? string? string?)))]
[continuation-url? (url? . -> . (or/c boolean? (list/c number? number? number?)))] [continuation-url? (url? . -> . (or/c boolean? (list/c number? number? number?)))]
[embed-ids ((list/c number? number? number?) url? . -> . string?)]) [embed-ids ((list/c number? number? number?) url? . -> . string?)])

43
collects/web-server/servlet-helpers.ss
View File

@ -1,5 +1,5 @@
(module servlet-helpers mzscheme (module servlet-helpers mzscheme
(require (lib "list.ss") (require (lib "contract.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "xml.ss" "xml") (lib "xml.ss" "xml")
@ -8,21 +8,10 @@
(require "util.ss" (require "util.ss"
"response.ss" "response.ss"
"request-structs.ss" "request-structs.ss"
"bindings.ss") "bindings.ss"
(provide get-host "servlet-structs.ss")
(all-from "bindings.ss") (provide (all-from "bindings.ss")
extract-user-pass (all-from "request-structs.ss"))
build-suspender
make-html-response/incremental
report-errors-to-browser
redirect-to
permanently
temporarily
see-other
(all-from "request-structs.ss")
request-bindings
request-headers
translate-escapes)
(define (request-headers request) (define (request-headers request)
(map (match-lambda (map (match-lambda
@ -134,4 +123,24 @@
;; does the second part of the authorization header start with #"Basic " ;; does the second part of the authorization header start with #"Basic "
(define basic? (define basic?
(let ([rx (byte-regexp #"^Basic .*")]) (let ([rx (byte-regexp #"^Basic .*")])
(lambda (a) (regexp-match rx a))))) (lambda (a) (regexp-match rx a))))
(provide ; all-from
translate-escapes)
(provide/contract
[get-host (url? (listof header?) . -> . symbol?)]
; XXX contract maybe
[extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c string? string?)))]
[build-suspender (((listof xexpr?) (listof xexpr?))
((listof (list/c symbol? string?)) (listof (list/c symbol? string?)))
. opt-> .
(k-url? . -> . xexpr?))]
[make-html-response/incremental (((string? . -> . void) . -> . void) . -> . response/incremental?)]
[report-errors-to-browser ((servlet-response? . -> . void) . -> . void)]
[redirect-to ((string?) (redirection-status?) . opt-> . response/full?)]
[permanently redirection-status?]
[temporarily redirection-status?]
[see-other redirection-status?]
[request-bindings (request? . -> . (listof (or/c (cons/c symbol? string?)
(cons/c symbol? bytes?))))]
[request-headers (request? . -> . (listof (cons/c symbol? string?)))]))

8
collects/web-server/servlet-language.ss
View File

@ -1,10 +1,11 @@
(module servlet-language mzscheme (module servlet-language mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "tool.ss" "drscheme") (lib "tool.ss" "drscheme")
(lib "contract.ss")
;(lib "mred.ss" "mred") ;(lib "mred.ss" "mred")
(lib "unitsig.ss")) (lib "unitsig.ss"))
(provide/contract
(provide tool@) [tool@ unit/sig?])
(define tool@ (define tool@
(unit/sig drscheme:tool-exports^ (unit/sig drscheme:tool-exports^
@ -99,5 +100,4 @@
;(language-numbers (list -1000 1000)) ;(language-numbers (list -1000 1000))
)) ))
))) ))))
)

42
collects/web-server/servlet-structs.ss Normal file
View File

@ -0,0 +1,42 @@
(module servlet-structs mzscheme
(require (lib "contract.ss")
(lib "xml.ss" "xml"))
(require "request-structs.ss"
"response-structs.ss")
(define servlet-response?
any/c)
(define (xexpr/callback? x)
(correct-xexpr? x
(lambda () #t)
(lambda (exn)
(if (procedure? (exn:invalid-xexpr-code exn))
#t
(begin ((error-display-handler) (exn-message exn) exn)
#f)))))
(define k-url?
string?)
(define response-generator?
(k-url? . -> . servlet-response?))
(define url-transform?
(k-url? . -> . k-url?))
(define expiration-handler?
(or/c false/c
(request? . -> . response?)))
(define embed/url?
(((request? . -> . any/c)) (expiration-handler?) . opt-> . string?))
(provide/contract
[servlet-response? contract?]
[xexpr/callback? (any/c . -> . boolean?)]
[response-generator? contract?]
[k-url? (any/c . -> . boolean?)]
[url-transform? contract?]
[expiration-handler? contract?]
[embed/url? contract?]))

49
collects/web-server/servlet.ss
View File

@ -7,35 +7,8 @@
"private/servlet.ss" "private/servlet.ss"
"private/url.ss" "private/url.ss"
"servlet-helpers.ss" "servlet-helpers.ss"
"timer.ss" "web-cells.ss"
"web-cells.ss") "servlet-structs.ss")
;; CONTRACT HELPERS
(define servlet-response? any/c)
(define (xexpr/callback? x)
(correct-xexpr? x
(lambda () #t)
(lambda (exn)
(if (procedure? (exn:invalid-xexpr-code exn))
#t
(begin ((error-display-handler) (exn-message exn) exn)
#f)))))
(define response-generator?
(string? . -> . servlet-response?))
(define url-transform?
(string? . -> . string?))
(define expiration-handler?
(request? . -> . void?))
(define (parameter/c c)
parameter?)
(define embed/url?
(((request? . -> . any/c)) (expiration-handler?) . opt-> . string?))
;; ************************************************************ ;; ************************************************************
;; HELPERS ;; HELPERS
@ -52,10 +25,11 @@
;; Weak contracts: the input is checked in output-response, and a message is ;; Weak contracts: the input is checked in output-response, and a message is
;; sent directly to the client (Web browser) instead of the terminal/log. ;; sent directly to the client (Web browser) instead of the terminal/log.
(provide/contract (provide/contract
[xexpr/callback? (any/c . -> . boolean?)]
[xexpr/callback->xexpr (embed/url? xexpr/callback? . -> . xexpr?)] [xexpr/callback->xexpr (embed/url? xexpr/callback? . -> . xexpr?)]
[current-url-transform (parameter/c url-transform?)] ; XXX contract
[current-servlet-continuation-expiration-handler (parameter/c expiration-handler?)] [current-url-transform parameter?]
; XXX contract
[current-servlet-continuation-expiration-handler parameter?]
[redirect/get (-> request?)] [redirect/get (-> request?)]
[redirect/get/forget (-> request?)] [redirect/get/forget (-> request?)]
[adjust-timeout! (number? . -> . void?)] [adjust-timeout! (number? . -> . void?)]
@ -68,17 +42,18 @@
[send/suspend/callback (xexpr/callback? . -> . any/c)]) [send/suspend/callback (xexpr/callback? . -> . any/c)])
(require "url.ss") (require "url.ss")
(provide (provide (all-from "web-cells.ss")
(all-from "web-cells.ss") (all-from "servlet-helpers.ss")
(all-from "servlet-helpers.ss") (all-from "url.ss")
(all-from "url.ss")) (all-from "servlet-structs.ss"))
;; ************************************************************ ;; ************************************************************
;; EXPORTS ;; EXPORTS
;; current-url-transform : string? -> string? ;; current-url-transform : string? -> string?
(define (default-url-transformer x) x)
(define current-url-transform (define current-url-transform
(make-parameter identity)) (make-parameter default-url-transformer))
;; current-servlet-continuation-expiration-handler : request -> response ;; current-servlet-continuation-expiration-handler : request -> response
(define current-servlet-continuation-expiration-handler (define current-servlet-continuation-expiration-handler

13
collects/web-server/sig.ss
View File

@ -1,21 +1,12 @@
(module sig mzscheme (module sig mzscheme
(require (lib "unitsig.ss")) (require (lib "unitsig.ss"))
(provide (require "dispatch-server-sig.ss")
dispatch-server^ dispatch-server-config^ (provide ; XXX contract signature
web-server^ servlet^ web-config^ web-config/pervasive^ web-config/local^) web-server^ servlet^ web-config^ web-config/pervasive^ web-config/local^)
(define-signature dispatch-server^
(serve
serve-ports
; for environment:
server-loop))
(define-signature web-server^ (define-signature web-server^
((open dispatch-server^))) ((open dispatch-server^)))
(define-signature dispatch-server-config^
(port listen-ip max-waiting initial-connection-timeout
read-request dispatch))
(define-signature servlet^ (define-signature servlet^
(initial-request send/suspend send/finish send/back send/forward adjust-timeout!)) (initial-request send/suspend send/finish send/back send/forward adjust-timeout!))

17
collects/web-server/timer.ss
View File

@ -1,11 +1,8 @@
(module timer mzscheme (module timer mzscheme
(require "timer-structs.ss")
(require (lib "list.ss") (require (lib "list.ss")
(lib "contract.ss")
(lib "async-channel.ss")) (lib "async-channel.ss"))
(provide timer? (require "timer-structs.ss")
start-timer reset-timer! increment-timer!
cancel-timer!
start-timer-manager)
(define timer-ch (make-async-channel)) (define timer-ch (make-async-channel))
@ -86,7 +83,15 @@
(revise-timer! timer (revise-timer! timer
(+ (- (timer-expire-seconds timer) (current-inexact-milliseconds)) (+ (- (timer-expire-seconds timer) (current-inexact-milliseconds))
(* 1000 secs)) (* 1000 secs))
(timer-action timer)))) (timer-action timer)))
(provide/contract
[timer? (any/c . -> . boolean?)]
[start-timer-manager (custodian? . -> . void)]
[start-timer (number? (-> void) . -> . timer?)]
[reset-timer! (timer? number? . -> . void)]
[increment-timer! (timer? number? . -> . void)]
[cancel-timer! (timer? . -> . void)]))
; --- timeout plan ; --- timeout plan

50
collects/web-server/url.ss
View File

@ -1,18 +1,12 @@
(module url mzscheme (module url mzscheme
(require (lib "list.ss") (require (lib "list.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "contract.ss")
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "struct.ss")) (lib "struct.ss"))
(require "private/url.ss" (require "private/url.ss"
"request-structs.ss") "request-structs.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 (define-struct servlet-url (protocol host port
servlets-root servlets-root
instance-id k-id nonce instance-id k-id nonce
@ -38,17 +32,17 @@
(define (servlet-url->url-string su) (define (servlet-url->url-string su)
(let ([the-url (let ([the-url
(make-url (servlet-url-protocol su) (make-url (servlet-url-protocol su)
#f #f
#f ;(servlet-url-host su) #f ;(servlet-url-host su)
#f ;(servlet-url-port su) #f ;(servlet-url-port su)
#t #t
(append (reverse (rest (reverse (servlet-url-servlets-root su)))) (append (reverse (rest (reverse (servlet-url-servlets-root su))))
(list (make-path/param (path/param-path (first (reverse (servlet-url-servlets-root su)))) (list (make-path/param (path/param-path (first (reverse (servlet-url-servlets-root su))))
empty)) empty))
(servlet-url-servlet-path su) (servlet-url-servlet-path su)
(servlet-url-extra-path su)) (servlet-url-extra-path su))
empty empty
#f)]) #f)])
(if (and (servlet-url-instance-id su) (if (and (servlet-url-instance-id su)
(servlet-url-k-id su) (servlet-url-k-id su)
(servlet-url-nonce su)) (servlet-url-nonce su))
@ -88,4 +82,22 @@
(list (first (url-path uri))) (list (first (url-path uri)))
k-instance k-id k-salt k-instance k-id k-salt
servlet-path servlet-path
path))))) path))))
(provide/contract
; XXX contract maybe
[struct servlet-url ([protocol (or/c false/c string?)]
[host (or/c false/c string?)]
[port (or/c false/c natural-number/c)]
[servlets-root (listof path/param?)]
[instance-id number?]
[k-id number?]
[nonce number?]
[servlet-path (listof path/param?)]
[extra-path (listof path/param?)])]
[servlet-url->url-string (servlet-url? . -> . string?)]
[servlet-url->url-string/no-continuation (servlet-url? . -> . string?)]
[servlet-url->servlet-url/no-extra-path (servlet-url? . -> . servlet-url?)]
[request->servlet-url (request? . -> . servlet-url?)]
; XXX contract maybe
[uri->servlet-url ((url?) ((or/c false/c string?) (or/c false/c natural-number/c)) . opt-> . servlet-url?)]))

68
collects/web-server/util.ss
View File

@ -8,24 +8,6 @@
(lib "uri-codec.ss" "net")) (lib "uri-codec.ss" "net"))
(require "request-structs.ss") (require "request-structs.ss")
(provide provide-define-struct
extract-flag
translate-escapes
hash-table-empty?
url-path->string)
(provide/contract
[valid-port? (any/c . -> . boolean?)]
[decompose-request ((request?) . ->* . (url? symbol? string?))]
[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)))))]
[url-path->path ((or/c (symbols 'up 'same) path?) string? . -> . path?)]
[directory-part (path? . -> . path?)]
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
[exn->string ((or/c exn? any/c) . -> . string?)]
[build-path-unless-absolute (path? (or/c string? path?) . -> . path?)])
;; valid-port? : any/c -> boolean? ;; valid-port? : any/c -> boolean?
(define (valid-port? p) (define (valid-port? p)
(and (number? p) (integer? p) (exact? p) (<= 1 p 65535))) (and (number? p) (integer? p) (exact? p) (<= 1 p 65535)))
@ -89,7 +71,7 @@
;; Notes: (GregP) ;; Notes: (GregP)
;; 1. What's the significance of char # 255 ??? ;; 1. What's the significance of char # 255 ???
;; 2. 255 isn't an ascii character. ascii is 7-bit ;; 2. 255 isn't an ascii character. ascii is 7-bit
;; 3. OK fuck this. It is only used in three places, some of them ;; 3. OK f this. It is only used in three places, some of them
;; will involve bytes while the others may involve strings. So ;; will involve bytes while the others may involve strings. So
;; I will just use regular expressions and get on with life. ;; I will just use regular expressions and get on with life.
(define (prefix?-old prefix) (define (prefix?-old prefix)
@ -153,20 +135,6 @@
null null
(regexp-split #rx"/" p))))))) (regexp-split #rx"/" p)))))))
; update-params : Url (U #f String) -> String
; to create a new url just like the old one, but with a different parameter part
;; GREGP: this is broken! replace with the version from new-kernel
; (define (update-params uri params)
; (url->string
; (make-url (url-scheme uri)
; (url-user uri)
; (url-host uri)
; (url-port uri)
; (url-path uri)
; params
; (url-query uri)
; (url-fragment uri))))
; to convert a platform dependent path into a listof path parts such that ; 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))))) ; (forall x (equal? (path->list x) (path->list (apply build-path (path->list x)))))
(define (path->list p) (define (path->list p)
@ -178,19 +146,9 @@
[else ; conflate 'relative and #f [else ; conflate 'relative and #f
new-acc]))))) new-acc])))))
; this should go somewhere that other collections can use it too
(define-syntax provide-define-struct
(lambda (stx)
(syntax-case stx ()
[(_ (struct-name parent-name) (field ...))
(syntax (begin (define-struct (struct-name parent-name) (field ...))
(provide (struct struct-name (field ...)))))]
[(_ struct-name (field ...))
(syntax (begin (define-struct struct-name (field ...))
(provide (struct struct-name (field ...)))))])))
; this is used by launchers ; this is used by launchers
; extract-flag : sym (listof (cons sym alpha)) alpha -> alpha ; extract-flag : sym (listof (cons sym alpha)) alpha -> alpha
; XXX remove
(define (extract-flag name flags default) (define (extract-flag name flags default)
(let ([x (assq name flags)]) (let ([x (assq name flags)])
(if x (if x
@ -199,9 +157,7 @@
; hash-table-empty? : hash-table -> bool ; hash-table-empty? : hash-table -> bool
(define (hash-table-empty? table) (define (hash-table-empty? table)
(let/ec out (zero? (hash-table-count table)))
(hash-table-for-each table (lambda (k v) (out #f)))
#t))
; This comes from Shriram's collection, and should be exported form there. ; This comes from Shriram's collection, and should be exported form there.
; translate-escapes : String -> String ; translate-escapes : String -> String
@ -220,4 +176,20 @@
(cond (cond
[(char=? ic #\+) #\space] [(char=? ic #\+) #\space]
[else ic])) [else ic]))
(list* c (loop cs))]))))) (list* c (loop cs))]))))
(provide/contract
[url-path->string ((listof (or/c string? path/param?)) . -> . string?)]
[extract-flag (symbol? (listof (cons/c symbol? any/c)) any/c . -> . any/c)]
[translate-escapes (string? . -> . string?)]
[hash-table-empty? (any/c . -> . boolean?)]
[valid-port? (any/c . -> . boolean?)]
[decompose-request ((request?) . ->* . (url? symbol? string?))]
[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)))))]
[url-path->path ((or/c (symbols 'up 'same) path?) string? . -> . path?)]
[directory-part (path? . -> . path?)]
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
[exn->string ((or/c exn? any/c) . -> . string?)]
[build-path-unless-absolute (path? (or/c string? path?) . -> . path?)]))

145
collects/web-server/web-cells.ss
View File

@ -1,12 +1,12 @@
(module web-cells mzscheme (module web-cells mzscheme
(require (lib "struct.ss")) (require (lib "struct.ss")
(lib "contract.ss"))
(define-struct (exn:fail:frame:top exn) ()) (define-struct (exn:fail:frame:top exn) ())
(define (exn:fail:frame:top-raise) (define (exn:fail:frame:top-raise)
(raise (make-exn:fail:frame:top (raise (make-exn:fail:frame:top
"Reached top of stack" "Reached top of stack"
(current-continuation-marks)))) (current-continuation-marks))))
(provide exn:fail:frame:top?)
;; frames ;; frames
(define-struct frame ()) (define-struct frame ())
@ -47,12 +47,12 @@
; frame-set? : frame:ns symbol -> boolean ; frame-set? : frame:ns symbol -> boolean
(define (frame-set? a-frame var) (define (frame-set? a-frame var)
(not
(not (not
(namespace-variable-value (not
var #f (namespace-variable-value
(lambda () #f) var #f
(frame:ns-namespace a-frame))))) (lambda () #f)
(frame:ns-namespace a-frame)))))
; frame-set! : frame:ns symbol any -> void ; frame-set! : frame:ns symbol any -> void
; Sets the variable in the frame to a value ; Sets the variable in the frame to a value
@ -62,9 +62,7 @@
#t (frame:ns-namespace a-frame))) #t (frame:ns-namespace a-frame)))
;; frame stacks ;; frame stacks
(define *global-root-id* (gensym)) (define *global-root-id* (gensym))
(define *session-root-id* (gensym))
; *frame-stack* : (box frame) ; *frame-stack* : (box frame)
(define *frame-stack* (define *frame-stack*
@ -80,26 +78,11 @@
(define (global-root? a-frame) (define (global-root? a-frame)
(annotation-present? *global-root-id* a-frame)) (annotation-present? *global-root-id* a-frame))
; session-root? : frame:ns -> boolean
(define (session-root? a-frame)
(annotation-present? *session-root-id* a-frame))
; make-frame/top : -> frame:ns ; make-frame/top : -> frame:ns
(define (make-frame/top) (define (make-frame/top)
(let* ([cur-top-box (*frame-stack*)] (define cur-top-box (*frame-stack*))
[cur-top (unbox cur-top-box)]) (define cur-top (unbox cur-top-box))
(cond (make-frame/parent cur-top-box))
#;[(not (frame:ns? cur-top))
; Construct global
(copy-struct frame:ns (make-frame/parent cur-top-box)
[frame:ns-annotations (list (cons *global-root-id* #t))])]
[(global-root? cur-top)
; Construct session
(copy-struct frame:ns (make-frame/parent cur-top-box)
[frame:ns-annotations (list (cons *session-root-id* #t))])]
[else
; Construct normal
(make-frame/parent cur-top-box)])))
; push-frame! : -> void ; push-frame! : -> void
; Pushs a new frame onto the session stack ; Pushs a new frame onto the session stack
@ -114,10 +97,10 @@
; save-stack/push/return : (-> 'a) -> 'a ; save-stack/push/return : (-> 'a) -> 'a
; Pushes a frame after the thunk's execution with the same parent as the call site ; Pushes a frame after the thunk's execution with the same parent as the call site
(define (save-stack/push/return thunk) (define (save-stack/push/return thunk)
(let ([initial-stack (*frame-stack*)]) (define initial-stack (*frame-stack*))
(begin0 (thunk) (begin0 (thunk)
(*frame-stack* initial-stack) (*frame-stack* initial-stack)
(push-frame!)))) (push-frame!)))
; syntax version of above ; syntax version of above
(define-syntax with-frame-after (define-syntax with-frame-after
@ -143,106 +126,42 @@
; cells ; cells
(define-struct cell (id)) (define-struct cell (id))
(define-struct (cell:global cell) ())
(define-struct (cell:session cell) ())
(define-struct (cell:local cell) ()) (define-struct (cell:local cell) ())
(define web-cell:local? cell:local?)
; ext:make-'a 'b -> 'a ; ext:make-'a 'b -> 'a
(define (ext:make-cell:global default) (define (make-web-cell:local default)
(let ([new-name (gensym)]) (define new-name (gensym))
(frame-set! (search-stack global-root?)
new-name default)
(make-cell:global new-name)))
(define (ext:make-cell:session default)
(let ([new-name (gensym)])
(frame-set! (search-stack global-root?)
new-name default)
(make-cell:session new-name)))
(define (ext:make-cell:local default)
(let ([new-name (gensym)])
(frame-set! (search-stack global-root?)
new-name default)
(make-cell:local new-name)))
; cell:global-ref : cell:global -> any
; returns the value of the global cell
(define (cell:global-ref gc)
(frame-ref (search-stack global-root?)
(cell-id gc)))
; cell:global-set! : cell:global any -> void
; sets the value of the global cell
(define (cell:global-set! gc nv)
(frame-set! (search-stack global-root?) (frame-set! (search-stack global-root?)
(cell-id gc) new-name default)
nv)) (make-cell:local new-name))
; cell:session-ref : cell:session -> any
; returns the value of the session cell
(define (cell:session-ref sc)
(frame-ref (search-stack session-root?)
(cell-id sc)))
; cell:session-set! : cell:session any -> void
; sets the value of the session cell
(define (cell:session-set! sc nv)
(frame-set! (search-stack session-root?)
(cell-id sc)
nv))
; cell:local-ref : cell:local -> any ; cell:local-ref : cell:local -> any
; returns the value of the local cell ; returns the value of the local cell
(define (cell:local-ref lc) (define (web-cell:local-ref lc)
(frame-ref (search-stack frame?) (frame-ref (search-stack frame?)
(cell-id lc))) (cell-id lc)))
; cell:local-set! : cell:local any -> void ; cell:local-set! : cell:local any -> void
; sets the value of the local cell at the last place it was set, including the default ; sets the value of the local cell at the last place it was set, including the default
(define (cell:local-set! lc nv) (define (web-cell:local-set! lc nv)
(frame-set! (search-stack (frame-set! (search-stack
(lambda (f) (frame-set? f (cell-id lc)))) (lambda (f) (frame-set? f (cell-id lc))))
(cell-id lc) (cell-id lc)
nv)) nv))
; cell:local-mask : cell:local any -> void ; cell:local-mask : cell:local any -> void
; masks the local cell to the given value ; masks the local cell to the given value
(define (cell:local-mask lc nv) (define (web-cell:local-mask lc nv)
(frame-set! (search-stack frame?) (frame-set! (search-stack frame?)
(cell-id lc) (cell-id lc)
nv)) nv))
; cell-ref : cell -> any (provide with-frame ; syntax
(define (cell-ref c) with-frame-after)
(cond (provide/contract
[(cell:global? c) (cell:global-ref c)] [exn:fail:frame:top? (any/c . -> . boolean?)]
[(cell:session? c) (cell:session-ref c)] [web-cell:local? (any/c . -> . boolean?)]
[(cell:local? c) (cell:local-ref c)])) [make-web-cell:local (any/c . -> . web-cell:local?)]
[web-cell:local-ref (web-cell:local? . -> . any/c)]
; ;; linking parameters to cells [web-cell:local-set! (web-cell:local? any/c . -> . void)]
; (define *parameter-links* (ext:make-cell:session (list))) [web-cell:local-mask (web-cell:local? any/c . -> . void)]))
; (define-struct parameter-link (parameter cell))
;
; ; link-parameter : parameter cell -> void
; (define (link-parameter p c)
; (cell:session-set! *parameter-links*
; (cons (make-parameter-link p c)
; (cell:session-ref *parameter-links*))))
;
; ; reinstall-linked-parameters : -> void
; (define (reinstall-linked-parameters)
; (for-each (lambda (link)
; ((parameter-link-parameter link)
; (cell-ref (parameter-link-cell link))))
; (cell:session-ref *parameter-links*)))
(provide with-frame
with-frame-after
(rename cell:global? web-cell:global?)
(rename ext:make-cell:global make-web-cell:global)
(rename cell:global-ref web-cell:global-ref)
(rename cell:global-set! web-cell:global-set!)
(rename cell:session? web-cell:session?)
(rename ext:make-cell:session make-web-cell:session)
(rename cell:session-ref web-cell:session-ref)
(rename cell:session-set! web-cell:session-set!)
(rename cell:local? web-cell:local?)
(rename ext:make-cell:local make-web-cell:local)
(rename cell:local-ref web-cell:local-ref)
(rename cell:local-set! web-cell:local-set!)
(rename cell:local-mask web-cell:local-mask)))

9
collects/web-server/web-server-structs.ss
View File

@ -1,9 +1,14 @@
(module web-server-structs mzscheme (module web-server-structs mzscheme
(provide (all-defined)) (require (lib "contract.ss"))
(require "contract.ss")
(define current-server-custodian (make-parameter #f)) (define current-server-custodian (make-parameter #f))
(provide current-server-custodian) ; parameter
;; make-servlet-custodian: -> custodian ;; make-servlet-custodian: -> custodian
;; create a custodian for the dynamic extent of a servlet continuation ;; create a custodian for the dynamic extent of a servlet continuation
(define (make-servlet-custodian) (define (make-servlet-custodian)
(make-custodian (current-server-custodian)))) (make-custodian (current-server-custodian)))
(provide/contract
[make-servlet-custodian (-> custodian?)]))

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

@ -1,9 +1,12 @@
(module web-server-unit mzscheme (module web-server-unit mzscheme
(require (lib "tcp-sig.ss" "net")
(lib "contract.ss")
(lib "unitsig.ss"))
(require "sig.ss" (require "sig.ss"
"dispatch-server-unit.ss"
"dispatch-server-sig.ss"
"web-server-structs.ss" "web-server-structs.ss"
"connection-manager.ss"
"configuration-structures.ss" "configuration-structures.ss"
"servlet.ss"
"private/cache-table.ss" "private/cache-table.ss"
(rename "private/request.ss" (rename "private/request.ss"
the-read-request read-request)) the-read-request read-request))
@ -14,105 +17,9 @@
(prefix path-procedure: "dispatchers/dispatch-pathprocedure.ss") (prefix path-procedure: "dispatchers/dispatch-pathprocedure.ss")
(prefix log: "dispatchers/dispatch-log.ss") (prefix log: "dispatchers/dispatch-log.ss")
(prefix host: "dispatchers/dispatch-host.ss")) (prefix host: "dispatchers/dispatch-host.ss"))
(require (lib "tcp-sig.ss" "net") (provide/contract
(lib "unitsig.ss") ; XXX contract
(lib "string.ss") [web-server@ unit/sig?])
(lib "list.ss")
(lib "url.ss" "net"))
(provide web-server@)
;; ****************************************
(define dispatch-server@
(unit/sig dispatch-server^
(import net:tcp^ (config : dispatch-server-config^))
;; serve: -> -> void
;; start the server and return a thunk to shut it down
(define (serve)
(define the-server-custodian (make-custodian))
(start-connection-manager the-server-custodian)
(parameterize ([current-custodian the-server-custodian]
[current-server-custodian the-server-custodian]
[current-thread-initial-stack-size 3])
(thread
(lambda ()
(start-listener))))
(lambda ()
(custodian-shutdown-all the-server-custodian)))
;; start-listener : -> void
;; loops around starting a listener if the current listener dies
(define (start-listener)
(define listener
(tcp-listen config:port config:max-waiting
#t config:listen-ip))
(define 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
(define (server-loop get-ports port-addresses)
(let loop ()
(define connection-cust (make-custodian))
(parameterize ([current-custodian connection-cust])
(define-values (ip op) (get-ports))
(serve-ports/inner ip op
port-addresses))
(loop)))
;; serve-ports : input-port output-port -> void
;; returns immediately, spawning a thread to handle
;; the connection
;; NOTE: (GregP) should allow the user to pass in a connection-custodian
(define (serve-ports ip op)
(define server-cust (make-custodian))
(start-connection-manager server-cust)
(parameterize ([current-custodian server-cust]
[current-server-custodian server-cust])
(define connection-cust (make-custodian))
(parameterize ([current-custodian connection-cust])
(serve-ports/inner ip op
(lambda (ip)
(values "127.0.0.1"
"127.0.0.1"))))))
;; serve-ports/inner : input-port output-port (input-port -> string string) -> void
;; returns immediately, spawning a thread to handle
(define (serve-ports/inner ip op port-addresses)
(thread
(lambda ()
(define conn
(new-connection config:initial-connection-timeout
ip op (current-custodian) #f))
(with-handlers ([exn:fail:network?
(lambda (e)
(kill-connection! conn)
(raise e))])
(serve-connection conn port-addresses)))))
;; serve-connection: connection (input-port -> string string) -> void
;; respond to all requests on this connection
(define (serve-connection conn port-addresses)
(let connection-loop ()
(define-values (req close?) (config:read-request conn config:port port-addresses))
(unless close?
(set-connection-close?! conn #f))
(adjust-connection-timeout! conn config:initial-connection-timeout)
(config:dispatch conn req)
(when close?
(set-connection-close?! conn #t))
(cond
[(connection-close? conn) (kill-connection! conn)]
[else (connection-loop)])))))
(define web-config@->dispatch-server-config@ (define web-config@->dispatch-server-config@
(unit/sig dispatch-server-config^ (unit/sig dispatch-server-config^

13
collects/web-server/web-server.ss
View File

@ -1,10 +1,15 @@
(module web-server mzscheme (module web-server mzscheme
(require (lib "tcp-sig.ss" "net") (require (lib "tcp-sig.ss" "net")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "contract.ss")
"sig.ss" "sig.ss"
"web-server-unit.ss" "web-server-unit.ss"
"configuration.ss") "configuration.ss"
(provide serve) "configuration-structures.ss")
(provide/contract
[serve (case-> [configuration? . -> . (-> void?)]
[configuration? natural-number/c . -> . (-> void?)]
[configuration? natural-number/c string? . -> . (-> void?)])])
; : configuration [nat] [(U str #f)] -> -> void ; : configuration [nat] [(U str #f)] -> -> void
(define serve (define serve
@ -29,6 +34,4 @@
(serve)) (serve))
s)]) s)])
(export)) (export))
net:tcp^)) net:tcp^)))
)

17
collects/web-server/xexpr-callback.ss
View File

@ -1,17 +0,0 @@
;; Mike Burns 2004
;; Used for send/suspend/callback.
(module xexpr-callback mzscheme
(require (lib "xml.ss" "xml"))
(provide xexpr/callback?)
;; Is it a Xexpr, or an Xexpr with procedures?
(define (xexpr/callback? x)
(correct-xexpr? x
(lambda () #t)
(lambda (exn)
(if (procedure? (exn:invalid-xexpr-code exn))
#t
(begin ((error-display-handler) (exn-message exn) exn)
#f))))))