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

new keyword contracts

Browse Source 
svn: r8622
This commit is contained in:
Jay McCarthy 2008-02-11 21:35:02 +00:00
parent e958a5af7a
commit 533266f2dd
15 changed files with 120 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/web-server/configuration/namespace.ss
View File

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

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

@ -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

14
collects/web-server/dispatchers/dispatch-lang.ss
View File

@ -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

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

@ -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]

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

@ -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

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

@ -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

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

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

4
collects/web-server/private/mime-types.ss
View File

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

2
collects/web-server/run.ss
View File

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

2
collects/web-server/scribblings/dispatchers.scrbl
View File

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

2
collects/web-server/scribblings/managers.scrbl
View File

@ -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.

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

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

2
collects/web-server/tests/lang/anormal-test.ss
View File

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

20
collects/web-server/web-config-unit.ss
View File

@ -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@

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

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