new keyword contracts

svn: r8622

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
+; XXX
- make-make-servlet-namespace)
+(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?)])

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

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?])
+ [interface-version dispatcher-interface-version?]
-(provide make)
+ [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

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?])
+ [interface-version dispatcher-interface-version?]
-(provide make)  
+ [make (->* ()
+            (#:format format-req/c
+                      #:log-path path-string?)
+            dispatcher?)])
 
 (define interface-version 'v1)
 (define (make #:format [format paren-format]

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?])
+ [interface-version dispatcher-interface-version?]
-(provide make)
+ [make (->* ()
+            (#:password-file path-string?
+                             #:authentication-responder 
+                             (url? header? . -> . response?))
+            (values
+             (-> void)
+             dispatcher?))])
 
 (define interface-version 'v1)
 (define (make ; XXX Take authorized? function

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?])
+ [interface-version dispatcher-interface-version?]
-(provide make)
+ [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 

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)

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?)]
+ [read-mime-types (path-string? . -> . hash-table?)]
- [make-path->mime-type (path? . -> . (path? . -> . bytes?))])
+ [make-path->mime-type (path-string? . -> . (path? . -> . bytes?))])
 
 ; read-mime-types : path? -> hash-table?
 (define (read-mime-types a-path)

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)

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?)]{

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.

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
+ with-errors-to-browser)
- redirect-to)
 (provide/contract
+ [redirect-to
+  (->* (string?) (redirection-status? #:headers (listof header?))
+       response/full?)]
  [redirection-status? (any/c . -> . boolean?)]
  [permanently redirection-status?]
  [temporarily redirection-status?]

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

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@
+; XXX unit? should be particular unit sig
-         configuration-table-sexpr->web-config@)
+(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@ 

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?))])