From a687555c38a0acf49cf763a341021acd3d76a638 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 19 Nov 2008 22:22:02 +0000 Subject: [PATCH 01/29] moving tests svn: r12512 --- collects/{ => tests}/web-server/template/examples/basic.html | 0 collects/{ => tests}/web-server/template/examples/if.html | 0 collects/{ => tests}/web-server/template/examples/run.ss | 0 collects/{ => tests}/web-server/template/examples/static.html | 0 4 files changed, 0 insertions(+), 0 deletions(-) rename collects/{ => tests}/web-server/template/examples/basic.html (100%) rename collects/{ => tests}/web-server/template/examples/if.html (100%) rename collects/{ => tests}/web-server/template/examples/run.ss (100%) rename collects/{ => tests}/web-server/template/examples/static.html (100%) diff --git a/collects/web-server/template/examples/basic.html b/collects/tests/web-server/template/examples/basic.html similarity index 100% rename from collects/web-server/template/examples/basic.html rename to collects/tests/web-server/template/examples/basic.html diff --git a/collects/web-server/template/examples/if.html b/collects/tests/web-server/template/examples/if.html similarity index 100% rename from collects/web-server/template/examples/if.html rename to collects/tests/web-server/template/examples/if.html diff --git a/collects/web-server/template/examples/run.ss b/collects/tests/web-server/template/examples/run.ss similarity index 100% rename from collects/web-server/template/examples/run.ss rename to collects/tests/web-server/template/examples/run.ss diff --git a/collects/web-server/template/examples/static.html b/collects/tests/web-server/template/examples/static.html similarity index 100% rename from collects/web-server/template/examples/static.html rename to collects/tests/web-server/template/examples/static.html From 117f01698220739fe967a40f91e1db65f7b06d56 Mon Sep 17 00:00:00 2001 From: John Clements Date: Wed, 19 Nov 2008 22:31:39 +0000 Subject: [PATCH 02/29] 4.1.3 history update svn: r12513 --- doc/release-notes/stepper/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index b80dff5077..fe02426a99 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,6 +1,10 @@ Stepper ------- +Changes for v4.1.3: + +Minor bug fixes. + Changes for v4.1.2: None. From 8f0544f37d0d7d061852c6eda3dcb7237e30c741 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 19 Nov 2008 22:41:49 +0000 Subject: [PATCH 03/29] Bug after moving instance lookup inside servlet namespace svn: r12514 --- .../dispatchers/dispatch-servlets.ss | 18 +--------- collects/web-server/private/servlet.ss | 4 --- collects/web-server/servlet/setup.ss | 33 +++++++++++-------- 3 files changed, 21 insertions(+), 34 deletions(-) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index cf0147436f..a28932d4db 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -51,10 +51,6 @@ #:responders-servlet (url? any/c . -> . response?)) dispatcher/c)]) -;; default-server-instance-expiration-handler : (request -> response) -(define (default-servlet-instance-expiration-handler req) - (next-dispatcher)) - (define (make url->servlet #:responders-servlet-loading [responders-servlet-loading servlet-loading-responder] #:responders-servlet [responders-servlet servlet-error-responder]) @@ -70,15 +66,6 @@ (define response (with-handlers ([exn:fail:filesystem:exists? (lambda (the-exn) (next-dispatcher))] - [exn:fail:servlet-manager:no-instance? - (lambda (the-exn) - ((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))] - [exn:fail:servlet-manager:no-continuation? - (lambda (the-exn) - ((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))] - [exn:fail:servlet:instance? - (lambda (the-exn) - (default-servlet-instance-expiration-handler req))] [(lambda (x) #t) (lambda (the-exn) (responders-servlet-loading uri the-exn))]) (define the-servlet (url->servlet uri)) @@ -87,10 +74,7 @@ [current-directory (servlet-directory the-servlet)] [current-namespace (servlet-namespace the-servlet)]) (with-handlers ([(lambda (x) #t) - (lambda (exn) - (responders-servlet - (request-uri req) - exn))]) + (lambda (exn) (responders-servlet uri exn))]) (call-with-continuation-barrier (lambda () (call-with-continuation-prompt diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss index 392d740b75..482f394fff 100644 --- a/collects/web-server/private/servlet.ss +++ b/collects/web-server/private/servlet.ss @@ -4,7 +4,6 @@ web-server/http) (define servlet-prompt (make-continuation-prompt-tag 'servlet)) -(define-struct (exn:fail:servlet:instance exn:fail) ()) (define-struct servlet (custodian namespace manager directory handler) #:mutable) (define-struct execution-context (request)) @@ -18,9 +17,6 @@ (provide/contract [servlet-prompt continuation-prompt-tag?] - [struct (exn:fail:servlet:instance exn:fail) - ([message string?] - [continuation-marks continuation-mark-set?])] [struct servlet ([custodian custodian?] [namespace namespace?] diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index 2cecb0b0d5..b3d85f1451 100644 --- a/collects/web-server/servlet/setup.ss +++ b/collects/web-server/servlet/setup.ss @@ -49,19 +49,26 @@ (lambda (req) (define uri (request-uri req)) - (define-values (instance-id handler) - (cond - [(continuation-url? uri) - => (match-lambda - [(list instance-id k-id salt) - (values instance-id - (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])] - [else - (values ((manager-create-instance manager) (exit-handler)) - start)])) - - (parameterize ([current-servlet-instance-id instance-id]) - (handler req))))) + (with-handlers ([exn:fail:servlet-manager:no-instance? + (lambda (the-exn) + ((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))] + [exn:fail:servlet-manager:no-continuation? + (lambda (the-exn) + ((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))]) + + (define-values (instance-id handler) + (cond + [(continuation-url? uri) + => (match-lambda + [(list instance-id k-id salt) + (values instance-id + (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])] + [else + (values ((manager-create-instance manager) (exit-handler)) + start)])) + + (parameterize ([current-servlet-instance-id instance-id]) + (handler req)))))) (define (make-stateless.servlet directory start) (define ses From 8dad54e520a10471b1879b2f960365b1fa718301 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 19 Nov 2008 22:49:43 +0000 Subject: [PATCH 04/29] Fix doc typo. svn: r12515 --- collects/net/scribblings/url.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/net/scribblings/url.scrbl b/collects/net/scribblings/url.scrbl index 43fa60828c..287c374e2c 100644 --- a/collects/net/scribblings/url.scrbl +++ b/collects/net/scribblings/url.scrbl @@ -44,7 +44,7 @@ re-exported by @schememodname[net/url].} [query (listof (cons/c symbol? (or/c false/c string?)))] [fragment (or/c false/c string?)])]{ -The basic structure for all URLs, hich is explained in RFC 3986 +The basic structure for all URLs, which is explained in RFC 3986 @cite["RFC3986"]. The following diagram illustrates the parts: @verbatim[#:indent 2]|{ From a4ac14b124cb70127897fcb117d4d9312ab17518 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 19 Nov 2008 22:50:10 +0000 Subject: [PATCH 05/29] Add scheme/tcp bindings. svn: r12516 --- collects/typed-scheme/private/base-env.ss | 15 ++++++++++++++- .../private/type-effect-convenience.ss | 3 ++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 1bcfa78f87..641376322e 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -2,6 +2,7 @@ (require scheme/list + scheme/tcp (only-in rnrs/lists-6 fold-left) '#%paramz (only-in '#%kernel [apply kernel:apply]) @@ -480,4 +481,16 @@ [eof (-val eof)] [read-accept-reader (-Param B B)] -[maybe-print-message (-String . -> . -Void)] \ No newline at end of file +[maybe-print-message (-String . -> . -Void)] + +;; scheme/tcp +[tcp-listener? (make-pred-ty -TCP-Listener)] +[tcp-abandon-port (-Port . -> . -Void)] +[tcp-accept (-TCP-Listener . -> . (-values (list -Input-Port -Output-Port)) )] +[tcp-accept/enable-break (-TCP-Listener . -> . (-values (list -Input-Port -Output-Port)) )] +[tcp-accept-ready? (-TCP-Listener . -> . B )] +[tcp-addresses (-Port . -> . (-values (list N N)))] +[tcp-close (-TCP-Listener . -> . -Void )] +[tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] +[tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] +[tcp-listen (N . -> . -TCP-Listener)] \ No newline at end of file diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 6776fe5419..217e0c0c7d 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -12,7 +12,7 @@ scheme/promise (for-syntax macro-debugger/stxclass/stxclass) (for-syntax scheme/base) - (for-template scheme/base scheme/contract)) + (for-template scheme/base scheme/contract scheme/tcp)) (provide (all-defined-out) ;; these should all eventually go away @@ -134,6 +134,7 @@ (define -Namespace (make-Base 'Namespace #'namespace?)) (define -Output-Port (make-Base 'Output-Port #'output-port?)) (define -Input-Port (make-Base 'Input-Port #'input-port?)) +(define -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener?)) (define -Syntax make-Syntax) (define -HT make-Hashtable) From 66b9b932ef7d5b5eec53731ec7f196ba4d6b263f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 19 Nov 2008 22:50:54 +0000 Subject: [PATCH 06/29] Refactor require/typed/provide and dt into new private dir. svn: r12517 --- collects/typed/framework/framework.ss | 3 ++- collects/typed/mred/mred.ss | 10 +--------- collects/typed/private/utils.ss | 11 +++++++++++ 3 files changed, 14 insertions(+), 10 deletions(-) create mode 100644 collects/typed/private/utils.ss diff --git a/collects/typed/framework/framework.ss b/collects/typed/framework/framework.ss index fab2f91dff..513cfa1d29 100644 --- a/collects/typed/framework/framework.ss +++ b/collects/typed/framework/framework.ss @@ -1,6 +1,7 @@ #lang typed-scheme -(require (only-in typed/mred/mred dt require/typed/provide Font%)) +(require typed/private/utils + (only-in typed/mred/mred Font%)) (dt Style-List% (Class () () diff --git a/collects/typed/mred/mred.ss b/collects/typed/mred/mred.ss index 03f60efbd5..80984c28a8 100644 --- a/collects/typed/mred/mred.ss +++ b/collects/typed/mred/mred.ss @@ -1,14 +1,6 @@ #lang typed-scheme -(define-syntax-rule (dt nm t) - (begin (define-type-alias nm t) (provide nm))) - -(define-syntax-rule (require/typed/provide lib [nm t] ...) - (begin - (require/typed lib [nm t] ...) - (provide nm ...))) - -(provide dt require/typed/provide) +(require typed/private/utils) (dt Bitmap% (Class (Number Number Boolean) () diff --git a/collects/typed/private/utils.ss b/collects/typed/private/utils.ss new file mode 100644 index 0000000000..c1fdbea7f6 --- /dev/null +++ b/collects/typed/private/utils.ss @@ -0,0 +1,11 @@ +#lang typed-scheme + +(define-syntax-rule (dt nm t) + (begin (define-type-alias nm t) (provide nm))) + +(define-syntax-rule (require/typed/provide lib [nm t] ...) + (begin + (require/typed lib [nm t] ...) + (provide nm ...))) + +(provide dt require/typed/provide) From 7124d1e1a1a4e04f4fb23fb2a2d02a82fd6b5426 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 19 Nov 2008 22:51:24 +0000 Subject: [PATCH 07/29] Typed wrappers for file/gif and almost all of net/*. svn: r12518 --- collects/typed/file/gif.ss | 17 ++++++++ collects/typed/net/base64.ss | 13 ++++++ collects/typed/net/cgi.ss | 27 +++++++++++++ collects/typed/net/cookie.ss | 23 +++++++++++ collects/typed/net/dns.ss | 10 +++++ collects/typed/net/ftp.ss | 16 ++++++++ collects/typed/net/gifwrite.ss | 4 ++ collects/typed/net/head.ss | 31 ++++++++++++++ collects/typed/net/imap.ss | 55 +++++++++++++++++++++++++ collects/typed/net/mime.ss | 71 +++++++++++++++++++++++++++++++++ collects/typed/net/nntp.ss | 31 ++++++++++++++ collects/typed/net/pop3.ss | 38 ++++++++++++++++++ collects/typed/net/qp.ss | 10 +++++ collects/typed/net/sendmail.ss | 12 ++++++ collects/typed/net/sendurl.ss | 9 +++++ collects/typed/net/smtp.ss | 11 +++++ collects/typed/net/uri-codec.ss | 15 +++++++ collects/typed/net/url.ss | 59 +++++++++++++++++++++++++++ 18 files changed, 452 insertions(+) create mode 100644 collects/typed/file/gif.ss create mode 100644 collects/typed/net/base64.ss create mode 100644 collects/typed/net/cgi.ss create mode 100644 collects/typed/net/cookie.ss create mode 100644 collects/typed/net/dns.ss create mode 100644 collects/typed/net/ftp.ss create mode 100644 collects/typed/net/gifwrite.ss create mode 100644 collects/typed/net/head.ss create mode 100644 collects/typed/net/imap.ss create mode 100644 collects/typed/net/mime.ss create mode 100644 collects/typed/net/nntp.ss create mode 100644 collects/typed/net/pop3.ss create mode 100644 collects/typed/net/qp.ss create mode 100644 collects/typed/net/sendmail.ss create mode 100644 collects/typed/net/sendurl.ss create mode 100644 collects/typed/net/smtp.ss create mode 100644 collects/typed/net/uri-codec.ss create mode 100644 collects/typed/net/url.ss diff --git a/collects/typed/file/gif.ss b/collects/typed/file/gif.ss new file mode 100644 index 0000000000..3a17435eb0 --- /dev/null +++ b/collects/typed/file/gif.ss @@ -0,0 +1,17 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/opaque-type GIF-Stream gif-stream? file/gif) + +(require/typed/provide file/gif + [gif-start ( Output-Port Number Number Number (U #f (Listof (Vectorof Number))) -> Void )] + [gif-add-image ( GIF-Stream Number Number Number Number Boolean (U #f Number) String -> Void )] + [gif-add-control ( GIF-Stream Symbol Boolean Number (U #f Number) -> Void)] + [gif-add-loop-control ( GIF-Stream Number -> Void )] + [gif-add-comment ( GIF-Stream String -> Void )] + [gif-end ( GIF-Stream -> Void )] + [quantize ( String -> (values String (Listof (Vectorof Number)) (U #f (Vectorof Number))))]) + +(provide gif-stream? GIF-Stream) + \ No newline at end of file diff --git a/collects/typed/net/base64.ss b/collects/typed/net/base64.ss new file mode 100644 index 0000000000..13061e4ea5 --- /dev/null +++ b/collects/typed/net/base64.ss @@ -0,0 +1,13 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/base64 + [base64-encode-stream (case-lambda (Input-Port Output-Port -> Void) + (Input-Port Output-Port Bytes -> Void))] + [base64-decode-stream (Input-Port Output-Port -> Void)] + [base64-encode (Bytes -> Bytes)] + [base64-decode (Bytes -> Bytes)]) + +(provide base64-encode-stream base64-decode-stream base64-encode base64-decode) + \ No newline at end of file diff --git a/collects/typed/net/cgi.ss b/collects/typed/net/cgi.ss new file mode 100644 index 0000000000..7287e6f073 --- /dev/null +++ b/collects/typed/net/cgi.ss @@ -0,0 +1,27 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require-typed-struct cgi-error () net/cgi) +(require-typed-struct incomplete-%-suffix ([chars : (Listof Char)]) net/cgi) +(require-typed-struct invalid-%-suffix ([char : Char]) net/cgi) + +(require/typed/provide net/cgi + [get-bindings (-> (Listof (cons (U Symbol String) String)))] + [get-bindings/post (-> (Listof (Pair (U Symbol String) String)))] + [get-bindings/get (-> (Listof (Pair (U Symbol String) String)) )] + [output-http-headers (-> Void)] + [generate-html-output (case-lambda (String (Listof String) -> Void) + (String (Listof String) String String String String String -> Void))] + [generate-error-output ((Listof String) -> (U))] + [bindings-as-html ((Listof (cons (U Symbol String) String)) -> (Listof String))] + [extract-bindings ((U Symbol String) (Listof (cons (U Symbol String) String)) -> ( Listof String))] + [extract-binding/single ((U Symbol String) (Listof (Pair (U Symbol String) String)) -> String)] + [get-cgi-method (-> (U "GET" "POST"))] + [string->html (String -> String)] + [generate-link-text (String String -> String)]) + +(provide + (struct-out cgi-error) + (struct-out incomplete-%-suffix) + (struct-out invalid-%-suffix)) \ No newline at end of file diff --git a/collects/typed/net/cookie.ss b/collects/typed/net/cookie.ss new file mode 100644 index 0000000000..f2ff60224c --- /dev/null +++ b/collects/typed/net/cookie.ss @@ -0,0 +1,23 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/opaque-type Cookie cookie? net/cookie) + +(require/typed/provide net/cookie + [set-cookie (String String -> Cookie)] + [cookie:add-comment (Cookie String -> Cookie)] + [cookie:add-domain (Cookie String -> Cookie)] + [cookie:add-max-age (Cookie Number -> Cookie)] + [cookie:add-path (Cookie String -> Cookie)] + [cookie:secure (Cookie Boolean -> Cookie)] + [cookie:version (Cookie Number -> Cookie)] + + [print-cookie (Cookie -> String)] + + [get-cookie (String String -> (Listof String))] + [get-cookie/single (String String -> (Option String))]) + +(require-typed-struct cookie-error () net/cookie) + +(provide Cookie cookie? (struct-out cookie-error)) \ No newline at end of file diff --git a/collects/typed/net/dns.ss b/collects/typed/net/dns.ss new file mode 100644 index 0000000000..24ef679f81 --- /dev/null +++ b/collects/typed/net/dns.ss @@ -0,0 +1,10 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/dns + [dns-get-address (String String -> String)] + [dns-get-name (String String -> String)] + [dns-get-mail-exchanger (String String -> String )] + [dns-find-nameserver (-> (Option String))]) + diff --git a/collects/typed/net/ftp.ss b/collects/typed/net/ftp.ss new file mode 100644 index 0000000000..041befc0d5 --- /dev/null +++ b/collects/typed/net/ftp.ss @@ -0,0 +1,16 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/opaque-type FTP-Connection ftp-connection? net/ftp) + +(require/typed/provide net/ftp + [ftp-cd (FTP-Connection String -> Void)] + [ftp-establish-connection (String Number String String -> FTP-Connection)] + [ftp-close-connection (FTP-Connection -> Void)] + [ftp-directory-list (FTP-Connection -> (Listof (List (U "-" "d" "l") String String)))] + [ftp-download-file (FTP-Connection Path String -> Void)] + [ftp-make-file-seconds (String -> Number)]) + +(provide ftp-connection? FTP-Connection) + diff --git a/collects/typed/net/gifwrite.ss b/collects/typed/net/gifwrite.ss new file mode 100644 index 0000000000..cfe9167c5b --- /dev/null +++ b/collects/typed/net/gifwrite.ss @@ -0,0 +1,4 @@ +#lang typed-scheme + +(require typed/file/gif) +(provide (all-from-out typed/file/gif)) diff --git a/collects/typed/net/head.ss b/collects/typed/net/head.ss new file mode 100644 index 0000000000..958eea1ef7 --- /dev/null +++ b/collects/typed/net/head.ss @@ -0,0 +1,31 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/head + [empty-header String] + [validate-header (String -> Void)] + [extract-field (Bytes (U Bytes String) -> (Option Bytes))] + [remove-field (String String -> String)] + [insert-field (String String String -> String)] + [replace-field (String String String -> String)] + [extract-all-fields ((U String Bytes) -> (Listof (cons (U String Bytes) (U Bytes String))))] + [append-headers (String String -> String)] + [standard-message-header (String (Listof String) (Listof String) (Listof String) String -> String)] + [data-lines->data ((Listof String) -> String)] + [extract-addresses (String Symbol -> (U (Listof String) (Listof (Listof String))))] + [assemble-address-field ((Listof String) -> String)]) + +(provide + empty-header + validate-header + extract-field + remove-field + insert-field + replace-field + extract-all-fields + append-headers + standard-message-header + data-lines->data + extract-addresses + assemble-address-field) \ No newline at end of file diff --git a/collects/typed/net/imap.ss b/collects/typed/net/imap.ss new file mode 100644 index 0000000000..a4639fad19 --- /dev/null +++ b/collects/typed/net/imap.ss @@ -0,0 +1,55 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/opaque-type IMAP-Connection imap-connection? net/imap) + +(define-type-alias bstring (U String Bytes)) + +(require/typed/provide net/imap + [imap-port-number (Number -> Void)] + + [imap-connect (String String String String -> (values IMAP-Connection Number Number))] + [imap-connect* (Number Number String String String -> (values IMAP-Connection Number Number))] + [imap-disconnect (IMAP-Connection -> Void)] + [imap-force-disconnect (IMAP-Connection -> Void)] + [imap-reselect (IMAP-Connection String -> (values Number Number))] + [imap-examine (IMAP-Connection String -> (values Number Number))] + [imap-noop (IMAP-Connection -> (values Number Number))] + [imap-status (IMAP-Connection String (Listof Symbol) -> (Listof (Listof Number)))] + [imap-poll (IMAP-Connection -> Void)] + + [imap-new? (IMAP-Connection -> Boolean)] + [imap-messages (IMAP-Connection -> Number)] + [imap-recent (IMAP-Connection -> Number)] + [imap-uidnext (IMAP-Connection -> (Option Number))] + [imap-uidvalidity (IMAP-Connection -> (Option Number))] + [imap-unseen (IMAP-Connection -> (Option Number))] + [imap-reset-new! (IMAP-Connection -> Void)] + + [imap-get-expunges (IMAP-Connection -> (Listof Number))] + [imap-pending-expunges? (IMAP-Connection -> Boolean)] + [imap-get-updates (IMAP-Connection -> (Listof (cons Number (Listof (Pair Any Any)))))] + [imap-pending-updates? (IMAP-Connection -> Boolean)] + + [imap-get-messages + (IMAP-Connection (Listof Number) Symbol -> (Listof (Listof (U Number String String (Listof Symbol)))))] + [imap-copy (IMAP-Connection (Listof Number) String -> Void)] + [imap-append (IMAP-Connection String String -> Void)] + [imap-store (IMAP-Connection Symbol (Listof Number) Symbol -> Void)] + [imap-flag->symbol (Symbol -> Symbol)] + [symbol->imap-flag (Symbol -> Symbol)] + [imap-expunge (IMAP-Connection -> Void)] + + [imap-mailbox-exists? (IMAP-Connection String -> Boolean)] + [imap-create-mailbox (IMAP-Connection String -> Void)] + + [imap-list-child-mailboxes + (case-lambda (IMAP-Connection bstring -> (Listof (cons (Listof Symbol) (cons String '())))) + (IMAP-Connection bstring (Option bstring) -> (Listof (List (Listof Symbol) String))))] + [imap-mailbox-flags (IMAP-Connection String -> (Listof Symbol))] + [imap-get-hierarchy-delimiter (IMAP-Connection -> String)]) + +(provide + imap-connection? + IMAP-Connection) \ No newline at end of file diff --git a/collects/typed/net/mime.ss b/collects/typed/net/mime.ss new file mode 100644 index 0000000000..167f000335 --- /dev/null +++ b/collects/typed/net/mime.ss @@ -0,0 +1,71 @@ +#lang typed-scheme + +(require typed/private/utils) +;; -- basic mime structures -- +(require-typed-struct disposition + ([type : Symbol] + [filename : String] + [creation : String] + [modification : String] + [read : String] + [size : Number] + [params : Any]) + net/mime) +(require-typed-struct entity ([type : (U Symbol String)] + [subtype : (U Symbol String)] + [charset : (U Symbol String)] + [encoding : Symbol] + [disposition : disposition ] + [params : (Listof (cons Symbol String))] + [id : String] + [description : String] + [other : String] + [fields : Any] + [parts : (Listof String) ] + [body : (Output-Port -> Void)]) + net/mime) +(require-typed-struct message + ([version : String] [entity : entity] [fields : (Listof Symbol)]) + net/mime) + + +;; -- exceptions raised -- +(require/typed mime-error? (Any -> Boolean : (Opaque mime-error?)) net/mime) +(require/typed unexpected-termination? (Any -> Boolean :(Opaque unexpected-termination?)) net/mime) +(require/typed unexpected-termination-msg ((Opaque unexpected-termination?) -> message) net/mime) +(require/typed missing-multipart-boundary-parameter? (Any -> Boolean : (Opaque missing-multipart-boundary-parameter?)) net/mime) +(require/typed malformed-multipart-entity? (Any -> Boolean : (Opaque malformed-multipart-entity?)) net/mime) +(require/typed malformed-multipart-entity-msg ((Opaque malformed-multipart-entity?)-> message) net/mime) +(require/typed empty-mechanism? (Any -> Boolean : (Opaque empty-mechanism?)) net/mime) +(require/typed empty-type? (Any -> Boolean : (Opaque empty-type?)) net/mime) +(require/typed empty-subtype? (Any -> Boolean : (Opaque empty-subtype?)) net/mime) +(require/typed empty-disposition-type? (Any -> Boolean : (Opaque empty-disposition-type?)) net/mime) + + +;; -- mime methods -- +(require/typed/provide net/mime + [mime-analyze ((U Bytes Input-Port) Any -> message)]) + +(provide + ;; -- exceptions raised -- + mime-error? + unexpected-termination? + unexpected-termination-msg + missing-multipart-boundary-parameter? + malformed-multipart-entity? + malformed-multipart-entity-msg + empty-mechanism? + empty-type? + empty-subtype? + empty-disposition-type? + + ;; -- basic mime structures -- + message + entity + + disposition + + ;; -- mime methods -- + mime-analyze +) + diff --git a/collects/typed/net/nntp.ss b/collects/typed/net/nntp.ss new file mode 100644 index 0000000000..04468077f1 --- /dev/null +++ b/collects/typed/net/nntp.ss @@ -0,0 +1,31 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number]) + net/nntp) + +(require/typed/provide net/nntp + [connect-to-server (case-lambda (String -> communicator) (String Number -> communicator))] + [disconnect-from-server (communicator -> Void)] + [authenticate-user (communicator String String -> Void)] + [open-news-group (communicator String -> (values Number Number Number))] + [head-of-message (communicator Number -> (Listof String))] + [body-of-message (communicator Number -> (Listof String))] + [newnews-since (communicator Number -> (Listof String))] + [generic-message-command (communicator Number -> (Listof String))] + [make-desired-header (String -> String)] ;;-> Regexp + [extract-desired-headers ((Listof String) (Listof String) -> (Listof String))]) ;;2nd: Of Regexp +#| +;; requires structure inheritance +(require-typed-struct nntp ()] +(require-typed-struct unexpected-response ([code : Number] [text : String])] +(require-typed-struct bad-status-line ([line : String])] +(require-typed-struct premature-close ([communicator : communicator])] +(require-typed-struct bad-newsgroup-line ([line : String])] +(require-typed-struct non-existent-group ([group : String])] +(require-typed-struct article-not-in-group ([article : Number])] +(require-typed-struct no-group-selected ()] +(require-typed-struct article-not-found ([article : Number])] +(require-typed-struct authentication-rejected ()] +|# diff --git a/collects/typed/net/pop3.ss b/collects/typed/net/pop3.ss new file mode 100644 index 0000000000..8ecaa8f528 --- /dev/null +++ b/collects/typed/net/pop3.ss @@ -0,0 +1,38 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require-typed-struct communicator ([sender : Number] [receiver : Number] [server : String] [port : Number] [state : Symbol])net/pop3) + +(require/typed/provide net/pop3 + [connect-to-server ( case-lambda (String -> (Opaque communicator?)) (String Number -> (Opaque communicator?)) )] + + [disconnect-from-server ( (Opaque communicator?) -> Void )] + [authenticate/plain-text ( String String (Opaque communicator?) -> Void )] + [get-mailbox-status ( (Opaque communicator?) -> (values Number Number) )] + [get-message/complete ( (Opaque communicator?) Number -> (values (Listof String)(Listof String)) )] + [get-message/headers ( (Opaque communicator?) Number -> (Listof String) )] + [get-message/body ( (Opaque communicator?) Number -> (Listof String) )] + [delete-message ( (Opaque communicator?) Number -> Void )] + [get-unique-id/single ( (Opaque communicator?) Number -> String )] + [get-unique-id/all ( (Opaque communicator?) -> (Listof (cons Number String)) )] + + [make-desired-header ( String -> String )];-> Regexp + [extract-desired-headers ( (Listof String)(Listof String)-> (Listof String) )];2nd:of Regexp + ) +(provide (struct-out communicator)) + +#| +(require-typed-struct pop3 ()] +(require-typed-struct cannot-connect ()] +(require-typed-struct username-rejected ()] +(require-typed-struct password-rejected ()] +(require-typed-struct not-ready-for-transaction ([ communicator : (Opaque communicator?) ])net/pop3) +(require-typed-struct not-given-headers ([ communicator : (Opaque communicator?) ] [message : String])] +(require-typed-struct illegal-message-number ([communicator : (Opaque communicator?)] [message : String])] +(require-typed-struct cannot-delete-message ([communicator : (Opaque communicator?)] [message : String])] +(require-typed-struct disconnect-not-quiet ([communicator : (Opaque communicator?)])] +(require-typed-struct malformed-server-response ([communicator : (Opaque communicator?)])net/pop3) +|# + + \ No newline at end of file diff --git a/collects/typed/net/qp.ss b/collects/typed/net/qp.ss new file mode 100644 index 0000000000..092ccdde3a --- /dev/null +++ b/collects/typed/net/qp.ss @@ -0,0 +1,10 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/qp + [qp-encode ( String -> String )] + [qp-decode ( String -> String )] + [qp-encode-stream (case-lambda (Input-Port Output-Port -> Void) (Input-Port Output-Port String -> Void) )] + [qp-decode-stream ( Input-Port Output-Port -> Void )]) + \ No newline at end of file diff --git a/collects/typed/net/sendmail.ss b/collects/typed/net/sendmail.ss new file mode 100644 index 0000000000..1dd748d8be --- /dev/null +++ b/collects/typed/net/sendmail.ss @@ -0,0 +1,12 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/sendmail + [send-mail-message/port + (String String (Listof String) (Listof String) (Listof String) String * -> Output-Port)] + [send-mail-message + (String String (Listof String) (Listof String) (Listof String) (Listof String) String * -> Output-Port)]) + +(provide send-mail-message/port send-mail-message #;no-mail-recipients) + \ No newline at end of file diff --git a/collects/typed/net/sendurl.ss b/collects/typed/net/sendurl.ss new file mode 100644 index 0000000000..205096db36 --- /dev/null +++ b/collects/typed/net/sendurl.ss @@ -0,0 +1,9 @@ +#lang typed-scheme +(require/typed net/sendurl + [send-url (String -> Void)] + [unix-browser-list (Listof Symbol)] + [browser-preference? (String -> Boolean)] + [external-browser (-> (U Symbol #f (Pair String String)))]) + +(provide send-url unix-browser-list browser-preference? external-browser) + \ No newline at end of file diff --git a/collects/typed/net/smtp.ss b/collects/typed/net/smtp.ss new file mode 100644 index 0000000000..4923a4b116 --- /dev/null +++ b/collects/typed/net/smtp.ss @@ -0,0 +1,11 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/smtp + [smtp-send-message (String String (Listof String) String (Listof String) -> Void)] + [smtp-sending-end-of-message (Parameter (-> Any))]) + +(provide smtp-send-message smtp-sending-end-of-message) + + \ No newline at end of file diff --git a/collects/typed/net/uri-codec.ss b/collects/typed/net/uri-codec.ss new file mode 100644 index 0000000000..bfbc991191 --- /dev/null +++ b/collects/typed/net/uri-codec.ss @@ -0,0 +1,15 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require/typed/provide net/uri-codec + [uri-encode ( String -> String )] + [uri-decode ( String -> String )] + + [form-urlencoded-encode ( String -> String )] + [form-urlencoded-decode ( String -> String )] + + [alist->form-urlencoded ( (Listof (cons Symbol String)) -> String )] + [form-urlencoded->alist ( String -> (Listof (cons Symbol String)) )] + [current-alist-separator-mode (Parameter Symbol)]) + \ No newline at end of file diff --git a/collects/typed/net/url.ss b/collects/typed/net/url.ss new file mode 100644 index 0000000000..86add4fef6 --- /dev/null +++ b/collects/typed/net/url.ss @@ -0,0 +1,59 @@ +#lang typed-scheme + +(require typed/private/utils) + +(require-typed-struct path/param ([path : (U String 'up 'same)] [param : (Listof String)]) net/url) + +(require-typed-struct url ([scheme : (Option String)] + [user : (Option String)] + [host : (Option String)] + [port : (Option Integer)] + [path-absolute? : Boolean] + [path : (Listof path/param)] + [query : (Listof (Pair Symbol (Option String)))] + [fragment : (Option String)]) + net/url) + +(require/opaque-type URL-Exception url-exception? net/url) + +(define-type-alias PortT (case-lambda (url -> Input-Port) (url (Listof String)-> Input-Port))) +(define-type-alias PortT/String (case-lambda (url String -> Input-Port) (url String (Listof String)-> Input-Port))) + +(require/typed/provide net/url + + [path->url (Path -> url)] + [url->path (case-lambda (url -> Path) (url (U 'unix 'windows) -> Path))] + + [file-url-path-convention-type (Parameter (U 'unix 'windows))] + + [get-pure-port PortT] + [head-pure-port PortT] + [delete-pure-port PortT] + + [get-impure-port PortT] + [head-impure-port PortT] + [delete-impure-port PortT] + + [post-pure-port PortT/String] + [put-pure-port PortT/String] + + [post-impure-port PortT/String] + [put-impure-port PortT/String] + + [display-pure-port (Input-Port -> Void)] + [purify-port (Input-Port -> String)] + + [call/input-url (case-lambda [url url (Input-Port -> Any) -> Any])] ;;FIXME - need polymorphism + + [current-proxy-servers (Parameter (Listof (List String String Integer)))] + + [netscape/string->url (String -> url)] + [string->url (String -> url)] + [url->string (url -> String)] + [combine-url/relative (url String -> url)]) + +(provide + URL-Exception + url-exception? + (struct-out url) + (struct-out path/param)) From 447cea73d08c145385fc75a236cb705c5d2a705f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 00:16:25 +0000 Subject: [PATCH 08/29] set svn:eol-style svn: r12520 --- collects/typed/file/gif.ss | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/typed/file/gif.ss b/collects/typed/file/gif.ss index 3a17435eb0..402c340692 100644 --- a/collects/typed/file/gif.ss +++ b/collects/typed/file/gif.ss @@ -14,4 +14,3 @@ [quantize ( String -> (values String (Listof (Vectorof Number)) (U #f (Vectorof Number))))]) (provide gif-stream? GIF-Stream) - \ No newline at end of file From 959c8917942f3c44057d8f4cd85322af3324b456 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 20 Nov 2008 02:15:01 +0000 Subject: [PATCH 09/29] svn: r12521 --- doc/release-notes/drscheme/HISTORY.txt | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/doc/release-notes/drscheme/HISTORY.txt b/doc/release-notes/drscheme/HISTORY.txt index 2ecc672274..6421c44f94 100644 --- a/doc/release-notes/drscheme/HISTORY.txt +++ b/doc/release-notes/drscheme/HISTORY.txt @@ -1,3 +1,16 @@ +------------------------------ + Version 4.3 +------------------------------ + + . minor bug fixes + +------------------------------ + Version 4.2 +------------------------------ + + . contract library's function contract + combinatiors now preserve tail recursion. + ------------------------------ Version 4.1 ------------------------------ From 7c0db197ec0a9f9d9c49415208256009693cbb37 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 02:27:02 +0000 Subject: [PATCH 10/29] * Made --ssl set a port number only if it wasn't already before * Made -p reject non-integers and bad port numbers svn: r12523 --- collects/web-server/private/launch.ss | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/web-server/private/launch.ss b/collects/web-server/private/launch.ss index c24473910c..6884af754f 100644 --- a/collects/web-server/private/launch.ss +++ b/collects/web-server/private/launch.ss @@ -18,7 +18,7 @@ default))) (define ssl (make-parameter #f)) -(define port (make-parameter 80)) +(define port (make-parameter #f)) (define configuration@ (parse-command-line @@ -27,7 +27,7 @@ `((once-each [("--ssl") ,(lambda (flag) - (port 443) + (unless (port) (port 443)) (ssl #t)) ("Run with SSL using server-cert.pem and private-key.pem in the current directory, with 443 as the default port.")] [("-f" "--configuration-table") @@ -41,7 +41,10 @@ ("Use an alternate configuration table" "file-name")] [("-p" "--port") ,(lambda (flag the-port) - (port (string->number the-port))) + (let ([p (string->number the-port)]) + (if (and (integer? p) (<= 1 p 65535)) + (port p) + (error 'web-server "expecting a valid port number, got \"~a\"" the-port)))) ("Use an alternate network port." "port")] [("-a" "--ip-address") ,(lambda (flag ip-address) @@ -58,7 +61,7 @@ (lambda (flags) (configuration-table->web-config@ (extract-flag 'config flags default-configuration-table-path) - #:port (port) + #:port (or (port) 80) #:listen-ip (extract-flag 'ip-address flags #f))) '())) From 788b94e28b02cb8c010163219ba47cdd7165f6b7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 02:55:28 +0000 Subject: [PATCH 11/29] Mostly reformatting svn: r12524 --- collects/web-server/servlet-env.ss | 193 ++++++++++++++--------------- collects/web-server/web-server.ss | 24 ++-- 2 files changed, 107 insertions(+), 110 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index e6988ba34d..3f4f224674 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -9,7 +9,7 @@ web-server/managers/manager web-server/private/servlet web-server/configuration/namespace - web-server/private/cache-table + web-server/private/cache-table web-server/http web-server/private/util web-server/configuration/responders @@ -18,10 +18,10 @@ web-server/configuration/configuration-table web-server/servlet/setup (prefix-in lift: web-server/dispatchers/dispatch-lift) - (prefix-in fsmap: web-server/dispatchers/filesystem-map) + (prefix-in fsmap: web-server/dispatchers/filesystem-map) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) (prefix-in files: web-server/dispatchers/dispatch-files) - (prefix-in filter: web-server/dispatchers/dispatch-filter) + (prefix-in filter: web-server/dispatchers/dispatch-filter) (prefix-in servlets: web-server/dispatchers/dispatch-servlets)) (define send-url (make-parameter net:send-url)) @@ -30,93 +30,89 @@ (lift:make (lambda (request) (thread (lambda () (sleep 2) (semaphore-post sema))) - `(html - (head - (title "Server Stopped") - (link ([rel "stylesheet"] [href "/error.css"]))) - (body - (div ([class "section"]) - (div ([class "title"]) "Server Stopped") - (p "Return to DrScheme."))))))) + `(html (head (title "Server Stopped") + (link ([rel "stylesheet"] [href "/error.css"]))) + (body (div ([class "section"]) + (div ([class "title"]) "Server Stopped") + (p "Return to DrScheme."))))))) (provide/contract [serve/servlet (((request? . -> . response?)) (#:command-line? boolean? - #:launch-browser? boolean? - #:quit? boolean? - #:banner? boolean? - #:listen-ip string? - #:port number? - #:manager manager? - #:servlet-namespace (listof module-path?) - #:server-root-path path? - #:stateless? boolean? - #:extra-files-paths (listof path?) - #:servlets-root path? - #:file-not-found-responder (request? . -> . response?) - #:mime-types-path path? - #:servlet-path string? - #:servlet-regexp regexp?) + #:launch-browser? boolean? + #:quit? boolean? + #:banner? boolean? + #:listen-ip string? + #:port number? + #:manager manager? + #:servlet-namespace (listof module-path?) + #:server-root-path path? + #:stateless? boolean? + #:extra-files-paths (listof path?) + #:servlets-root path? + #:file-not-found-responder (request? . -> . response?) + #:mime-types-path path? + #:servlet-path string? + #:servlet-regexp regexp?) . ->* . void)]) -(define (serve/servlet start - #:command-line? - [command-line? #f] - #:launch-browser? - [launch-browser? (not command-line?)] - #:quit? - [quit? (not command-line?)] - #:banner? - [banner? (not command-line?)] - - #:listen-ip - [listen-ip "127.0.0.1"] - #:port - [the-port 8000] - - #:manager - [manager - (make-threshold-LRU-manager - (lambda (request) - `(html (head (title "Page Has Expired.")) - (body (p "Sorry, this page has expired. Please go back.")))) - (* 64 1024 1024))] - - #:servlet-path - [servlet-path "/servlets/standalone.ss"] - #:servlet-regexp - [servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))] - #:stateless? - [stateless? #f] - - #:servlet-namespace - [servlet-namespace empty] - #:server-root-path - [server-root-path (directory-part default-configuration-table-path)] - #:extra-files-paths - [extra-files-paths (list (build-path server-root-path "htdocs"))] - #:servlets-root - [servlets-root (build-path server-root-path "htdocs")] - #:servlet-current-directory - [servlet-current-directory servlets-root] - #:file-not-found-responder - [file-not-found-responder (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))] - #:mime-types-path - [mime-types-path (build-path server-root-path "mime.types")]) - (define standalone-url - (format "http://localhost:~a~a" the-port servlet-path)) +(define (serve/servlet + start + #:command-line? + [command-line? #f] + #:launch-browser? + [launch-browser? (not command-line?)] + #:quit? + [quit? (not command-line?)] + #:banner? + [banner? (not command-line?)] + + #:listen-ip + [listen-ip "127.0.0.1"] + #:port + [the-port 8000] + + #:manager + [manager + (make-threshold-LRU-manager + (lambda (request) + `(html (head (title "Page Has Expired.")) + (body (p "Sorry, this page has expired. Please go back.")))) + (* 64 1024 1024))] + + #:servlet-path + [servlet-path "/servlets/standalone.ss"] + #:servlet-regexp + [servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))] + #:stateless? + [stateless? #f] + + #:servlet-namespace + [servlet-namespace empty] + #:server-root-path + [server-root-path (directory-part default-configuration-table-path)] + #:extra-files-paths + [extra-files-paths (list (build-path server-root-path "htdocs"))] + #:servlets-root + [servlets-root (build-path server-root-path "htdocs")] + #:servlet-current-directory + [servlet-current-directory servlets-root] + #:file-not-found-responder + [file-not-found-responder + (gen-file-not-found-responder + (build-path server-root-path "conf" "not-found.html"))] + #:mime-types-path + [mime-types-path (build-path server-root-path "mime.types")]) + (define standalone-url (format "http://localhost:~a~a" the-port servlet-path)) (define make-servlet-namespace - (make-make-servlet-namespace - #:to-be-copied-module-specs servlet-namespace)) + (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)) (define sema (make-semaphore 0)) (define servlet-box (box #f)) (define dispatcher (sequencer:make (if quit? - (filter:make - #rx"^/quit$" - (quit-server sema)) - (lambda _ (next-dispatcher))) + (filter:make #rx"^/quit$" (quit-server sema)) + (lambda _ (next-dispatcher))) (filter:make servlet-regexp (servlets:make @@ -129,8 +125,8 @@ #:additional-specs default-module-specs)]) (if stateless? - (make-stateless.servlet servlet-current-directory start) - (make-v2.servlet servlet-current-directory manager start)))]) + (make-stateless.servlet servlet-current-directory start) + (make-v2.servlet servlet-current-directory manager start)))]) (set-box! servlet-box servlet) servlet))))) (let-values ([(clear-cache! url->servlet) @@ -144,33 +140,34 @@ (servlets:make url->servlet)) (apply sequencer:make (map (lambda (extra-files-path) - (files:make - #:url->path (fsmap:make-url->path - extra-files-path) + (files:make + #:url->path (fsmap:make-url->path extra-files-path) #:path->mime-type (make-path->mime-type mime-types-path) #:indices (list "index.html" "index.htm"))) extra-files-paths)) - (files:make - #:url->path (fsmap:make-url->path - (build-path server-root-path "htdocs")) - #:path->mime-type (make-path->mime-type (build-path server-root-path "mime.types")) + (files:make + #:url->path (fsmap:make-url->path (build-path server-root-path "htdocs")) + #:path->mime-type (make-path->mime-type + (build-path server-root-path "mime.types")) #:indices (list "index.html" "index.htm")) (lift:make file-not-found-responder))) (define shutdown-server (serve #:dispatch dispatcher #:listen-ip listen-ip #:port the-port)) + (define welcome + (if banner? + (lambda () + (printf "Your Web application is running at ~a.\n" standalone-url) + (printf "Click 'Stop' at any time to terminate the Web Server.\n")) + (void))) + (define (bye) + (when banner? (printf "\nWeb Server stopped.\n")) + (shutdown-server)) (when launch-browser? ((send-url) standalone-url #t)) - (when banner? - (printf "Your Web application is running at ~a.~n" standalone-url) - (printf "Click 'Stop' at any time to terminate the Web Server.~n")) - (with-handlers - ([exn:break? - (lambda (exn) - (when banner? - (printf "~nWeb Server stopped.~n")) - (shutdown-server))]) + (welcome) + (with-handlers ([exn:break? (lambda (exn) (bye))]) (semaphore-wait/enable-break sema)) - ; We shouldn't get here, because nothing posts to the semaphore. But just in case... - (shutdown-server)) \ No newline at end of file + ;; We can get here if a /quit url is visited + (bye)) diff --git a/collects/web-server/web-server.ss b/collects/web-server/web-server.ss index 3a293ad793..1491095d57 100644 --- a/collects/web-server/web-server.ss +++ b/collects/web-server/web-server.ss @@ -15,25 +15,25 @@ [serve (->* (#:dispatch dispatcher/c) (#:tcp@ unit? - #:port number? - #:listen-ip (or/c false/c string?) - #:max-waiting number? - #:initial-connection-timeout number?) + #:port number? + #:listen-ip (or/c false/c string?) + #:max-waiting number? + #:initial-connection-timeout number?) (-> void))] [serve/ports (->* (#:dispatch dispatcher/c) (#:tcp@ unit? - #:ports (listof number?) - #:listen-ip (or/c false/c string?) - #:max-waiting number? - #:initial-connection-timeout number?) + #:ports (listof number?) + #:listen-ip (or/c false/c string?) + #:max-waiting number? + #:initial-connection-timeout number?) (-> void))] [serve/ips+ports (->* (#:dispatch dispatcher/c) (#:tcp@ unit? - #:ips+ports (listof (cons/c (or/c false/c string?) (listof number?))) - #:max-waiting number? - #:initial-connection-timeout number?) + #: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?) (#:tcp@ unit?) . ->* . (-> void?))]) @@ -59,7 +59,7 @@ dispatch-server@/tcp@ (import dispatch-server-config^) (export dispatch-server^)) - + (serve)) (define (serve/ports From 42d8f1ae1f2df731e9b7bfc28cc0b8491f3b7523 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 03:08:08 +0000 Subject: [PATCH 12/29] fix: just one shutdown message svn: r12525 --- collects/web-server/servlet-env.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 3f4f224674..52ce8f65bd 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -168,6 +168,6 @@ ((send-url) standalone-url #t)) (welcome) (with-handlers ([exn:break? (lambda (exn) (bye))]) - (semaphore-wait/enable-break sema)) - ;; We can get here if a /quit url is visited - (bye)) + (semaphore-wait/enable-break sema) + ;; We can get here if a /quit url is visited + (bye))) From 9405d572928173d33fb60376d71c5e4debb3fc89 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 03:13:01 +0000 Subject: [PATCH 13/29] allow #f for #:listen-ip svn: r12526 --- collects/web-server/servlet-env.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 52ce8f65bd..d817197aca 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -42,7 +42,7 @@ #:launch-browser? boolean? #:quit? boolean? #:banner? boolean? - #:listen-ip string? + #:listen-ip (or/c false/c string?) #:port number? #:manager manager? #:servlet-namespace (listof module-path?) From 8b5b87c80765d3d6a5c28ca6b2906ca72fd99b2f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 04:55:14 +0000 Subject: [PATCH 14/29] * revise requires to scheme/* * use `for' and better use of regexp patterns in `match' * use a literal byte-regexp in `make-path->mime-type' and use it throught `match' * delay reading of the mime types table (since there are uses like serve/servlet that will never use it anyway) svn: r12527 --- collects/web-server/private/mime-types.ss | 27 +++++++++-------------- 1 file changed, 11 insertions(+), 16 deletions(-) diff --git a/collects/web-server/private/mime-types.ss b/collects/web-server/private/mime-types.ss index 429953a88e..b129767d36 100644 --- a/collects/web-server/private/mime-types.ss +++ b/collects/web-server/private/mime-types.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require mzlib/contract - mzlib/plt-match - mzlib/string) +(require scheme/contract + scheme/match + scheme/promise) (require "util.ss" web-server/http) (provide/contract @@ -17,13 +17,9 @@ (match (read-line (current-input-port) 'any) [(? eof-object?) (void)] - [(regexp #"^([^\t ]+)[\t ]+(.+)$" - (list s type exts)) - (for-each (lambda (ext) - (hash-set! MIME-TYPE-TABLE - (lowercase-symbol! ext) - type)) - (regexp-split #" " exts)) + [(regexp #rx#"^([^\t ]+)[\t ]+(.+)$" (list _ type exts)) + (for ([ext (in-list (regexp-split #" " exts))]) + (hash-set! MIME-TYPE-TABLE (lowercase-symbol! ext) type)) (loop)] [_ (loop)])))) @@ -36,12 +32,11 @@ ;; 1. Can we determine the mime type based on file contents? ;; 2. Assuming that 7-bit ASCII is correct for mime-type (define (make-path->mime-type a-path) - (define MIME-TYPE-TABLE (read-mime-types a-path)) - (define file-suffix-regexp (byte-regexp #".*\\.([^\\.]*$)")) + (define MIME-TYPE-TABLE (delay (read-mime-types a-path))) (lambda (path) - (match (regexp-match file-suffix-regexp (path->bytes path)) - [(list path-bytes sffx) - (hash-ref MIME-TYPE-TABLE + (match (path->bytes path) + [(regexp #rx#".*\\.([^\\.]*$)" (list _ sffx)) + (hash-ref (force MIME-TYPE-TABLE) (lowercase-symbol! sffx) - (lambda () TEXT/HTML-MIME-TYPE))] + TEXT/HTML-MIME-TYPE)] [_ TEXT/HTML-MIME-TYPE]))) From f6aa15c531e9e2c7bdeae10e0b4ef3da5c78ce4c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 04:59:26 +0000 Subject: [PATCH 15/29] Use the given `mime-types-path' for all files svn: r12528 --- collects/web-server/servlet-env.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index d817197aca..bf76c2602c 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -147,8 +147,7 @@ extra-files-paths)) (files:make #:url->path (fsmap:make-url->path (build-path server-root-path "htdocs")) - #:path->mime-type (make-path->mime-type - (build-path server-root-path "mime.types")) + #:path->mime-type (make-path->mime-type mime-types-path) #:indices (list "index.html" "index.htm")) (lift:make file-not-found-responder))) (define shutdown-server From a41971ba6d5dd11093c4dc95838d14d47c0ff666 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 05:53:04 +0000 Subject: [PATCH 16/29] Added #:ssl? for making an https server. It is hard-wired to using "server-cert.pem" and "private-key.pem" in `server-root-path', but that seems to be the same as the --ssl command-line option. The ssl server is created using the same code that "private/launch.ss" uses, so it might be a good idea to abstract it into a separate file. Also, `mime-types-path' defaults to "mime.types" in the `server-root-path', but if the file is missing, then it uses "mime.types" in the `default-configuration-table-path', which is a sensible choice for just getting a server running. svn: r12529 --- collects/web-server/servlet-env.ss | 59 +++++++++++++++++++++--------- 1 file changed, 41 insertions(+), 18 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index bf76c2602c..7342405b98 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -3,7 +3,11 @@ #lang scheme/base (require (prefix-in net: net/sendurl) scheme/contract - scheme/list) + scheme/list + scheme/unit + net/tcp-unit + net/tcp-sig + net/ssl-tcp-unit) (require web-server/web-server web-server/managers/lru web-server/managers/manager @@ -44,6 +48,7 @@ #:banner? boolean? #:listen-ip (or/c false/c string?) #:port number? + #:ssl? boolean? #:manager manager? #:servlet-namespace (listof module-path?) #:server-root-path path? @@ -71,6 +76,8 @@ [listen-ip "127.0.0.1"] #:port [the-port 8000] + #:ssl? + [ssl? #f] #:manager [manager @@ -102,8 +109,18 @@ (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))] #:mime-types-path - [mime-types-path (build-path server-root-path "mime.types")]) - (define standalone-url (format "http://localhost:~a~a" the-port servlet-path)) + [mime-types-path (let ([p (build-path server-root-path "mime.types")]) + (if (file-exists? p) + p + (build-path + (directory-part default-configuration-table-path) + "mime.types")))]) + (define standalone-url + (string-append (if ssl? "https" "http") + "://localhost" + (if (and (not ssl?) (= the-port 80)) + "" (format ":~a" the-port)) + servlet-path)) (define make-servlet-namespace (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)) (define sema (make-semaphore 0)) @@ -153,20 +170,26 @@ (define shutdown-server (serve #:dispatch dispatcher #:listen-ip listen-ip - #:port the-port)) - (define welcome - (if banner? - (lambda () - (printf "Your Web application is running at ~a.\n" standalone-url) - (printf "Click 'Stop' at any time to terminate the Web Server.\n")) - (void))) - (define (bye) - (when banner? (printf "\nWeb Server stopped.\n")) - (shutdown-server)) + #:port the-port + #:tcp@ (if ssl? + (let () + (define-unit-binding ssl-tcp@ + (make-ssl-tcp@ + (build-path server-root-path "server-cert.pem") + (build-path server-root-path "private-key.pem") + #f #f #f #f #f) + (import) (export tcp^)) + ssl-tcp@) + tcp@))) (when launch-browser? ((send-url) standalone-url #t)) - (welcome) - (with-handlers ([exn:break? (lambda (exn) (bye))]) - (semaphore-wait/enable-break sema) - ;; We can get here if a /quit url is visited - (bye))) + (when banner? + (printf "Your Web application is running at ~a.\n" standalone-url) + (printf "Click 'Stop' at any time to terminate the Web Server.\n")) + (let ([bye (lambda () + (when banner? (printf "\nWeb Server stopped.\n")) + (shutdown-server))]) + (with-handlers ([exn:break? (lambda (exn) (bye))]) + (semaphore-wait/enable-break sema) + ;; We can get here if a /quit url is visited + (bye)))) From 56abd457ecdfe1ffe73eb4bef47c128ce82ac11f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 08:50:13 +0000 Subject: [PATCH 17/29] Welcome to a new PLT day. svn: r12530 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index cd6d48b8c9..925fa0040c 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19nov2008") +#lang scheme/base (provide stamp) (define stamp "20nov2008") From beea721bc41026a982e4316dc8d63aa44d4b6b47 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 09:48:03 +0000 Subject: [PATCH 18/29] Use the new web-server's `serve/servlet' for the status servlet. svn: r12531 --- collects/handin-server/main.ss | 4 +- .../scribblings/quick-start.scrbl | 5 +- .../scribblings/server-setup.scrbl | 4 +- .../handin-server/status-web-root/index.html | 8 - .../status-web-root/servlets/status.ss | 277 -------------- collects/handin-server/web-status-server.ss | 347 ++++++++++++++---- 6 files changed, 278 insertions(+), 367 deletions(-) delete mode 100644 collects/handin-server/status-web-root/index.html delete mode 100644 collects/handin-server/status-web-root/servlets/status.ss diff --git a/collects/handin-server/main.ss b/collects/handin-server/main.ss index 1bd32f3b5d..ba1730692c 100644 --- a/collects/handin-server/main.ss +++ b/collects/handin-server/main.ss @@ -10,7 +10,7 @@ "private/run-status.ss" "private/reloadable.ss" "private/hooker.ss" - "web-status-server.ss" + (prefix-in web: "web-status-server.ss") ;; this sets some global parameter values, and this needs ;; to be done in the main thread, rather than later in a ;; user session thread (that will make the global changes @@ -623,7 +623,7 @@ (hook 'server-start `([port ,(get-conf 'port-number)])) (define stop-status - (cond [(get-conf 'https-port-number) => serve-status] + (cond [(get-conf 'https-port-number) => web:run] [else void])) (define session-count 0) diff --git a/collects/handin-server/scribblings/quick-start.scrbl b/collects/handin-server/scribblings/quick-start.scrbl index 5fb1855056..dc522b882e 100644 --- a/collects/handin-server/scribblings/quick-start.scrbl +++ b/collects/handin-server/scribblings/quick-start.scrbl @@ -50,9 +50,8 @@ The submitted file will be @filepath{.../test/tester/handin.scm}.} @item{Check the status of your submission by pointing a web browser at - @tt{https://localhost:7980/servlets/status.ss}. Note the ``s'' in - ``https''. Use the ``@tt{tester}'' username and ``@tt{pw}'' - password, as before. + @tt{https://localhost:7980/}. Note the ``s'' in ``https''. Use the + ``@tt{tester}'' username and ``@tt{pw}'' password, as before. NOTE: The @scheme[https-port-number] line in the @filepath{config.ss} file enables the embedded secure server. You diff --git a/collects/handin-server/scribblings/server-setup.scrbl b/collects/handin-server/scribblings/server-setup.scrbl index 1116902f2d..5be0694ea0 100644 --- a/collects/handin-server/scribblings/server-setup.scrbl +++ b/collects/handin-server/scribblings/server-setup.scrbl @@ -482,11 +482,11 @@ the correct assignment in the handin dialog. A student can download his/her own submissions through a web server that runs concurrently with the handin server. The starting URL is -@commandline{https://SERVER:PORT/servlets/status.ss} +@commandline{https://SERVER:PORT/} to obtain a list of all assignments, or -@commandline{https://SERVER:PORT/servlets/status.ss?handin=ASSIGNMENT} +@commandline{https://SERVER:PORT/?handin=ASSIGNMENT} to start with a specific assignment (named ASSIGNMENT). The default PORT is 7980. diff --git a/collects/handin-server/status-web-root/index.html b/collects/handin-server/status-web-root/index.html deleted file mode 100644 index 26af46228c..0000000000 --- a/collects/handin-server/status-web-root/index.html +++ /dev/null @@ -1,8 +0,0 @@ - -Handin Status Web Server - -The handin status server is running. -
-You can check your submissions on this server. - - diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss deleted file mode 100644 index 1f939f9a52..0000000000 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ /dev/null @@ -1,277 +0,0 @@ -(module status mzscheme - (require mzlib/file - mzlib/list - mzlib/string - mzlib/date - web-server/servlet - web-server/servlet/servlet-structs - web-server/managers/timeouts - web-server/private/util - net/uri-codec - net/url - handin-server/private/md5 - handin-server/private/logger - handin-server/private/config - handin-server/private/hooker) - - (define get-user-data - (let ([users-file (build-path server-dir "users.ss")]) - (lambda (user) - (get-preference (string->symbol user) (lambda () #f) #f users-file)))) - - (define (clean-str s) - (regexp-replace #rx" +$" (regexp-replace #rx"^ +" s "") "")) - - (define (aget alist key) - (cond [(assq key alist) => cdr] [else #f])) - - (define (make-page title . body) - `(html (head (title ,title)) - (body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body))) - - (define (relativize-path p) - (path->string (find-relative-path (normalize-path server-dir) p))) - - (define (make-k k tag) - (format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?") - (uri-encode tag))) - - ;; `look-for' can be a username as a string (will find "bar+foo" for "foo"), - ;; or a regexp that should match the whole directory name (used with - ;; "^solution" below) - (define (find-handin-entry hi look-for) - (let ([dir (assignment<->dir hi)]) - (and (directory-exists? dir) - (ormap - (lambda (d) - (let ([d (path->string d)]) - (and (cond [(string? look-for) - (member look-for (regexp-split #rx" *[+] *" d))] - [(regexp? look-for) (regexp-match? look-for d)] - [else (error 'find-handin-entry - "internal error: ~e" look-for)]) - (build-path dir d)))) - (directory-list dir))))) - - (define (handin-link k user hi) - (let* ([dir (find-handin-entry hi user)] - [l (and dir (with-handlers ([exn:fail? (lambda (x) null)]) - (parameterize ([current-directory dir]) - (sort (filter (lambda (f) - (and (not (equal? f "grade")) - (file-exists? f))) - (map path->string (directory-list))) - stringstring - (seconds->date - (file-or-directory-modify-seconds hi)) - #t) - ")"))) - l))) - (list (format "No handins accepted so far for user ~s, assignment ~s" - user hi))))) - - (define (solution-link k hi) - (let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs)) - (find-handin-entry hi #rx"^solution"))] - [none `((i "---"))]) - (cond [(not soln) none] - [(file-exists? soln) - `((a ((href ,(make-k k (relativize-path soln)))) "Solution"))] - [(directory-exists? soln) - (parameterize ([current-directory soln]) - (let ([files (sort (map path->string - (filter file-exists? (directory-list))) - stringdir dir)]) - `(tr ([valign "top"]) - ,(apply header hi - (if active? `((br) (small (small "[active]"))) '())) - ,(apply cell (handin-link k user hi)) - ,(rcell (handin-grade user hi)) - ,(apply cell (solution-link k hi))))) - (let* ([next - (send/suspend - (lambda (k) - (make-page - (format "All Handins for ~a" user) - `(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"]) - (tr () ,@(map header '(nbsp "Files" "Grade" "Solution"))) - ,@(append (map (row k #t) (get-conf 'active-dirs)) - (map (row k #f) (get-conf 'inactive-dirs)))))))] - [tag (aget (request-bindings next) 'tag)]) - (download user tag))) - - (define (download who tag) - (define (check path elts allow-active?) - (let loop ([path path] [elts (reverse elts)]) - (let*-values ([(base name dir?) (split-path path)] - [(name) (path->string name)] - [(check) (and (pair? elts) (car elts))]) - (if (null? elts) - ;; must be rooted in a submission directory (why build-path instead - ;; of using `path'? -- because path will have a trailing slash) - (member (build-path base name) - (get-conf (if allow-active? 'all-dirs 'inactive-dirs))) - (and (cond [(eq? '* check) #t] - [(regexp? check) (regexp-match? check name)] - [(string? check) - (or (equal? name check) - (member check (regexp-split #rx" *[+] *" name)))] - [else #f]) - (loop base (cdr elts))))))) - (define file (build-path server-dir tag)) - (with-handlers ([exn:fail? - (lambda (exn) - (log-line "Status exception: ~a" (exn-message exn)) - (make-page "Error" "Illegal file access"))]) - ;; Make sure the user is allowed to read the requested file: - (or (check file `(,who *) #t) - (check file `(#rx"^solution") #f) - (check file `(#rx"^solution" *) #f) - (error 'download "bad file access for ~s: ~a" who file)) - (log-line "Status file-get: ~s ~a" who file) - (hook 'status-file-get `([username ,(string->symbol who)] [file ,file])) - ;; Return the downloaded file - (let* ([data (with-input-from-file file - (lambda () (read-bytes (file-size file))))] - [html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))] - [wxme? (regexp-match? #rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)]) - (make-response/full 200 "Okay" (current-seconds) - (cond [html? #"text/html"] - [wxme? #"application/data"] - [else #"text/plain"]) - (list - (make-header #"Content-Length" - (string->bytes/latin-1 - (number->string (bytes-length data)))) - (make-header #"Content-Disposition" - (string->bytes/utf-8 - (format "~a; filename=~s" - (if wxme? "attachment" "inline") - (let-values ([(base name dir?) (split-path file)]) - (path->string name)))))) - (list data))))) - - (define (status-page user for-handin) - (log-line "Status access: ~s" user) - (hook 'status-login `([username ,(string->symbol user)])) - (if for-handin - (one-status-page user for-handin) - (all-status-page user))) - - (define (login-page for-handin errmsg) - (let* ([request - (send/suspend - (lambda (k) - (make-page - "Handin Status Login" - `(form ([action ,k] [method "post"]) - (table ([align "center"]) - (tr (td ([colspan "2"] [align "center"]) - (font ([color "red"]) ,(or errmsg 'nbsp)))) - (tr (td "Username") - (td (input ([type "text"] [name "user"] [size "20"] - [value ""])))) - (tr (td nbsp)) - (tr (td "Password") - (td (input ([type "password"] [name "passwd"] - [size "20"] [value ""])))) - (tr (td ([colspan "2"] [align "center"]) - (input ([type "submit"] [name "post"] - [value "Login"])))))))))] - [bindings (request-bindings request)] - [user (aget bindings 'user)] - [passwd (aget bindings 'passwd)] - [user (and user (clean-str user))] - [user-data (get-user-data user)]) - (cond [(and user-data - (string? passwd) - (let ([pw (md5 passwd)]) - (or (equal? pw (car user-data)) - (equal? pw (get-conf 'master-password))))) - (status-page user for-handin)] - [else (login-page for-handin "Bad username or password")]))) - - (define web-counter - (let ([sema (make-semaphore 1)] - [count 0]) - (lambda () - (dynamic-wind - (lambda () (semaphore-wait sema)) - (lambda () (set! count (add1 count)) (format "w~a" count)) - (lambda () (semaphore-post sema)))))) - - (define (start initial-request) - (parameterize ([current-session (web-counter)]) - (login-page (aget (request-bindings initial-request) 'handin) #f))) - - (define interface-version 'v2) - (define name "status") - - (define (instance-expiration-handler failed-request) - (let* (;; get the current url, and strip off the continuation data - [cont-url (request-uri failed-request)] - [base-url (url-replace-path - (lambda (pl) - (map (lambda (pp) - (make-path/param (path/param-path pp) empty)) - pl)) - cont-url)] - [base-url-str (url->string base-url)]) - `(html (head (meta [(http-equiv "refresh") - (content ,(format "3;URL=~a" base-url-str))])) - (body "Your session has expired, " - (a ([href ,base-url-str]) "restarting") " in 3 seconds.")))) - - (define manager - (create-timeout-manager instance-expiration-handler 600 600)) - - (provide interface-version start name manager)) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index b95cd91ca3..64307edc6e 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -1,82 +1,279 @@ -#lang scheme/base -(require scheme/unit - net/ssl-tcp-unit - net/tcp-sig - net/tcp-unit - (only-in mzlib/etc this-expression-source-directory) - web-server/web-server-unit - web-server/web-server-sig - web-server/web-config-sig - web-server/web-config-unit - web-server/configuration/namespace - "private/config.ss") +#lang scheme +(require scheme/list + scheme/file + scheme/date + net/uri-codec + web-server/servlet + web-server/servlet-env + web-server/managers/lru + handin-server/private/md5 + handin-server/private/logger + handin-server/private/config + handin-server/private/hooker) -(provide serve-status) +(define (aget alist key) + (cond [(assq key alist) => cdr] [else #f])) -(define (serve-status port-no) +(define (clean-str s) + (regexp-replace #rx" +$" (regexp-replace #rx"^ +" s "") "")) - (define ((in-dir dir) . paths) (path->string (apply build-path dir paths))) - (define in-web-dir - (in-dir (or (get-conf 'web-base-dir) - (build-path (this-expression-source-directory) - "status-web-root")))) - (define in-plt-web-dir - (in-dir (build-path (collection-path "web-server") "default-web-root"))) +(define (make-page title . body) + `(html (head (title ,title)) + (body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body))) - (define config - `((port ,port-no) - (max-waiting 40) - (initial-connection-timeout 30) - (default-host-table - (host-table - (default-indices "index.html") - (log-format parenthesized-default) - (messages - (servlet-message "servlet-error.html") - (authentication-message "forbidden.html") - (servlets-refreshed "servlet-refresh.html") - (passwords-refreshed "passwords-refresh.html") - (file-not-found-message "not-found.html") - (protocol-message "protocol-error.html") - (collect-garbage "collect-garbage.html")) - (timeouts - (default-servlet-timeout 120) - (password-connection-timeout 300) - (servlet-connection-timeout 86400) - (file-per-byte-connection-timeout 1/20) - (file-base-connection-timeout 30)) - (paths - (configuration-root ,(in-plt-web-dir "conf")) - (host-root ".") - (log-file-path ,(cond [(get-conf 'web-log-file) => path->string] - [else #f])) - (file-root ".") - (servlet-root ,(in-web-dir "servlets")) - (mime-types ,(in-plt-web-dir "mime.types")) - (password-authentication ,(in-plt-web-dir "passwords"))))) - (virtual-host-table))) +(define get-user-data + (let ([users-file (build-path server-dir "users.ss")]) + (unless (file-exists? users-file) + (error 'get-user-data "users file missing at: ~a" users-file)) + (lambda (user) + (get-preference (string->symbol user) (lambda () #f) #f users-file)))) - (define configuration - (configuration-table-sexpr->web-config@ - config - #:web-server-root (in-web-dir) - #:make-servlet-namespace - (make-make-servlet-namespace - #:to-be-copied-module-specs - '(handin-server/private/md5 - handin-server/private/logger - handin-server/private/config - handin-server/private/hooker - handin-server/private/reloadable)))) +(define (relativize-path p) + (path->string (find-relative-path (normalize-path server-dir) p))) - (define-unit-binding config@ configuration (import) (export web-config^)) - (define-unit-binding ssl-tcp@ - (make-ssl-tcp@ "server-cert.pem" "private-key.pem" #f #f #f #f #f) - (import) (export tcp^)) - (define-compound-unit/infer status-server@ - (import) - (link ssl-tcp@ config@ web-server@) - (export web-server^)) - (define-values/invoke-unit/infer status-server@) +(define (make-k k tag) + (format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?") + (uri-encode tag))) - (serve)) +;; `look-for' can be a username as a string (will find "bar+foo" for "foo"), or +;; a regexp that should match the whole directory name (used with "^solution" +;; below) +(define (find-handin-entry hi look-for) + (let ([dir (assignment<->dir hi)]) + (and (directory-exists? dir) + (ormap + (lambda (d) + (let ([d (path->string d)]) + (and (cond [(string? look-for) + (member look-for (regexp-split #rx" *[+] *" d))] + [(regexp? look-for) (regexp-match? look-for d)] + [else (error 'find-handin-entry + "internal error: ~e" look-for)]) + (build-path dir d)))) + (directory-list dir))))) + +(define (handin-link k user hi) + (let* ([dir (find-handin-entry hi user)] + [l (and dir (with-handlers ([exn:fail? (lambda (x) null)]) + (parameterize ([current-directory dir]) + (sort (filter (lambda (f) + (and (not (equal? f "grade")) + (file-exists? f))) + (map path->string (directory-list))) + stringstring + (seconds->date (file-or-directory-modify-seconds hi)) + #t) + ")"))) + l)) + (list (format "No handins accepted so far for user ~s, assignment ~s" + user hi))))) + +(define (solution-link k hi) + (let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs)) + (find-handin-entry hi #rx"^solution"))] + [none `((i "---"))]) + (cond [(not soln) none] + [(file-exists? soln) + `((a ((href ,(make-k k (relativize-path soln)))) "Solution"))] + [(directory-exists? soln) + (parameterize ([current-directory soln]) + (let ([files (sort (map path->string + (filter file-exists? (directory-list))) + stringdir dir)]) + `(tr ([valign "top"]) + ,(apply header hi (if active? `((br) (small (small "[active]"))) '())) + ,(apply cell (handin-link k user hi)) + ,(rcell (handin-grade user hi)) + ,(apply cell (solution-link k hi))))) + (let* ([next + (send/suspend + (lambda (k) + (make-page + (format "All Handins for ~a" user) + `(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"]) + (tr () ,@(map header '(nbsp "Files" "Grade" "Solution"))) + ,@(append (map (row k #t) (get-conf 'active-dirs)) + (map (row k #f) (get-conf 'inactive-dirs)))))))] + [tag (aget (request-bindings next) 'tag)]) + (download user tag))) + +(define (download who tag) + (define (check path elts allow-active?) + (let loop ([path path] [elts (reverse elts)]) + (let*-values ([(base name dir?) (split-path path)] + [(name) (path->string name)] + [(check) (and (pair? elts) (car elts))]) + (if (null? elts) + ;; must be rooted in a submission directory (why build-path instead + ;; of using `path'? -- because path will have a trailing slash) + (member (build-path base name) + (get-conf (if allow-active? 'all-dirs 'inactive-dirs))) + (and (cond [(eq? '* check) #t] + [(regexp? check) (regexp-match? check name)] + [(string? check) + (or (equal? name check) + (member check (regexp-split #rx" *[+] *" name)))] + [else #f]) + (loop base (cdr elts))))))) + (define file (build-path server-dir tag)) + (with-handlers ([exn:fail? + (lambda (exn) + (log-line "Status exception: ~a" (exn-message exn)) + (make-page "Error" "Illegal file access"))]) + ;; Make sure the user is allowed to read the requested file: + (or (check file `(,who *) #t) + (check file `(#rx"^solution") #f) + (check file `(#rx"^solution" *) #f) + (error 'download "bad file access for ~s: ~a" who file)) + (log-line "Status file-get: ~s ~a" who file) + (hook 'status-file-get `([username ,(string->symbol who)] [file ,file])) + ;; Return the downloaded file + (let* ([data (file->bytes file)] + [html? (regexp-match? #rx"[.]html?$" (string-foldcase tag))] + [wxme? (regexp-match? + #rx#"^(?:#reader[(]lib\"read.ss\"\"wxme\"[)])?WXME" data)]) + (make-response/full 200 "Okay" (current-seconds) + (cond [html? #"text/html"] + [wxme? #"application/data"] + [else #"text/plain"]) + (list + (make-header #"Content-Length" + (string->bytes/latin-1 + (number->string (bytes-length data)))) + (make-header #"Content-Disposition" + (string->bytes/utf-8 + (format "~a; filename=~s" + (if wxme? "attachment" "inline") + (let-values ([(base name dir?) (split-path file)]) + (path->string name)))))) + (list data))))) + +(define (status-page user for-handin) + (log-line "Status access: ~s" user) + (hook 'status-login `([username ,(string->symbol user)])) + (if for-handin + (one-status-page user for-handin) + (all-status-page user))) + +(define (login-page for-handin errmsg) + (let* ([request + (send/suspend + (lambda (k) + (make-page + "Handin Status Login" + `(form ([action ,k] [method "post"]) + (table ([align "center"]) + (tr (td ([colspan "2"] [align "center"]) + (font ([color "red"]) ,(or errmsg 'nbsp)))) + (tr (td "Username") + (td (input ([type "text"] [name "user"] [size "20"] + [value ""])))) + (tr (td nbsp)) + (tr (td "Password") + (td (input ([type "password"] [name "passwd"] + [size "20"] [value ""])))) + (tr (td ([colspan "2"] [align "center"]) + (input ([type "submit"] [name "post"] + [value "Login"])))))))))] + [bindings (request-bindings request)] + [user (aget bindings 'user)] + [passwd (aget bindings 'passwd)] + [user (and user (clean-str user))] + [user-data (get-user-data user)]) + (cond [(and user-data + (string? passwd) + (let ([pw (md5 passwd)]) + (or (equal? pw (car user-data)) + (equal? pw (get-conf 'master-password))))) + (status-page user for-handin)] + [else (login-page for-handin "Bad username or password")]))) + +(define web-counter + (let ([sema (make-semaphore 1)] [count 0]) + (lambda () + (dynamic-wind + (lambda () (semaphore-wait sema)) + (lambda () (set! count (add1 count)) (format "w~a" count)) + (lambda () (semaphore-post sema)))))) + +(define ((send-error msg) req) + `(html (head (meta [(http-equiv "refresh") (content "3;URL=/")]) + (title ,msg)) + (body ,msg "; " (a ([href "/"]) "restarting") " in 3 seconds."))) + +(define ((run-servlet port)) + (define dir (string->path server-dir)) + (serve/servlet + (lambda (request) + (parameterize ([current-session (web-counter)]) + (login-page (aget (request-bindings request) 'handin) #f))) + #:port port #:listen-ip #f #:ssl? #t #:command-line? #t + #:servlet-path "/" #:servlet-regexp #rx"" + #:server-root-path dir #:servlets-root dir + #:file-not-found-responder (send-error "File not found") + #:servlet-namespace '(handin-server/private/md5 + handin-server/private/logger + handin-server/private/config + handin-server/private/hooker + handin-server/private/reloadable) + #:manager (make-threshold-LRU-manager + (send-error "Your session has expired") (* 12 1024 1024)))) + + + +(provide run) +(define (run p) + (thread (lambda () (dynamic-wind + (lambda () (log-line "*** starting web server")) + (run-servlet p) + (lambda () (log-line "*** web server died!"))))) + (void)) From 827b76cb6fb431a7d34fc8fef1d17dcced35b876 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 09:54:05 +0000 Subject: [PATCH 19/29] return a thunk that can kill the web server svn: r12532 --- collects/handin-server/web-status-server.ss | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index 64307edc6e..d6c371ab5c 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -272,8 +272,9 @@ (provide run) (define (run p) - (thread (lambda () (dynamic-wind - (lambda () (log-line "*** starting web server")) - (run-servlet p) - (lambda () (log-line "*** web server died!"))))) - (void)) + (define t + (thread (lambda () (dynamic-wind + (lambda () (log-line "*** starting web server")) + (run-servlet p) + (lambda () (log-line "*** web server died!")))))) + (lambda () (thread-break t))) From aa824d8e054049df38cc3394dbc8ea2554f15159 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 11:42:28 +0000 Subject: [PATCH 20/29] remove web-base-dir which does not make any sense now svn: r12533 --- collects/handin-server/private/config.ss | 1 - .../scribblings/server-setup.scrbl | 20 +++++-------------- 2 files changed, 5 insertions(+), 16 deletions(-) diff --git a/collects/handin-server/private/config.ss b/collects/handin-server/private/config.ss index 892c348c4e..ffaead0b06 100644 --- a/collects/handin-server/private/config.ss +++ b/collects/handin-server/private/config.ss @@ -74,7 +74,6 @@ [(allow-new-users) (values #f id )] [(allow-change-info) (values #f id )] [(master-password) (values #f id )] - [(web-base-dir) (values #f path/false )] [(log-output) (values #t id )] [(log-file) (values "log" path/false )] [(web-log-file) (values #f path/false )] diff --git a/collects/handin-server/scribblings/server-setup.scrbl b/collects/handin-server/scribblings/server-setup.scrbl index 5be0694ea0..90429b0d91 100644 --- a/collects/handin-server/scribblings/server-setup.scrbl +++ b/collects/handin-server/scribblings/server-setup.scrbl @@ -114,16 +114,6 @@ This directory contains the following files and sub-directories: option), or @scheme[#f] for no log file; defaults to @filepath{log}.} - @item{@indexed-scheme[web-base-dir] --- if @scheme[#f] (the - default), the built-in web server will use the - @filepath{status-web-root} in the handin collection for its - configuration; to have complete control over the built in server - content, you can copy and edit @filepath{status-web-root}, then - add this configuration entry set to the name of your new copy - (relative to the handin server directory, or absolute). Note that - you must copy the @filepath{servlets} directory if you want the - status servlet.} - @item{@indexed-scheme[web-log-file] --- a path (relative to handin server directory or absolute) that specifies a filename for logging the internal HTTPS status web server; or @scheme[#f] (the @@ -218,11 +208,11 @@ This directory contains the following files and sub-directories: Changes to @filepath{config.ss} are detected, the file will be re-read, and options are reloaded. A few options are fixed at - startup time: port numbers, log file specs, and the - @scheme[web-base-dir] are fixed as configured at startup. All other - options will change the behavior of the running server (but things - like @scheme[username-case-sensitive?] it would be unwise to do - so). (For safety, options are not reloaded until the file parses + startup time: port numbers and log file specs are fixed as + configured at startup. All other options will change the behavior + of the running server (but things like + @scheme[username-case-sensitive?] it would be unwise to do so). + (For safety, options are not reloaded until the file parses correctly, but make sure that you don't save a copy that has inconsistent options: it is best to create a new configuration file and move it over the old one, or use an editor that does so and not From 44ae50652657e7d85d8a3285ca543f2a7b7d30bd Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 11:59:37 +0000 Subject: [PATCH 21/29] typo svn: r12534 --- collects/handin-server/web-status-server.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index d6c371ab5c..d6b37813a5 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -277,4 +277,4 @@ (lambda () (log-line "*** starting web server")) (run-servlet p) (lambda () (log-line "*** web server died!")))))) - (lambda () (thread-break t))) + (lambda () (break-thread t))) From 631a8be60c4938e8de16a160158934f36445c945 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 12:11:37 +0000 Subject: [PATCH 22/29] * Added #:log-file to `serve/servlet' (always using the 'apache-default format for now) * Using a convenient `dispatcher-sequence' as a `sequencer:make' wrapper svn: r12535 --- collects/web-server/servlet-env.ss | 44 ++++++++++++++++++++---------- 1 file changed, 30 insertions(+), 14 deletions(-) diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 7342405b98..2e8fd2a751 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -26,7 +26,8 @@ (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) (prefix-in files: web-server/dispatchers/dispatch-files) (prefix-in filter: web-server/dispatchers/dispatch-filter) - (prefix-in servlets: web-server/dispatchers/dispatch-servlets)) + (prefix-in servlets: web-server/dispatchers/dispatch-servlets) + (prefix-in log: web-server/dispatchers/dispatch-log)) (define send-url (make-parameter net:send-url)) @@ -58,9 +59,19 @@ #:file-not-found-responder (request? . -> . response?) #:mime-types-path path? #:servlet-path string? - #:servlet-regexp regexp?) + #:servlet-regexp regexp? + #:log-file (or/c false/c path?)) . ->* . void)]) + +;; utility for conveniently chaining dispatchers +(define (dispatcher-sequence . dispatchers) + (let loop ([ds dispatchers] [r '()]) + (cond [(null? ds) (apply sequencer:make (reverse r))] + [(not (car ds)) (loop (cdr ds) r)] + [(list? (car ds)) (loop (append (car ds) (cdr ds)) r)] + [else (loop (cdr ds) (cons (car ds) r))]))) + (define (serve/servlet start #:command-line? @@ -114,7 +125,10 @@ p (build-path (directory-part default-configuration-table-path) - "mime.types")))]) + "mime.types")))] + + #:log-file + [log-file #f]) (define standalone-url (string-append (if ssl? "https" "http") "://localhost" @@ -126,10 +140,13 @@ (define sema (make-semaphore 0)) (define servlet-box (box #f)) (define dispatcher - (sequencer:make - (if quit? - (filter:make #rx"^/quit$" (quit-server sema)) - (lambda _ (next-dispatcher))) + (dispatcher-sequence + (and log-file (log:make #:format (log:log-format->format + ;; 'parenthesized-default + ;; 'extended + 'apache-default) + #:log-path log-file)) + (and quit? (filter:make #rx"^/quit$" (quit-server sema))) (filter:make servlet-regexp (servlets:make @@ -155,13 +172,12 @@ (make-default-path->servlet #:make-servlet-namespace make-servlet-namespace))]) (servlets:make url->servlet)) - (apply sequencer:make - (map (lambda (extra-files-path) - (files:make - #:url->path (fsmap:make-url->path extra-files-path) - #:path->mime-type (make-path->mime-type mime-types-path) - #:indices (list "index.html" "index.htm"))) - extra-files-paths)) + (map (lambda (extra-files-path) + (files:make + #:url->path (fsmap:make-url->path extra-files-path) + #:path->mime-type (make-path->mime-type mime-types-path) + #:indices (list "index.html" "index.htm"))) + extra-files-paths) (files:make #:url->path (fsmap:make-url->path (build-path server-root-path "htdocs")) #:path->mime-type (make-path->mime-type mime-types-path) From ed8cd4b37f5753cf13212acb93ca65b4c419cd60 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 20 Nov 2008 12:15:53 +0000 Subject: [PATCH 23/29] re-add the log file option svn: r12536 --- collects/handin-server/main.ss | 4 +--- collects/handin-server/web-status-server.ss | 23 ++++++++++++--------- 2 files changed, 14 insertions(+), 13 deletions(-) diff --git a/collects/handin-server/main.ss b/collects/handin-server/main.ss index ba1730692c..55291a7012 100644 --- a/collects/handin-server/main.ss +++ b/collects/handin-server/main.ss @@ -622,9 +622,7 @@ (log-line "server started ------------------------------") (hook 'server-start `([port ,(get-conf 'port-number)])) -(define stop-status - (cond [(get-conf 'https-port-number) => web:run] - [else void])) +(define stop-status (web:run)) (define session-count 0) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index d6b37813a5..f6cc7090ce 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -266,15 +266,18 @@ handin-server/private/hooker handin-server/private/reloadable) #:manager (make-threshold-LRU-manager - (send-error "Your session has expired") (* 12 1024 1024)))) - - + (send-error "Your session has expired") (* 12 1024 1024)) + #:log-file (get-conf 'web-log-file))) (provide run) -(define (run p) - (define t - (thread (lambda () (dynamic-wind - (lambda () (log-line "*** starting web server")) - (run-servlet p) - (lambda () (log-line "*** web server died!")))))) - (lambda () (break-thread t))) +(define (run) + (cond [(get-conf 'https-port-number) + => (lambda (p) + (define t + (thread (lambda () + (dynamic-wind + (lambda () (log-line "*** starting web server")) + (run-servlet p) + (lambda () (log-line "*** web server died!")))))) + (lambda () (break-thread t)))] + [else void])) From 1a4b3abba7cc0191ea431ef86a7bdd4911a0d41d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Nov 2008 13:47:06 +0000 Subject: [PATCH 24/29] decompiler repairs svn: r12537 --- collects/compiler/decompile.ss | 122 ++++++++++++++++++--------------- collects/compiler/zo-parse.ss | 17 +++-- 2 files changed, 75 insertions(+), 64 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 70a64f71c1..4fc5259255 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -28,12 +28,12 @@ (hash-set! table n (car b))))) table)) -(define (list-ref/protect l pos) +(define (list-ref/protect l pos who) (list-ref l pos) #; (if (pos . < . (length l)) (list-ref l pos) - `(OUT-OF-BOUNDS ,pos ,l))) + `(OUT-OF-BOUNDS ,who ,pos ,(length l) ,l))) ;; ---------------------------------------- @@ -44,7 +44,7 @@ (let-values ([(globs defns) (decompile-prefix prefix)]) `(begin ,@defns - ,(decompile-form form globs '(#%globals))))] + ,(decompile-form form globs '(#%globals) (make-hasheq))))] [else (error 'decompile "unrecognized: ~e" top)])) (define (decompile-prefix a-prefix) @@ -76,7 +76,7 @@ lift-ids) (map (lambda (stx id) `(define ,id ,(if stx - `(#%decode-syntax ,(stx-encoded stx)) + `(#%decode-syntax ,stx #;(stx-encoded stx)) #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -90,18 +90,19 @@ (match mod-form [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) (let-values ([(globs defns) (decompile-prefix prefix)] - [(stack) (append '(#%modvars) stack)]) + [(stack) (append '(#%modvars) stack)] + [(closed) (make-hasheq)]) `(module ,name .... ,@defns ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) syntax-body) ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) body)))] [else (error 'decompile-module "huh?: ~e" mod-form)])) -(define (decompile-form form globs stack) +(define (decompile-form form globs stack closed) (match form [(? mod?) (decompile-module form stack)] @@ -109,31 +110,31 @@ `(define-values ,(map (lambda (tl) (match tl [(struct toplevel (depth pos const? mutated?)) - (list-ref/protect globs pos)])) + (list-ref/protect globs pos 'def-vals)])) ids) - ,(decompile-expr rhs globs stack))] + ,(decompile-expr rhs globs stack closed))] [(struct def-syntaxes (ids rhs prefix max-let-depth)) `(define-syntaxes ,ids ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-form rhs globs '(#%globals)))))] + ,(decompile-form rhs globs '(#%globals) closed))))] [(struct def-for-syntax (ids rhs prefix max-let-depth)) `(define-values-for-syntax ,ids ,(let-values ([(globs defns) (decompile-prefix prefix)]) `(let () ,@defns - ,(decompile-expr rhs globs '(#%globals)))))] + ,(decompile-expr rhs globs '(#%globals) closed))))] [(struct sequence (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) forms))] [(struct splice (forms)) `(begin ,@(map (lambda (form) - (decompile-form form globs stack)) + (decompile-form form globs stack closed)) forms))] [else - (decompile-expr form globs stack)])) + (decompile-expr form globs stack closed)])) (define (extract-name name) (if (symbol? name) @@ -168,22 +169,22 @@ (extract-ids! body ids)] [else #f])) -(define (decompile-expr expr globs stack) +(define (decompile-expr expr globs stack closed) (match expr [(struct toplevel (depth pos const? mutated?)) - (let ([id (list-ref/protect globs pos)]) + (let ([id (list-ref/protect globs pos 'toplevel)]) (if const? id `(#%checked ,id)))] [(struct topsyntax (depth pos midpt)) - (list-ref/protect globs (+ midpt pos))] + (list-ref/protect globs (+ midpt pos) 'topsyntax)] [(struct primitive (id)) (hash-ref primitive-table id)] [(struct assign (id rhs undef-ok?)) - `(set! ,(decompile-expr id globs stack) - ,(decompile-expr rhs globs stack))] + `(set! ,(decompile-expr id globs stack closed) + ,(decompile-expr rhs globs stack closed))] [(struct localref (unbox? offset clear?)) - (let ([id (list-ref/protect stack offset)]) + (let ([id (list-ref/protect stack offset 'localref)]) (let ([e (if unbox? `(#%unbox ,id) id)]) @@ -191,17 +192,17 @@ `(#%sfs-clear ,e) e)))] [(? lam?) - `(lambda . ,(decompile-lam expr globs stack))] + `(lambda . ,(decompile-lam expr globs stack closed))] [(struct case-lam (name lams)) `(case-lambda ,@(map (lambda (lam) - (decompile-lam lam globs stack)) + (decompile-lam lam globs stack closed)) lams))] [(struct let-one (rhs body)) (let ([id (or (extract-id rhs) (gensym 'local))]) - `(let ([,id ,(decompile-expr rhs globs (cons id stack))]) - ,(decompile-expr body globs (cons id stack))))] + `(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)]) + ,(decompile-expr body globs (cons id stack) closed)))] [(struct let-void (count boxes? body)) (let ([ids (make-vector count #f)]) (extract-ids! body ids) @@ -210,71 +211,76 @@ (or id (gensym 'localv)))]) `(let ,(map (lambda (i) `[,i ,(if boxes? `(#%box ?) '?)]) vars) - ,(decompile-expr body globs (append vars stack)))))] + ,(decompile-expr body globs (append vars stack) closed))))] [(struct let-rec (procs body)) `(begin (#%set!-rec-values ,(for/list ([p (in-list procs)] [i (in-naturals)]) - (list-ref/protect stack i)) + (list-ref/protect stack i 'let-rec)) ,@(map (lambda (proc) - (decompile-expr proc globs stack)) + (decompile-expr proc globs stack closed)) procs)) - ,(decompile-expr body globs stack))] + ,(decompile-expr body globs stack closed))] [(struct install-value (count pos boxes? rhs body)) `(begin (,(if boxes? '#%set-boxes! 'set!-values) ,(for/list ([i (in-range count)]) - (list-ref/protect stack (+ i pos))) - ,(decompile-expr rhs globs stack)) - ,(decompile-expr body globs stack))] + (list-ref/protect stack (+ i pos) 'install-value)) + ,(decompile-expr rhs globs stack closed)) + ,(decompile-expr body globs stack closed))] [(struct boxenv (pos body)) - (let ([id (list-ref/protect stack pos)]) + (let ([id (list-ref/protect stack pos 'boxenv)]) `(begin (set! ,id (#%box ,id)) - ,(decompile-expr body globs stack)))] + ,(decompile-expr body globs stack closed)))] [(struct branch (test then else)) - `(if ,(decompile-expr test globs stack) - ,(decompile-expr then globs stack) - ,(decompile-expr else globs stack))] + `(if ,(decompile-expr test globs stack closed) + ,(decompile-expr then globs stack closed) + ,(decompile-expr else globs stack closed))] [(struct application (rator rands)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) stack)]) (annotate-inline - `(,(decompile-expr rator globs stack) + `(,(decompile-expr rator globs stack closed) ,@(map (lambda (rand) - (decompile-expr rand globs stack)) + (decompile-expr rand globs stack closed)) rands))))] [(struct apply-values (proc args-expr)) - `(#%apply-values ,(decompile-expr proc globs stack) - ,(decompile-expr args-expr globs stack))] + `(#%apply-values ,(decompile-expr proc globs stack closed) + ,(decompile-expr args-expr globs stack closed))] [(struct sequence (exprs)) `(begin ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack)))] + (decompile-expr expr globs stack closed)))] [(struct beg0 (exprs)) `(begin0 ,@(for/list ([expr (in-list exprs)]) - (decompile-expr expr globs stack)))] + (decompile-expr expr globs stack closed)))] [(struct with-cont-mark (key val body)) `(with-continuation-mark - ,(decompile-expr key globs stack) - ,(decompile-expr val globs stack) - ,(decompile-expr body globs stack))] + ,(decompile-expr key globs stack closed) + ,(decompile-expr val globs stack closed) + ,(decompile-expr body globs stack closed))] [(struct closure (lam gen-id)) - `(#%closed ,gen-id ,(decompile-expr lam globs stack))] + (if (hash-ref closed gen-id #f) + gen-id + (begin + (hash-set! closed gen-id #t) + `(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))] [(struct indirect (val)) (if (closure? val) - (closure-gen-id val) + (decompile-expr val globs stack closed) '???)] [else `(quote ,expr)])) -(define (decompile-lam expr globs stack) +(define (decompile-lam expr globs stack closed) (match expr - [(struct closure (lam gen-id)) (decompile-lam lam globs stack)] + [(struct indirect (val)) (decompile-lam val globs stack closed)] + [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] [(struct lam (name flags num-params rest? closure-map max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)]) (gensym (format "arg~a-" i)))] [rest-vars (if rest? (list (gensym 'rest)) null)] [captures (map (lambda (v) - (list-ref/protect stack v)) + (list-ref/protect stack v 'lam)) (vector->list closure-map))]) `((,@vars . ,(if rest? (car rest-vars) @@ -285,8 +291,10 @@ ,@(if (null? captures) null `('(captures: ,@captures))) - ,(decompile-expr body globs (append captures - (append vars rest-vars)))))])) + ,(decompile-expr body globs + (append captures + (append vars rest-vars)) + closed)))])) (define (annotate-inline a) (if (and (symbol? (car a)) @@ -301,16 +309,16 @@ car cdr caar cadr cdar cddr mcar mcdr unbox vector-length syntax-e add1 sub1 - abs bitwise-not - list vector box))] + list list* vector vector-immutable box))] [(3) (memq (car a) '(eq? = <= < >= > bitwise-bit-set? char=? + - * / min max bitwise-and bitwise-ior arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons - list vector))] + list list* vector vector-immutable))] [(4) (memq (car a) '(vector-set! string-set! bytes-set! - list vector))] - [else (memq (car a) '(list vector))])) + list list* vector vector-immutable))] + [else (memq (car a) '(list list* vector vector-immutable))])) (cons '#%in a) a)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index a19caea4ad..57472a6c38 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -661,7 +661,7 @@ ;; Main parsing loop (define (read-compact cp) - (let loop ([need-car 0] [proper #f] [last #f] [first #f]) + (let loop ([need-car 0] [proper #f]) (begin-with-definitions (define ch (cp-getc cp)) (define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)]) @@ -707,7 +707,7 @@ (cons (read-compact cp) (if ppr null (read-compact cp))) (read-compact-list l ppr cp)) - (loop l ppr last first)))] + (loop l ppr)))] [(let-one) (make-let-one (read-compact cp) (read-compact cp))] [(branch) @@ -747,8 +747,10 @@ (read-compact cp))]) (vector->immutable-vector (list->vector lst)))] [(list) (let* ([n (read-compact-number cp)]) - (for/list ([i (in-range n)]) - (read-compact cp)))] + (append + (for/list ([i (in-range n)]) + (read-compact cp)) + (read-compact cp)))] [(prefab) (let ([v (read-compact cp)]) (apply make-prefab-struct @@ -845,9 +847,8 @@ [(symbol? s) s] [(vector? s) (vector-ref s 0)] [else 'closure]))))]) - (vector-set! (cport-symtab cp) l cl) (set-indirect-v! ind cl) - cl))] + ind))] [(svector) (read-compact-svector cp (read-compact-number cp))] [(small-svector) @@ -858,7 +859,7 @@ [(and proper (= need-car 1)) (cons v null)] [else - (cons v (loop (sub1 need-car) proper last first))])))) + (cons v (loop (sub1 need-car) proper))])))) ;; path -> bytes ;; implementes read.c:read_compiled @@ -898,11 +899,13 @@ (define symtab (make-vector symtabsize (make-not-ready))) (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) + (for/list ([i (in-range 1 symtabsize)]) (when (not-ready? (vector-ref symtab i)) (set-cport-pos! cp (vector-ref so* (sub1 i))) (let ([v (read-compact cp)]) (vector-set! symtab i v)))) + (set-cport-pos! cp shared-size) (read-marshalled 'compilation-top-type cp))) From 93a13222dc02fecd371e8269e3919f3f0f4f3ff7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Nov 2008 13:48:48 +0000 Subject: [PATCH 25/29] Mac: change draw-point to use Quartz in smoothed mode svn: r12538 --- src/wxmac/src/mac/wx_dccan2.cc | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/src/wxmac/src/mac/wx_dccan2.cc b/src/wxmac/src/mac/wx_dccan2.cc index cd46d06c0b..a64e91ef88 100644 --- a/src/wxmac/src/mac/wx_dccan2.cc +++ b/src/wxmac/src/mac/wx_dccan2.cc @@ -533,6 +533,32 @@ void wxCanvasDC::DrawPoint(double x, double y) if (!current_pen || current_pen->GetStyle() == wxTRANSPARENT) return; + if (anti_alias) { + double xx, yy; + CGContextRef cg; + + SetCurrentDC(TRUE); + cg = GetCG(); + + CGContextSaveGState(cg); + + xx = SmoothingXFormX(x); + yy = SmoothingXFormY(y); + + CGContextMoveToPoint(cg, xx, yy); + CGContextAddLineToPoint(cg, xx, yy); + + wxMacSetCurrentTool(kPenTool); + CGContextStrokePath(cg); + wxMacSetCurrentTool(kNoTool); + + CGContextRestoreGState(cg); + + ReleaseCurrentDC(); + + return; + } + SetCurrentDC(); wxMacSetCurrentTool(kPenTool); wxMacDrawPoint(XLOG2DEV(x), YLOG2DEV(y)); From 8ccce66af7b96a141d661b8af36cb974be77a9d4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 20 Nov 2008 13:50:22 +0000 Subject: [PATCH 26/29] round out inlining and optimization of simple allocating primitives svn: r12539 --- collects/tests/mzscheme/optimize.ss | 41 +++++++++++++++++----- collects/texpict/utils.ss | 4 +-- src/mred/wxme/wx_mpbrd.cxx | 1 - src/mzscheme/src/eval.c | 30 ++++++++++++---- src/mzscheme/src/jit.c | 54 ++++++++++++++++++++++++----- src/mzscheme/src/list.c | 23 +++++++++--- src/mzscheme/src/read.c | 8 +++++ src/mzscheme/src/schpriv.h | 6 ++++ src/mzscheme/src/vector.c | 8 +++++ 9 files changed, 143 insertions(+), 32 deletions(-) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 0ed2853c66..98894a67c0 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -350,6 +350,9 @@ (un0 '(1) 'list 1) (bin0 '(1 2) 'list 1 2) (tri0 '(1 2 3) 'list (lambda () 1) 2 3 void) + (un0 '1 'list* 1) + (bin0 '(1 . 2) 'list* 1 2) + (tri0 '(1 2 . 3) 'list* (lambda () 1) 2 3 void) (un0 '#&1 'box 1) (let ([test-setter @@ -443,17 +446,19 @@ (list a b c d e f))]) 10)) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][j i]) j)) - (normalize-depth '(let* ([i (cons 0 1)]) i))) +;; We use nonsense `display' and `write' where we used to use `cons' and +;; `list', because the old ones now get optimized away: +(test-comp (normalize-depth '(let* ([i (display 0 1)][j i]) j)) + (normalize-depth '(let* ([i (display 0 1)]) i))) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i]) g)) - (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i))) +(test-comp (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)][g i]) g)) + (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)]) i))) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)][g i][h g]) h)) - (normalize-depth '(let* ([i (cons 0 1)][j (list 2)][k (list 3)]) i))) +(test-comp (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)][g i][h g]) h)) + (normalize-depth '(let* ([i (display 0 1)][j (write 2)][k (write 3)]) i))) -(test-comp (normalize-depth '(let* ([i (cons 0 1)][g i][h (car g)][m h]) m)) - (normalize-depth '(let* ([i (cons 0 1)][h (car i)]) h))) +(test-comp (normalize-depth '(let* ([i (display 0 1)][g i][h (car g)][m h]) m)) + (normalize-depth '(let* ([i (display 0 1)][h (car i)]) h))) ; (require #%kernel) ; @@ -685,6 +690,26 @@ (define (q x) (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10)))))))))))))) +(let ([test-dropped + (lambda (cons-name . args) + (test-comp `(let ([x 5]) + (let ([y (,cons-name ,@args)]) + x)) + 5))]) + (test-dropped 'cons 1 2) + (test-dropped 'mcons 1 2) + (test-dropped 'box 1) + (let ([test-multi + (lambda (cons-name) + (test-dropped cons-name 1 2) + (test-dropped cons-name 1 2 3) + (test-dropped cons-name 1) + (test-dropped cons-name))]) + (test-multi 'list) + (test-multi 'list*) + (test-multi 'vector) + (test-multi 'vector-immutable))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check bytecode verification of lifted functions diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss index f787dd868f..ff0305dadc 100644 --- a/collects/texpict/utils.ss +++ b/collects/texpict/utils.ss @@ -286,9 +286,9 @@ w h)))) - (define (filled-rounded-rectangle w h [corner-radius 0.25] #:angle [angle 0]) + (define (filled-rounded-rectangle w h [corner-radius -0.25] #:angle [angle 0]) (let ([dc-path (new dc-path%)]) - (send dc-path rounded-rectangle 0 0 w h (- corner-radius)) + (send dc-path rounded-rectangle 0 0 w h corner-radius) (send dc-path rotate angle) (let-values ([(x y w h) (send dc-path get-bounding-box)]) (dc (λ (dc dx dy) diff --git a/src/mred/wxme/wx_mpbrd.cxx b/src/mred/wxme/wx_mpbrd.cxx index b038ab87f1..17f6bb9730 100644 --- a/src/mred/wxme/wx_mpbrd.cxx +++ b/src/mred/wxme/wx_mpbrd.cxx @@ -317,7 +317,6 @@ void wxMediaPasteboard::OnDefaultEvent(wxMouseEvent *event) if (!admin) return; - /* First, find clicked-on snip: */ x = event->x; y = event->y; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 1a169a3daa..1aff3b6e8a 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -889,8 +889,12 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 1; } } - /* (void ...) */ - if (SAME_OBJ(scheme_void_proc, app->args[0])) { + /* ({void,list,list*,vector,vector-immutable} ...) */ + if (SAME_OBJ(scheme_void_proc, app->args[0]) + || SAME_OBJ(scheme_list_proc, app->args[0]) + || SAME_OBJ(scheme_list_star_proc, app->args[0]) + || SAME_OBJ(scheme_vector_proc, app->args[0]) + || SAME_OBJ(scheme_vector_immutable_proc, app->args[0])) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { int i; @@ -905,10 +909,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, } if ((vtype == scheme_application2_type)) { - /* (values ) or (void ) */ + /* ({values,void,list,list*,vector,vector-immutable,box} ) */ Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; if (SAME_OBJ(scheme_values_func, app->rator) - || SAME_OBJ(scheme_void_proc, app->rator)) { + || SAME_OBJ(scheme_void_proc, app->rator) + || SAME_OBJ(scheme_list_proc, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator) + || SAME_OBJ(scheme_vector_proc, app->rator) + || SAME_OBJ(scheme_vector_immutable_proc, app->rator) + || SAME_OBJ(scheme_box_proc, app->rator)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info)) @@ -928,8 +937,14 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 1; } } - /* (void ) */ - if (SAME_OBJ(scheme_void_proc, app->rator)) { + /* ({void,cons,list,list*,vector,vector-immutable) ) */ + if (SAME_OBJ(scheme_void_proc, app->rator) + || SAME_OBJ(scheme_cons_proc, app->rator) + || SAME_OBJ(scheme_mcons_proc, app->rator) + || SAME_OBJ(scheme_list_proc, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator) + || SAME_OBJ(scheme_vector_proc, app->rator) + || SAME_OBJ(scheme_vector_immutable_proc, app->rator)) { note_match(1, vals, warn_info); if ((vals == 1) || (vals < 0)) { if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info) @@ -2507,7 +2522,8 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf } } - if (SAME_OBJ(scheme_values_func, app->rator) + if ((SAME_OBJ(scheme_values_func, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator)) && scheme_omittable_expr(app->rand, 1, -1, 0, info)) { info->preserves_marks = 1; info->single_result = 1; diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 0e04244bbe..3c4c239c2e 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -1256,8 +1256,7 @@ static void *malloc_double(void) #endif #ifdef CAN_INLINE_ALLOC -static void *make_list_code; -# define make_list make_list_code +static void *make_list_code, *make_list_star_code; #else static Scheme_Object *make_list(long n) { @@ -1270,6 +1269,17 @@ static Scheme_Object *make_list(long n) return l; } +static Scheme_Object *make_list_star(long n) +{ + GC_CAN_IGNORE Scheme_Object **rs = MZ_RUNSTACK; + GC_CAN_IGNORE Scheme_Object *l = rs[--n]; + + while (n--) { + l = cons(rs[n], l); + } + + return l; +} #endif #if !defined(CAN_INLINE_ALLOC) @@ -4077,6 +4087,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } else if (IS_NAMED_PRIM(rator, "vector-immutable") || IS_NAMED_PRIM(rator, "vector")) { return generate_vector_alloc(jitter, rator, NULL, app, NULL); + } else if (IS_NAMED_PRIM(rator, "list*")) { + /* on a single argument, `list*' is identity */ + mz_runstack_skipped(jitter, 1); + generate_non_tail(app->rand, jitter, 0, 1); + CHECK_LIMIT(); + mz_runstack_unskipped(jitter, 1); + return 1; } else if (IS_NAMED_PRIM(rator, "list")) { mz_runstack_skipped(jitter, 1); generate_non_tail(app->rand, jitter, 0, 1); @@ -4553,7 +4570,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i (void)jit_movi_p(JIT_R0, scheme_void); return 1; - } else if (IS_NAMED_PRIM(rator, "cons")) { + } else if (IS_NAMED_PRIM(rator, "cons") + || IS_NAMED_PRIM(rator, "list*")) { LOG_IT(("inlined cons\n")); generate_two_args(app->rand1, app->rand2, jitter, 1); @@ -4748,8 +4766,12 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } else if (IS_NAMED_PRIM(rator, "vector-immutable") || IS_NAMED_PRIM(rator, "vector")) { return generate_vector_alloc(jitter, rator, app, NULL, NULL); - } else if (IS_NAMED_PRIM(rator, "list")) { + } else if (IS_NAMED_PRIM(rator, "list") + || IS_NAMED_PRIM(rator, "list*")) { int c = app->num_args; + int star; + + star = IS_NAMED_PRIM(rator, "list*"); if (c) generate_app(app, NULL, c, jitter, 0, 0, 1); @@ -4757,13 +4779,19 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int #ifdef CAN_INLINE_ALLOC jit_movi_l(JIT_R2, c); - (void)jit_calli(make_list_code); + if (star) + (void)jit_calli(make_list_star_code); + else + (void)jit_calli(make_list_code); #else JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); jit_movi_l(JIT_R0, c); mz_prepare(1); jit_pusharg_l(JIT_R0); - (void)mz_finish(make_list); + if (star) + (void)mz_finish(make_list_star); + else + (void)mz_finish(make_list); jit_retval(JIT_R0); #endif @@ -7252,13 +7280,21 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) #ifdef CAN_INLINE_ALLOC /* *** make_list_code *** */ /* R2 has length, args are on runstack */ - { + for (i = 0; i < 2; i++) { jit_insn *ref, *refnext; - make_list_code = jit_get_ip().ptr; + if (i == 0) + make_list_code = jit_get_ip().ptr; + else + make_list_star_code = jit_get_ip().ptr; mz_prolog(JIT_R1); jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE); - (void)jit_movi_p(JIT_R0, &scheme_null); + if (i == 0) + (void)jit_movi_p(JIT_R0, &scheme_null); + else { + jit_subi_l(JIT_R2, JIT_R2, JIT_WORD_SIZE); + jit_ldxr_p(JIT_R0, JIT_RUNSTACK, JIT_R2); + } __START_SHORT_JUMPS__(1); ref = jit_beqi_l(jit_forward(), JIT_R2, 0); diff --git a/src/mzscheme/src/list.c b/src/mzscheme/src/list.c index 30254661a6..21d1d6d8df 100644 --- a/src/mzscheme/src/list.c +++ b/src/mzscheme/src/list.c @@ -27,7 +27,11 @@ /* globals */ Scheme_Object scheme_null[1]; +Scheme_Object *scheme_cons_proc; +Scheme_Object *scheme_mcons_proc; Scheme_Object *scheme_list_proc; +Scheme_Object *scheme_list_star_proc; +Scheme_Object *scheme_box_proc; /* locals */ static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]); @@ -155,7 +159,9 @@ scheme_init_list (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant ("mpair?", p, env); + REGISTER_SO(scheme_cons_proc); p = scheme_make_noncm_prim(cons_prim, "cons", 2, 2); + scheme_cons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; scheme_add_global_constant ("cons", p, env); @@ -167,7 +173,9 @@ scheme_init_list (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant ("cdr", p, env); + REGISTER_SO(scheme_mcons_proc); p = scheme_make_noncm_prim(mcons_prim, "mcons", 2, 2); + scheme_mcons_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; scheme_add_global_constant ("mcons", p, env); @@ -205,11 +213,14 @@ scheme_init_list (Scheme_Env *env) | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant ("list", p, env); - scheme_add_global_constant ("list*", - scheme_make_immed_prim(list_star_prim, - "list*", - 1, -1), - env); + REGISTER_SO(scheme_list_star_proc); + p = scheme_make_immed_prim(list_star_prim, "list*", 1, -1); + scheme_list_star_proc = p; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); + scheme_add_global_constant ("list*", p, env); + scheme_add_global_constant("immutable?", scheme_make_folding_prim(immutablep, "immutable?", @@ -409,7 +420,9 @@ scheme_init_list (Scheme_Env *env) 1, 1, 1), env); + REGISTER_SO(scheme_box_proc); p = scheme_make_immed_prim(box, BOX, 1, 1); + scheme_box_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant(BOX, p, env); diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index f80452e61e..473c2b1f15 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -4371,6 +4371,8 @@ static Scheme_Object *read_compact_k(void) return read_compact(port, p->ku.k.i1); } +int dump_info = 0; + static Scheme_Object *read_compact(CPort *port, int use_stack) { #define BLK_BUF_SIZE 32 @@ -4396,6 +4398,9 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) ZO_CHECK(port->pos < port->size); ch = CP_GETC(port); + if (dump_info) + printf("%d %d %d\n", ch, port->pos, need_car); + switch(cpt_branch[ch]) { case CPT_ESCAPE: { @@ -4451,6 +4456,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) case CPT_SYMREF: l = read_compact_number(port); RANGE_CHECK(l, < port->symtab_size); + if (dump_info) + printf("%d\n", l); v = port->symtab[l]; if (!v) { long save_pos = port->pos; @@ -5261,6 +5268,7 @@ static Scheme_Object *read_compiled(Scheme_Object *port, len = symtabsize; for (j = 1; j < len; j++) { if (!symtab[j]) { + if (dump_info) printf("at %ld %ld\n", j, rp->pos); v = read_compact(rp, 0); symtab[j] = v; } else { diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 1846ad86b3..9ea3f36d3a 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -260,7 +260,13 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym, extern Scheme_Object *scheme_values_func; extern Scheme_Object *scheme_procedure_p_proc; extern Scheme_Object *scheme_void_proc; +extern Scheme_Object *scheme_cons_proc; +extern Scheme_Object *scheme_mcons_proc; extern Scheme_Object *scheme_list_proc; +extern Scheme_Object *scheme_list_star_proc; +extern Scheme_Object *scheme_vector_proc; +extern Scheme_Object *scheme_vector_immutable_proc; +extern Scheme_Object *scheme_box_proc; extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc; extern Scheme_Object *scheme_current_inspector_proc; diff --git a/src/mzscheme/src/vector.c b/src/mzscheme/src/vector.c index bf51aeae25..0d7ac3df36 100644 --- a/src/mzscheme/src/vector.c +++ b/src/mzscheme/src/vector.c @@ -25,6 +25,10 @@ #include "schpriv.h" +/* globals */ +Scheme_Object *scheme_vector_proc; +Scheme_Object *scheme_vector_immutable_proc; + /* locals */ static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]); static Scheme_Object *make_vector (int argc, Scheme_Object *argv[]); @@ -53,13 +57,17 @@ scheme_init_vector (Scheme_Env *env) 1, 2), env); + REGISTER_SO(scheme_vector_proc); p = scheme_make_immed_prim(vector, "vector", 0, -1); + scheme_vector_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("vector", p, env); + REGISTER_SO(scheme_vector_immutable_proc); p = scheme_make_immed_prim(vector_immutable, "vector-immutable", 0, -1); + scheme_vector_immutable_proc = p; SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED); From 0d902ddeafc4b0c1fa77bc68e40d4df28c0321bd Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 20 Nov 2008 15:57:42 +0000 Subject: [PATCH 27/29] Docs for r12526 svn: r12540 --- collects/web-server/scribblings/servlet-env.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 7b93592f84..1fa4cdcca7 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -82,7 +82,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, [#:launch-browser? launch-browser? boolean? (not command-line?)] [#:quit? quit? boolean? (not command-line?)] [#:banner? banner? boolean? (not command-line?)] - [#:listen-ip listen-ip string? "127.0.0.1"] + [#:listen-ip listen-ip (or/c false/c string?) "127.0.0.1"] [#:port port number? 8000] [#:servlet-path servlet-path string? "/servlets/standalone.ss"] From 333ec0dfc12414c7840e52931b680e317658133a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 20 Nov 2008 16:04:50 +0000 Subject: [PATCH 28/29] Docs for r12529 svn: r12541 --- .../web-server/scribblings/servlet-env.scrbl | 27 ++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 1fa4cdcca7..5f6a880934 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -6,6 +6,8 @@ @(require (for-label web-server/servlet-env web-server/http web-server/managers/lru + web-server/private/util + web-server/configuration/configuration-table web-server/configuration/responders scheme/list)) @@ -84,10 +86,14 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, [#:banner? banner? boolean? (not command-line?)] [#:listen-ip listen-ip (or/c false/c string?) "127.0.0.1"] [#:port port number? 8000] + [#:ssl? ssl? boolean? #f] [#:servlet-path servlet-path string? "/servlets/standalone.ss"] [#:servlet-regexp servlet-regexp regexp? - (regexp (format "^~a$" (regexp-quote servlet-path)))] + (regexp + (format + "^~a$" + (regexp-quote servlet-path)))] [#:stateless? stateless? boolean? #f] [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] [#:servlet-namespace servlet-namespace (listof module-path?) empty] @@ -96,9 +102,21 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, [#:servlets-root servlets-root path? (build-path server-root-path "htdocs")] [#:servlet-current-directory servlet-current-directory path? servlets-root] [#:file-not-found-responder file-not-found-responder - (gen-file-not-found-responder (build-path server-root-path "conf" "not-found.html"))] + (gen-file-not-found-responder + (build-path + server-root-path + "conf" + "not-found.html"))] [#:mime-types-path mime-types-path path? - (build-path server-root-path "mime.types")]) + (let ([p (build-path + server-root-path + "mime.types")]) + (if (file-exists? p) + p + (build-path + (directory-part + default-configuration-table-path) + "mime.types")))]) void]{ This sets up and starts a fairly default server instance. @@ -115,6 +133,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, The server listens on @scheme[listen-ip] and port @scheme[port]. + If @scheme[ssl?] is true, then the server runs in HTTPS mode with @filepath{/server-cert.pem} + and @filepath{/private-key.pem} as the certificates and private keys + The servlet is loaded with @scheme[manager] as its continuation manager. (The default manager limits the amount of memory to 64 MB and deals with memory pressure as discussed in the @scheme[make-threshold-LRU-manager] documentation.) From 52a561fd3ebae729d8e4e3d391b55d51465fa2e1 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 20 Nov 2008 16:10:31 +0000 Subject: [PATCH 29/29] Adding docs and additional option for r12535 svn: r12542 --- collects/web-server/scribblings/servlet-env.scrbl | 9 ++++++++- collects/web-server/servlet-env.ss | 9 ++++----- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 5f6a880934..f4eda42536 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -9,6 +9,7 @@ web-server/private/util web-server/configuration/configuration-table web-server/configuration/responders + web-server/dispatchers/dispatch-log scheme/list)) @defmodule[web-server/servlet-env]{ @@ -102,6 +103,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, [#:servlets-root servlets-root path? (build-path server-root-path "htdocs")] [#:servlet-current-directory servlet-current-directory path? servlets-root] [#:file-not-found-responder file-not-found-responder + (request? . -> . response?) (gen-file-not-found-responder (build-path server-root-path @@ -116,7 +118,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, (build-path (directory-part default-configuration-table-path) - "mime.types")))]) + "mime.types")))] + [#:log-file log-file path? #f] + [#:log-format log-format symbol? 'apache-default]) void]{ This sets up and starts a fairly default server instance. @@ -154,6 +158,9 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, running from the command line, in which case the @scheme[command-line?] option controls similar options. MIME types are looked up at @scheme[mime-types-path]. + + If @scheme[log-file] is given, then it used to log requests using @scheme[log-format] as the format. Allowable formats + are those allowed by @scheme[log-format->format]. } } \ No newline at end of file diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 2e8fd2a751..17166d313c 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -128,7 +128,9 @@ "mime.types")))] #:log-file - [log-file #f]) + [log-file #f] + #:log-format + [log-format 'apache-default]) (define standalone-url (string-append (if ssl? "https" "http") "://localhost" @@ -141,10 +143,7 @@ (define servlet-box (box #f)) (define dispatcher (dispatcher-sequence - (and log-file (log:make #:format (log:log-format->format - ;; 'parenthesized-default - ;; 'extended - 'apache-default) + (and log-file (log:make #:format (log:log-format->format log-format) #:log-path log-file)) (and quit? (filter:make #rx"^/quit$" (quit-server sema))) (filter:make