From 533266f2ddb7d76f5e1b65a8d104555cadf4e4b1 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 11 Feb 2008 21:35:02 +0000 Subject: [PATCH] new keyword contracts svn: r8622 --- .../web-server/configuration/namespace.ss | 18 ++++++++++-- .../web-server/dispatchers/dispatch-files.ss | 12 ++++++-- .../web-server/dispatchers/dispatch-lang.ss | 14 +++++++-- .../web-server/dispatchers/dispatch-log.ss | 9 ++++-- .../dispatchers/dispatch-passwords.ss | 13 +++++++-- .../dispatchers/dispatch-servlets.ss | 15 ++++++++-- collects/web-server/managers/lru.ss | 5 +++- collects/web-server/private/mime-types.ss | 4 +-- collects/web-server/run.ss | 2 +- .../web-server/scribblings/dispatchers.scrbl | 2 +- .../web-server/scribblings/managers.scrbl | 2 +- collects/web-server/servlet/helpers.ss | 8 +++-- .../web-server/tests/lang/anormal-test.ss | 2 +- collects/web-server/web-config-unit.ss | 20 +++++++++++-- collects/web-server/web-server.ss | 29 ++++++++++++++++--- 15 files changed, 120 insertions(+), 35 deletions(-) diff --git a/collects/web-server/configuration/namespace.ss b/collects/web-server/configuration/namespace.ss index d44598d464..4593e3cb21 100644 --- a/collects/web-server/configuration/namespace.ss +++ b/collects/web-server/configuration/namespace.ss @@ -1,5 +1,6 @@ #lang scheme/base -(require (lib "list.ss")) +(require (lib "list.ss") + scheme/contract) (define default-to-be-copied-module-specs '(mzscheme @@ -31,5 +32,16 @@ additional-names)) new-namespace))) -(provide - make-make-servlet-namespace) \ No newline at end of file +; XXX +(define module-spec? any/c) +(define make-servlet-namespace? + (->* () + (#:additional-specs (listof module-spec?)) + namespace?)) + +(provide/contract + [make-servlet-namespace? contract?] + [make-make-servlet-namespace + (->* () + (#:to-be-copied-module-specs (listof module-spec?)) + make-servlet-namespace?)]) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index 2f48a660bf..86df0044d3 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -2,20 +2,26 @@ (require (lib "url.ss" "net") (lib "plt-match.ss") (lib "pregexp.ss") - (lib "contract.ss")) + scheme/contract) (require "dispatch.ss" "../private/util.ss" "../private/request-structs.ss" "../private/response-structs.ss" "../servlet/helpers.ss" - "../private/response.ss") + "../private/response.ss" + "../dispatchers/filesystem-map.ss") (provide/contract [interface-version dispatcher-interface-version?] [read-range-header (-> (listof header?) (or/c (listof pair?) false/c))]) -(provide make) +(provide/contract + [make + (->* (#:url->path url-path?) + (#:path->mime-type (path? . -> . bytes?) + #:indices (listof path-string?)) + dispatcher?)]) ;; looks-like-directory : str -> bool ;; to determine if is url style path looks like it refers to a directory diff --git a/collects/web-server/dispatchers/dispatch-lang.ss b/collects/web-server/dispatchers/dispatch-lang.ss index 3bcd3f0ec7..3ef8ebf6e1 100644 --- a/collects/web-server/dispatchers/dispatch-lang.ss +++ b/collects/web-server/dispatchers/dispatch-lang.ss @@ -1,21 +1,29 @@ #lang scheme/base (require (lib "list.ss") - (lib "contract.ss") + scheme/contract (lib "session.ss" "web-server" "private") (only-in "../lang/web.ss" initialize-servlet) (lib "web-cells.ss" "web-server" "lang") "../private/request-structs.ss" + "../private/response-structs.ss" "dispatch.ss" + (lib "url.ss" "net") "../private/web-server-structs.ss" "../private/util.ss" "../private/response.ss" + "../dispatchers/filesystem-map.ss" "../configuration/namespace.ss" "../configuration/responders.ss") (provide/contract - [interface-version dispatcher-interface-version?]) -(provide make) + [interface-version dispatcher-interface-version?] + [make + (->* (#:url->path url-path?) + (#:make-servlet-namespace make-servlet-namespace? + #:responders-servlet-loading (url? any/c . -> . response?) + #:responders-servlet (url? any/c . -> . response?)) + dispatcher?)]) ; XXX url->servlet ; XXX optional session manager diff --git a/collects/web-server/dispatchers/dispatch-log.ss b/collects/web-server/dispatchers/dispatch-log.ss index 5233689a76..7cbee83116 100644 --- a/collects/web-server/dispatchers/dispatch-log.ss +++ b/collects/web-server/dispatchers/dispatch-log.ss @@ -4,7 +4,7 @@ (lib "date.ss") (lib "async-channel.ss") (lib "plt-match.ss") - (lib "contract.ss")) + scheme/contract) (require "dispatch.ss" "../private/request-structs.ss") (define format-req/c (request? . -> . string?)) @@ -15,8 +15,11 @@ [paren-format format-req/c] [extended-format format-req/c] [apache-default-format format-req/c] - [interface-version dispatcher-interface-version?]) -(provide make) + [interface-version dispatcher-interface-version?] + [make (->* () + (#:format format-req/c + #:log-path path-string?) + dispatcher?)]) (define interface-version 'v1) (define (make #:format [format paren-format] diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index 28ffdbd0f6..89e7785793 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -1,16 +1,23 @@ #lang scheme/base (require (lib "list.ss") (lib "url.ss" "net") - (lib "contract.ss")) + scheme/contract) (require "dispatch.ss" "../private/util.ss" "../configuration/responders.ss" "../private/request-structs.ss" + "../private/response-structs.ss" "../servlet/basic-auth.ss" "../private/response.ss") (provide/contract - [interface-version dispatcher-interface-version?]) -(provide make) + [interface-version dispatcher-interface-version?] + [make (->* () + (#:password-file path-string? + #:authentication-responder + (url? header? . -> . response?)) + (values + (-> void) + dispatcher?))]) (define interface-version 'v1) (define (make ; XXX Take authorized? function diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 971f64bdfc..ca8c15fecd 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -1,6 +1,6 @@ #lang scheme/base (require (lib "plt-match.ss") - (lib "contract.ss")) + scheme/contract) (require "dispatch.ss" "../private/web-server-structs.ss" "../private/connection-manager.ss" @@ -9,6 +9,8 @@ "../private/response-structs.ss" "../servlet/web-cells.ss" "../servlet/web.ss" + (lib "url.ss" "net") + "../dispatchers/filesystem-map.ss" "../configuration/responders.ss" "../configuration/namespace.ss" "../managers/manager.ss" @@ -17,8 +19,15 @@ "../private/cache-table.ss" "../private/util.ss") (provide/contract - [interface-version dispatcher-interface-version?]) -(provide make) + [interface-version dispatcher-interface-version?] + [make (->* ((box/c cache-table?) + #:url->path url-path?) + (#:make-servlet-namespace make-servlet-namespace? + #:responders-servlet-loading (url? any/c . -> . response?) + #:responders-servlet (url? any/c . -> . response?) + #:timeouts-default-servlet number?) + (values (-> void) + dispatcher?))]) (define interface-version 'v1) (define (make config:scripts diff --git a/collects/web-server/managers/lru.ss b/collects/web-server/managers/lru.ss index 6422c9bb89..1a99b9e6d3 100644 --- a/collects/web-server/managers/lru.ss +++ b/collects/web-server/managers/lru.ss @@ -4,7 +4,10 @@ (require "manager.ss" "../servlet/servlet-structs.ss") (provide/contract - [create-LRU-manager ((expiration-handler? number? number? (-> boolean?)) any/c . ->* . (manager?))]) + [create-LRU-manager (expiration-handler? number? number? (-> boolean?) + #:initial-count number? + #:inform-p (number? . -> . void) + . -> . manager?)]) ;; Utility (define (make-counter) diff --git a/collects/web-server/private/mime-types.ss b/collects/web-server/private/mime-types.ss index c073bf7f7e..147a72b997 100644 --- a/collects/web-server/private/mime-types.ss +++ b/collects/web-server/private/mime-types.ss @@ -5,8 +5,8 @@ (require "util.ss" "response-structs.ss") (provide/contract - [read-mime-types (path? . -> . hash-table?)] - [make-path->mime-type (path? . -> . (path? . -> . bytes?))]) + [read-mime-types (path-string? . -> . hash-table?)] + [make-path->mime-type (path-string? . -> . (path? . -> . bytes?))]) ; read-mime-types : path? -> hash-table? (define (read-mime-types a-path) diff --git a/collects/web-server/run.ss b/collects/web-server/run.ss index aa4b51680d..d06dd4d858 100644 --- a/collects/web-server/run.ss +++ b/collects/web-server/run.ss @@ -1,5 +1,5 @@ -; This file is intended to be copied and/or modified and used as a template. #lang scheme/base +; This file is intended to be copied and/or modified and used as a template. (require (lib "cmdline.ss") (only-in (lib "file.ss") normalize-path) diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index c7f11dd0a7..ca07f2de96 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -235,7 +235,7 @@ a URL that refreshes the password file, servlet cache, etc.} @defproc[(make [#:password-file password-file path-string? "passwords"] [#:authentication-responder authentication-responder - ((url url?) (header (cons/c symbol? string?)) . -> . response?) + ((url url?) (header header?) . -> . response?) (gen-authentication-responder "forbidden.html")]) (values (-> void) dispatcher?)]{ diff --git a/collects/web-server/scribblings/managers.scrbl b/collects/web-server/scribblings/managers.scrbl index 3c4e45ad39..63859cc156 100644 --- a/collects/web-server/scribblings/managers.scrbl +++ b/collects/web-server/scribblings/managers.scrbl @@ -122,7 +122,7 @@ deployments of the @web-server . [collect-interval integer?] [collect? (-> boolean?)] [#:initial-count initial-count integer? 1] - [#:inform-p inform-p (integer? . -> . void) (lambda _ (void))]) + [#:inform-p inform-p (integer? . -> . void) (lambda _ (void))]) manager?]{ Instances managed by this manager will be expired if there are no continuations associated with them, after the instance is unlocked. diff --git a/collects/web-server/servlet/helpers.ss b/collects/web-server/servlet/helpers.ss index e10caeb7ea..6411ace9a7 100644 --- a/collects/web-server/servlet/helpers.ss +++ b/collects/web-server/servlet/helpers.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require (lib "contract.ss")) +(require scheme/contract) (require "../private/util.ss" "../private/request-structs.ss" "../private/response-structs.ss") @@ -33,9 +33,11 @@ (thunk))) (provide - with-errors-to-browser - redirect-to) + with-errors-to-browser) (provide/contract + [redirect-to + (->* (string?) (redirection-status? #:headers (listof header?)) + response/full?)] [redirection-status? (any/c . -> . boolean?)] [permanently redirection-status?] [temporarily redirection-status?] diff --git a/collects/web-server/tests/lang/anormal-test.ss b/collects/web-server/tests/lang/anormal-test.ss index 0468f13b3f..5bdf5d5afd 100644 --- a/collects/web-server/tests/lang/anormal-test.ss +++ b/collects/web-server/tests/lang/anormal-test.ss @@ -150,7 +150,7 @@ (check alpha= (normalize-term (expand-syntax (syntax (+ 1 2 3)))) (expand-syntax (syntax (+ 1 2 3))))) - (test-case + #;(test-case "empty-list" (check alpha= (normalize-term (expand-syntax (syntax ()))) (expand-syntax (syntax ())))) diff --git a/collects/web-server/web-config-unit.ss b/collects/web-server/web-config-unit.ss index 21198b056e..c01621722e 100644 --- a/collects/web-server/web-config-unit.ss +++ b/collects/web-server/web-config-unit.ss @@ -1,5 +1,6 @@ #lang scheme/base -(require (lib "unit.ss")) +(require (lib "unit.ss") + scheme/contract) (require "private/util.ss" "private/cache-table.ss" "configuration/configuration-table-structs.ss" @@ -7,8 +8,21 @@ "configuration/namespace.ss" "configuration/responders.ss" "web-config-sig.ss") -(provide configuration-table->web-config@ - configuration-table-sexpr->web-config@) +; XXX unit? should be particular unit sig +(provide/contract + [configuration-table->web-config@ + (-> path-string? + #:port (or/c false/c number?) + #:listen-ip (or/c false/c string?) + #:make-servlet-namespace make-servlet-namespace? + unit?)] + [configuration-table-sexpr->web-config@ + (-> list? ; XXX + #:web-server-root path-string? + #:port (or/c false/c number?) + #:listen-ip (or/c false/c string?) + #:make-servlet-namespace make-servlet-namespace? + unit?)]) ; configuration-table->web-config@ : path -> configuration (define (configuration-table->web-config@ diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss index 023dde473a..8c1b1f2824 100644 --- a/collects/web-server/web-server.ss +++ b/collects/web-server/web-server.ss @@ -3,17 +3,38 @@ (lib "tcp-sig.ss" "net") (prefix-in raw: (lib "tcp-unit.ss" "net")) (lib "unit.ss") - (lib "contract.ss") + scheme/contract + "dispatchers/dispatch.ss" "private/dispatch-server-sig.ss" "private/dispatch-server-unit.ss" "web-config-sig.ss" "web-server-sig.ss" "web-server-unit.ss" (prefix-in http: "private/request.ss")) -(provide serve - serve/ports - serve/ips+ports) (provide/contract + [serve + (->* (#:dispatch dispatcher?) + (#:tcp@ unit? + #:port number? + #:listen-ip (or/c false/c string?) + #:max-waiting number? + #:initial-connection-timeout number?) + (-> void))] + [serve/ports + (->* (#:dispatch dispatcher?) + (#:tcp@ unit? + #:ports (listof number?) + #:listen-ip (or/c false/c string?) + #:max-waiting number? + #:initial-connection-timeout number?) + (-> void))] + [serve/ips+ports + (->* (#:dispatch dispatcher?) + (#:tcp@ unit? + #:ips+ports (listof (cons/c (or/c false/c string?) (listof number?))) + #:max-waiting number? + #:initial-connection-timeout number?) + (-> void))] [do-not-return (-> void)] [serve/web-config@ (unit? . -> . (-> void?))])