Recovering bitrot, adding features and fixes
svn: r6269
This commit is contained in:
Jay McCarthy
parent
ecbf609a28
commit
d0318270a4
|
|
@ -1,12 +1,15 @@
|
|||
(module abort-resume mzscheme
|
||||
(require "define-closure.ss"
|
||||
(lib "serialize.ss"))
|
||||
(lib "plt-match.ss")
|
||||
(lib "serialize.ss")
|
||||
(lib "web-cells.ss" "newcont"))
|
||||
(provide
|
||||
|
||||
|
||||
;; AUXILLIARIES
|
||||
abort
|
||||
resume
|
||||
the-cont-key
|
||||
the-save-cm-key
|
||||
safe-call?
|
||||
abort/cc
|
||||
the-undef
|
||||
|
|
@ -22,91 +25,126 @@
|
|||
)
|
||||
|
||||
(provide current-abort-continuation)
|
||||
|
||||
;; **********************************************************************
|
||||
;; **********************************************************************
|
||||
;; AUXILLIARIES
|
||||
|
||||
;; **********************************************************************
|
||||
;; **********************************************************************
|
||||
;; AUXILLIARIES
|
||||
(define-struct mark-key ())
|
||||
(define the-cont-key (make-mark-key))
|
||||
(define the-save-cm-key (make-mark-key))
|
||||
(define safe-call? (make-mark-key))
|
||||
|
||||
;; current-continuation-as-list: -> (listof value)
|
||||
;; check the safety marks and return the list of marks representing the continuation
|
||||
(define (activation-record-list)
|
||||
(let* ([cm (current-continuation-marks)]
|
||||
[sl (continuation-mark-set->list cm safe-call?)])
|
||||
;(printf "sl = ~s~n" sl)
|
||||
(if (andmap (lambda (x) x) sl)
|
||||
(reverse (continuation-mark-set->list cm the-cont-key))
|
||||
(error "Attempt to capture a continuation from within an unsafe context"))))
|
||||
[sl (reverse (continuation-mark-set->list cm safe-call?))])
|
||||
(if (andmap (lambda (x)
|
||||
(if (pair? x)
|
||||
(car x)
|
||||
x))
|
||||
sl)
|
||||
(begin #;(printf "Safe continuation capture from ~S with cm ~S~n" sl cm)
|
||||
#;(printf "MSG CMs: ~S~n" (continuation-mark-set->list* cm (list 'msg the-cont-key the-save-cm-key)))
|
||||
(reverse (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key))))
|
||||
(error "Attempt to capture a continuation from within an unsafe context:" sl))))
|
||||
|
||||
;; BUGBUG this isn't thread safe
|
||||
;; XXX BUGBUG this isn't thread safe
|
||||
(define current-abort-continuation
|
||||
(box #f))
|
||||
(box
|
||||
(lambda _
|
||||
(error 'abort-resume "current-abort-continuation uninitialized"))))
|
||||
|
||||
;; abort: ( -> alpha) -> alpha
|
||||
;; erase the stack and apply a thunk
|
||||
(define (abort thunk)
|
||||
(let ([abort-k (unbox current-abort-continuation)])
|
||||
#;(printf "abort ~S ~S~n" abort-k thunk)
|
||||
(abort-k thunk)))
|
||||
|
||||
;; resume: (listof (value -> value)) value -> value
|
||||
;; resume a computation given a value and list of frame procedures
|
||||
(define (resume frames val)
|
||||
(cond
|
||||
[(null? frames) val]
|
||||
[else
|
||||
(let ([f (car frames)])
|
||||
(f (with-continuation-mark the-cont-key f (resume (cdr frames) val))))]))
|
||||
#;(printf "~S~n" `(resume ,frames ,val))
|
||||
(match frames
|
||||
[(list)
|
||||
(apply values val)]
|
||||
[(list-rest f fs)
|
||||
(match f
|
||||
[(vector #f #f)
|
||||
(error 'resume "Empty frame!")]
|
||||
[(vector f #f)
|
||||
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val)))
|
||||
f)]
|
||||
[(vector #f (list-rest cm-key cm-val))
|
||||
(with-continuation-mark the-save-cm-key (cons cm-key cm-val)
|
||||
(with-continuation-mark cm-key cm-val
|
||||
(resume fs val)))]
|
||||
[(vector f cm)
|
||||
(resume (list* (vector f #f) (vector #f cm) fs) val)])]))
|
||||
|
||||
;; rebuild-cms : frames (-> value) -> value
|
||||
(define (rebuild-cms frames thunk)
|
||||
#;(printf "~S~n" `(rebuild-cms ,frames ,thunk))
|
||||
(match frames
|
||||
[(list)
|
||||
(thunk)]
|
||||
[(list-rest f fs)
|
||||
(match f
|
||||
[(vector f #f)
|
||||
(rebuild-cms fs thunk)]
|
||||
[(vector f (list-rest cm-key cm-val))
|
||||
(with-continuation-mark cm-key cm-val (rebuild-cms fs thunk))])]))
|
||||
|
||||
(define-syntax (abort/cc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr)
|
||||
#'((let/cc abort-k
|
||||
(set-box! current-abort-continuation abort-k)
|
||||
(lambda () expr)))]))
|
||||
|
||||
(lambda () expr)))]))
|
||||
|
||||
;; a serializable undefined value
|
||||
(define-serializable-struct undef ())
|
||||
(define the-undef (make-undef))
|
||||
|
||||
|
||||
(define the-undef (make-undef))
|
||||
|
||||
;; **********************************************************************
|
||||
;; **********************************************************************
|
||||
;; "SERVLET" INTERFACE
|
||||
|
||||
;; "SERVLET" INTERFACE
|
||||
(define decode-continuation
|
||||
(lambda (k-val)
|
||||
(error "interactive module not initialized")))
|
||||
(error "interactive module not initialized: decode")))
|
||||
|
||||
(define (start-continuation val)
|
||||
(error "interactive module not initialized"))
|
||||
|
||||
(error "interactive module not initialized: start"))
|
||||
|
||||
;; start-interaction: (request -> continuation) -> request
|
||||
;; register the decode proc and start the interaction with the current-continuation
|
||||
(define (start-interaction decode)
|
||||
(set! decode-continuation decode)
|
||||
((lambda (k0) (abort (lambda () (set! start-continuation k0))))
|
||||
((lambda (k0)
|
||||
(abort (lambda () (set! start-continuation k0))))
|
||||
(let ([current-marks
|
||||
(reverse
|
||||
(continuation-mark-set->list (current-continuation-marks) the-cont-key))])
|
||||
(lambda (x) (abort (lambda () (resume current-marks x)))))))
|
||||
|
||||
(define-closure kont (x) (current-marks)
|
||||
(abort (lambda () (resume current-marks x))))
|
||||
(continuation-mark-set->list* (current-continuation-marks) (list the-cont-key the-save-cm-key)))])
|
||||
(lambda x (abort (lambda () (resume current-marks x)))))))
|
||||
|
||||
(define-closure kont x (wcs current-marks)
|
||||
(abort (lambda ()
|
||||
; Restoring the web-cells is separate from the continuation
|
||||
(restore-web-cell-set! wcs)
|
||||
(resume current-marks x))))
|
||||
|
||||
;; send/suspend: (continuation -> response) -> request
|
||||
;; produce the current response and wait for the next request
|
||||
(define (send/suspend response-maker)
|
||||
(with-continuation-mark safe-call? #t
|
||||
((lambda (k) (abort (lambda () (response-maker k))))
|
||||
(let ([current-marks (activation-record-list)])
|
||||
(make-kont (lambda () current-marks))))))
|
||||
|
||||
|
||||
(with-continuation-mark safe-call? '(#t send/suspend)
|
||||
(let ([current-marks (activation-record-list)]
|
||||
[wcs (capture-web-cell-set)])
|
||||
((lambda (k)
|
||||
(abort (lambda ()
|
||||
; Since we escaped from the previous context, we need to re-install the user's continuation-marks
|
||||
(rebuild-cms current-marks (lambda () (response-maker k))))))
|
||||
(make-kont (lambda () (values wcs current-marks)))))))
|
||||
|
||||
;; **********************************************************************
|
||||
;; **********************************************************************
|
||||
|
|
@ -119,11 +157,10 @@
|
|||
|
||||
;; dispatch: request -> response
|
||||
;; lookup the continuation for this request and invoke it
|
||||
(define (dispatch req)
|
||||
(define (dispatch req)
|
||||
(abort/cc
|
||||
(cond
|
||||
[(decode-continuation req)
|
||||
=> (lambda (k) (k req))]
|
||||
[else
|
||||
(error "no continuation associated with the provided request")])))
|
||||
)
|
||||
(error "no continuation associated with the provided request")]))))
|
||||
|
|
@ -2,23 +2,29 @@
|
|||
(require-for-template mzscheme
|
||||
(lib "serialize.ss")
|
||||
(lib "etc.ss"))
|
||||
(provide make-closure-definition-syntax)
|
||||
(require (lib "list.ss")
|
||||
(lib "serialize.ss"))
|
||||
(provide make-closure-definition-syntax
|
||||
closure->deserialize-name)
|
||||
|
||||
(define myprint printf)
|
||||
|
||||
|
||||
(define (closure->deserialize-name proc)
|
||||
(cdr (first (second (serialize proc)))))
|
||||
|
||||
;; borrowed this from Matthew's code
|
||||
;; creates the deserialize-info identifier
|
||||
(define (make-deserialize-name id)
|
||||
(datum->syntax-object
|
||||
id
|
||||
(string->symbol
|
||||
(format "web-deserialize-info:~a" (syntax-e id)))
|
||||
id))
|
||||
(datum->syntax-object
|
||||
id
|
||||
(string->symbol
|
||||
(format "web-deserialize-info:~a" (syntax-e id)))
|
||||
id))
|
||||
|
||||
(define (make-closure-definition-syntax tag formals fvars proc-body)
|
||||
(define (make-closure-definition-syntax tag fvars proc)
|
||||
(let ([make-id (lambda (str)
|
||||
(datum->syntax-object
|
||||
tag (string->symbol (format str (syntax-object->datum tag)))))])
|
||||
(datum->syntax-object
|
||||
tag (string->symbol (format str (syntax-object->datum tag)))))])
|
||||
(let ([deserialize-info:CLOSURE (make-deserialize-name tag)])
|
||||
(with-syntax ([CLOSURE:serialize-info (make-id "~a:serialize-info")]
|
||||
[make-CLOSURE (make-id "make-~a")]
|
||||
|
|
@ -29,41 +35,48 @@
|
|||
[set-CLOSURE-env! (make-id "set-~a-env!")]
|
||||
[struct:CLOSURE (make-id "struct:~a")])
|
||||
(values
|
||||
#'make-CLOSURE
|
||||
(syntax/loc proc make-CLOSURE)
|
||||
(list
|
||||
#`(define #,deserialize-info:CLOSURE
|
||||
(quasisyntax/loc proc
|
||||
(define #,deserialize-info:CLOSURE
|
||||
(make-deserialize-info
|
||||
|
||||
;; make-proc: value ... -> CLOSURE
|
||||
#,(if (null? fvars)
|
||||
#'(lambda () (make-CLOSURE))
|
||||
#`(lambda #,fvars (make-CLOSURE (lambda () (values #,@fvars)))))
|
||||
(lambda args
|
||||
(apply #,(if (null? fvars)
|
||||
(syntax/loc proc (lambda () (make-CLOSURE)))
|
||||
(quasisyntax/loc proc (lambda #,fvars (make-CLOSURE (lambda () (values #,@fvars))))))
|
||||
args))
|
||||
|
||||
;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void))
|
||||
(lambda ()
|
||||
(let ([new-closure
|
||||
#,(if (null? fvars)
|
||||
#'(make-CLOSURE)
|
||||
#'(make-CLOSURE (lambda () (error "closure not initialized"))))])
|
||||
(syntax/loc proc (make-CLOSURE))
|
||||
(syntax/loc proc (make-CLOSURE (lambda () (error "closure not initialized")))))])
|
||||
(values
|
||||
new-closure
|
||||
#,(if (null? fvars)
|
||||
#'void
|
||||
#'(lambda (clsr)
|
||||
(set-CLOSURE-env! new-closure (CLOSURE-env clsr)))))))))
|
||||
(syntax/loc proc void)
|
||||
(syntax/loc proc
|
||||
(lambda (clsr)
|
||||
(set-CLOSURE-env! new-closure (CLOSURE-env clsr)))))))))))
|
||||
|
||||
#`(provide #,deserialize-info:CLOSURE)
|
||||
(quasisyntax/loc proc
|
||||
(provide #,deserialize-info:CLOSURE))
|
||||
|
||||
#`(define CLOSURE:serialize-info
|
||||
(quasisyntax/loc proc
|
||||
(define CLOSURE:serialize-info
|
||||
(make-serialize-info
|
||||
|
||||
;; to-vector: CLOSURE -> vector
|
||||
#,(if (null? fvars)
|
||||
#'(lambda (clsr) (vector))
|
||||
#'(lambda (clsr)
|
||||
(syntax/loc proc (lambda (clsr) (vector)))
|
||||
(syntax/loc proc
|
||||
(lambda (clsr)
|
||||
(call-with-values
|
||||
(lambda () ((CLOSURE-env clsr)))
|
||||
vector)))
|
||||
vector))))
|
||||
|
||||
;; The serializer id: --------------------
|
||||
;(syntax deserialize-info:CLOSURE)
|
||||
|
|
@ -80,11 +93,13 @@
|
|||
|
||||
;; Directory for last-ditch resolution --------------------
|
||||
(or (current-load-relative-directory) (current-directory))
|
||||
))
|
||||
)))
|
||||
|
||||
#`(define-values (struct:CLOSURE make-CLOSURE CLOSURE? #,@(if (null? fvars)
|
||||
#'()
|
||||
#'(CLOSURE-env set-CLOSURE-env!)))
|
||||
(quasisyntax/loc proc
|
||||
(define-values (struct:CLOSURE make-CLOSURE CLOSURE?
|
||||
#,@(if (null? fvars)
|
||||
(syntax/loc proc ())
|
||||
(syntax/loc proc (CLOSURE-env set-CLOSURE-env!))))
|
||||
(let-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!)
|
||||
(make-struct-type '#,tag ;; the tag goes here
|
||||
#f ; no super type
|
||||
|
|
@ -99,14 +114,17 @@
|
|||
|
||||
;; the struct apply proc:
|
||||
#,(if (null? fvars)
|
||||
#`(lambda (clsr #,@formals)
|
||||
#,proc-body)
|
||||
#`(lambda (clsr #,@formals)
|
||||
(quasisyntax/loc proc
|
||||
(lambda (clsr . args)
|
||||
(apply #,proc args)))
|
||||
(quasisyntax/loc proc
|
||||
(lambda (clsr . args)
|
||||
(let-values ([#,fvars ((CLOSURE-env clsr))])
|
||||
#,proc-body)))
|
||||
(apply #,proc args)))))
|
||||
)])
|
||||
(values struct:CLOSURE make-CLOSURE CLOSURE?
|
||||
#,@(if (null? fvars)
|
||||
#'()
|
||||
#'((lambda (clsr) (CLOSURE-ref clsr 0))
|
||||
(lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env))))))))))))))
|
||||
(syntax/loc proc ())
|
||||
(syntax/loc proc
|
||||
((lambda (clsr) (CLOSURE-ref clsr 0))
|
||||
(lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env))))))))))))))))
|
||||
|
|
@ -5,11 +5,10 @@
|
|||
|
||||
(define-syntax (define-closure stx)
|
||||
(syntax-case stx ()
|
||||
[(_ tag (formals ...) (free-vars ...) body)
|
||||
[(_ tag formals (free-vars ...) body)
|
||||
(let-values ([(make-CLOSURE closure-definitions)
|
||||
(make-closure-definition-syntax
|
||||
#'tag
|
||||
(syntax->list #'(formals ...))
|
||||
(syntax->list #'(free-vars ...))
|
||||
#'body)])
|
||||
#`(lambda formals body))])
|
||||
#`(begin #,@closure-definitions))])))
|
||||
|
|
@ -43,7 +43,7 @@
|
|||
;; defunctionalize: expr (-> symbol) -> (values expr (listof definition))
|
||||
;; remove lambdas from an expression
|
||||
(define (defunctionalize expr labeling)
|
||||
(syntax-case expr (if #%app lambda let-values #%top #%datum with-continuation mark quote)
|
||||
(syntax-case expr (if #%app lambda let-values #%top #%datum with-continuation-mark quote)
|
||||
[(if test-expr csq-expr)
|
||||
(with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
|
||||
(let-values ([(new-test-expr test-defs) (defunctionalize #'test-expr labeling)]
|
||||
|
|
@ -66,7 +66,6 @@
|
|||
defs)))]
|
||||
[(let-values ([(f) rhs])
|
||||
(#%app f-apply (with-continuation-mark ignore-key f-mark body-expr)))
|
||||
;; (and (bound-identifier=? #'f #'f-apply) (bound-identifier=? #'f #'f-mark))
|
||||
(with-syntax ([(rhs f-apply ignore-key f-mark body-expr)
|
||||
(recertify* (syntax->list #'(rhs f-apply ignore-key f-mark body-expr)) expr)])
|
||||
(let-values ([(new-rhs rhs-defs) (defunctionalize #'rhs labeling)]
|
||||
|
|
@ -89,7 +88,8 @@
|
|||
(let ([fvars (free-vars expr)]
|
||||
[tag (labeling)])
|
||||
(let-values ([(make-CLOSURE closure-definitions)
|
||||
(make-closure-definition-syntax tag (syntax->list #'(formals ...)) fvars new-body-expr)])
|
||||
(make-closure-definition-syntax tag fvars
|
||||
#`(lambda (formals ...) #,new-body-expr))])
|
||||
(values
|
||||
(if (null? fvars)
|
||||
#`(#,make-CLOSURE)
|
||||
|
|
|
|||
|
|
@ -113,10 +113,4 @@
|
|||
#`(lambda (formals ...)
|
||||
(with-continuation-mark safe-call? #t
|
||||
body))]
|
||||
[_else w]))
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
[_else w])))
|
||||
|
|
@ -34,7 +34,7 @@
|
|||
;; definition ::= (define-values (var ...) expr)
|
||||
;;
|
||||
;; expr ::= var
|
||||
;; | (lambda (var ...) expr)
|
||||
;; | (lambda (var ...) expr ...)
|
||||
;; | (if expr expr)
|
||||
;; | (if expr expr expr)
|
||||
;; | (let-values ([(var ...)] expr) expr)
|
||||
|
|
@ -78,12 +78,16 @@
|
|||
(#%app set-box! vars new-rhss) ...
|
||||
new-body)))))]
|
||||
[(letrec-values . anything)
|
||||
(raise-syntax-error #f "Not all letrec-values-expressions supported" expr)]
|
||||
[(lambda (formals ...) body)
|
||||
(with-syntax ([body (recertify #'body expr)])
|
||||
#`(lambda (formals ...) #,(elim-letrec/ids #'body ids)))]
|
||||
(raise-syntax-error #f "elim-letrec: Not all letrec-values-expressions supported" expr)]
|
||||
[(lambda (formals ...) body-expr ...)
|
||||
(with-syntax ([(body-expr ...) (recertify* (syntax->list #'(body-expr ...)) expr)])
|
||||
#`(lambda (formals ...)
|
||||
#,@(map
|
||||
(lambda (an-expr)
|
||||
(elim-letrec/ids an-expr ids))
|
||||
(syntax->list #'(body-expr ...)))))]
|
||||
[(lambda . anything)
|
||||
(raise-syntax-error #f "Not all lambda-expressions supported" expr)]
|
||||
(raise-syntax-error #f "elim-letrec: Not all lambda-expressions supported" expr)]
|
||||
[(if tst-expr csq-expr)
|
||||
(with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
|
||||
#`(if #,(elim-letrec/ids #'tst-expr ids)
|
||||
|
|
@ -129,7 +133,7 @@
|
|||
#'(#%app unbox id)
|
||||
#'id)]
|
||||
[_else
|
||||
(raise-syntax-error #f "eliminate-letrec: unsupported form" expr)]))
|
||||
(raise-syntax-error #f "elim-letrec: unsupported form" expr)]))
|
||||
|
||||
(define myprint printf)
|
||||
|
||||
|
|
|
|||
|
|
@ -85,6 +85,4 @@
|
|||
[(_ rev-defs [])
|
||||
(raise-syntax-error #f "module has no body expression" stx)]
|
||||
[_else
|
||||
(raise-syntax-error #f "extra body expression, or expression out of order" stx)]))
|
||||
|
||||
)
|
||||
(raise-syntax-error #f "extra body expression, or expression out of order" stx)])))
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
(module hardcoded-configuration mzscheme
|
||||
(require (lib "configuration-structures.ss" "web-server")
|
||||
(lib "util.ss" "web-server")
|
||||
(require (lib "configuration-structures.ss" "web-server" "private")
|
||||
(lib "util.ss" "web-server" "private")
|
||||
(lib "response.ss" "web-server"))
|
||||
|
||||
(provide config:port
|
||||
|
|
@ -8,7 +8,7 @@
|
|||
config:listen-ip
|
||||
config:initial-connection-timeout
|
||||
config:virtual-hosts
|
||||
)
|
||||
hardcoded-host)
|
||||
|
||||
;; ************************************************************
|
||||
;; HARDCODED CONFIGURATION STUFF
|
||||
|
|
@ -37,7 +37,7 @@
|
|||
(lambda (in) (read-string (file-size path) in))))
|
||||
|
||||
;; error files:
|
||||
(define server-root-path (build-path "~" "plt-exp" "collects" "web-server" "default-web-root"))
|
||||
(define server-root-path (build-path "~" "Development" "plt" "default-web-root"))
|
||||
(define default-host-path (build-path server-root-path "conf"))
|
||||
|
||||
(define servlet-error-file (build-path default-host-path "servlet-error.html"))
|
||||
|
|
@ -46,102 +46,109 @@
|
|||
(define password-refresh-file (build-path default-host-path "passwords-refresh.html"))
|
||||
(define file-not-found-file (build-path default-host-path "not-found.html"))
|
||||
(define protocol-file (build-path default-host-path "protocol-error.html"))
|
||||
(define collect-garbage-file (build-path default-host-path "collect-garbage.html"))
|
||||
|
||||
(define hardcoded-host
|
||||
; host = (make-host (listof str) (str str sym url str -> str)
|
||||
; passwords resopnders timeouts paths)
|
||||
(make-host
|
||||
|
||||
;; indices
|
||||
(list "index.html" "index.htm")
|
||||
|
||||
;; log-format
|
||||
'none
|
||||
|
||||
;; log-message
|
||||
"log"
|
||||
|
||||
;; passwords
|
||||
"passwords"
|
||||
|
||||
(make-responders
|
||||
|
||||
;; servlet: url tst -> response
|
||||
(lambda (url exn)
|
||||
; more here - use separate log file
|
||||
;(printf "Servlet exception:\n~s\n" (exn-message exn))
|
||||
((error-display-handler)
|
||||
(format "Servlet exception:\n~a\n" (exn-message exn))
|
||||
exn)
|
||||
(error-response 500 "Servlet error" servlet-error-file))
|
||||
|
||||
;; servlet-loading: url tst -> response
|
||||
; more here - parameterize error based on a configurable file, perhaps?
|
||||
; This is slightly tricky since the (interesting) content comes from the exception.
|
||||
(lambda (url exn)
|
||||
((error-display-handler)
|
||||
(format "Servlet loading exception:\n~a\n" (exn-message exn))
|
||||
exn)
|
||||
(make-response/full 500 "Servlet didn't load"
|
||||
(current-seconds)
|
||||
#"text/plain" ;TEXT/HTML-MIME-TYPE
|
||||
'() ; check
|
||||
(list "Servlet didn't load.\n"
|
||||
(exn->string exn))))
|
||||
|
||||
;; authentication: url (cons sym str) -> response
|
||||
(lambda (uri recommended-header)
|
||||
(error-response 401 "Authorization Required" access-denied-file
|
||||
recommended-header))
|
||||
|
||||
;; servlets-refreshed: -> response
|
||||
(lambda ()
|
||||
(error-response 200 "Servlet cache refreshed" servlet-refresh-file))
|
||||
|
||||
;; passwords-refreshed: -> response
|
||||
(lambda ()
|
||||
(error-response 200 "Passwords refreshed" password-refresh-file))
|
||||
|
||||
;; file-not-found: url->response
|
||||
(lambda (url)
|
||||
(error-response 404 "File not found" file-not-found-file))
|
||||
|
||||
;; protocol: string -> response
|
||||
(lambda (error-message)
|
||||
(error-response 400 "Malformed Request" protocol-file))
|
||||
|
||||
;; collect-garbage: -> response
|
||||
(lambda ()
|
||||
(error-response 200 "Collected Garbage" collect-garbage-file))
|
||||
|
||||
)
|
||||
|
||||
; timeouts = (make-timeouts nat^5)
|
||||
(make-timeouts
|
||||
; default-servlet-timeout
|
||||
60
|
||||
;password-connection-timeout
|
||||
300
|
||||
; servlet-connection-timeout
|
||||
86400
|
||||
; file-per-byte-connection-timeout
|
||||
1/20
|
||||
; file-base-connection-timeout
|
||||
30)
|
||||
|
||||
; paths = (make-paths str^6)
|
||||
(make-paths
|
||||
; configuration-root
|
||||
(build-path server-root-path "conf")
|
||||
; host-root
|
||||
(build-path server-root-path "default-web-root")
|
||||
; log-file-path
|
||||
"log"
|
||||
; file-root
|
||||
(build-path server-root-path "htdocs")
|
||||
; servlet-root
|
||||
(build-path "~" "Development" "Projects" "exp" "prototype-web-server")
|
||||
; mime-types
|
||||
(build-path server-root-path "mime.types")
|
||||
; password-authentication
|
||||
(build-path server-root-path "passwords"))))
|
||||
|
||||
;; config:virtual-hosts: alpha -> host
|
||||
;; return a default host structure
|
||||
(define config:virtual-hosts
|
||||
(let ([hardcoded-host
|
||||
; host = (make-host (listof str) (str str sym url str -> str)
|
||||
; passwords resopnders timeouts paths)
|
||||
(make-host
|
||||
|
||||
;; indices
|
||||
(list "index.html" "index.htm")
|
||||
|
||||
;; log-message
|
||||
(lambda (str0 str1 sym0 url0 str2)
|
||||
(error "log-message not implemented"))
|
||||
|
||||
;; passwords
|
||||
'()
|
||||
|
||||
(make-responders
|
||||
|
||||
;; servlet: url tst -> response
|
||||
(lambda (url exn)
|
||||
; more here - use separate log file
|
||||
;(printf "Servlet exception:\n~s\n" (exn-message exn))
|
||||
((error-display-handler)
|
||||
(format "Servlet exception:\n~a\n" (exn-message exn))
|
||||
exn)
|
||||
(error-response 500 "Servlet error" servlet-error-file))
|
||||
|
||||
;; servlet-loading: url tst -> response
|
||||
; more here - parameterize error based on a configurable file, perhaps?
|
||||
; This is slightly tricky since the (interesting) content comes from the exception.
|
||||
(lambda (url exn)
|
||||
((error-display-handler)
|
||||
(format "Servlet loading exception:\n~a\n" (exn-message exn))
|
||||
exn)
|
||||
(make-response/full 500 "Servlet didn't load"
|
||||
(current-seconds)
|
||||
#"text/plain" ;TEXT/HTML-MIME-TYPE
|
||||
'() ; check
|
||||
(list "Servlet didn't load.\n"
|
||||
(exn->string exn))))
|
||||
|
||||
;; authentication: url (cons sym str) -> response
|
||||
(lambda (uri recommended-header)
|
||||
(error-response 401 "Authorization Required" access-denied-file
|
||||
recommended-header))
|
||||
|
||||
;; servlets-refreshed: -> response
|
||||
(lambda ()
|
||||
(error-response 200 "Servlet cache refreshed" servlet-refresh-file))
|
||||
|
||||
;; passwords-refreshed: -> response
|
||||
(lambda ()
|
||||
(error-response 200 "Passwords refreshed" password-refresh-file))
|
||||
|
||||
;; file-not-found: url->response
|
||||
(lambda (url)
|
||||
(error-response 404 "File not found" file-not-found-file))
|
||||
|
||||
;; protocol: string -> response
|
||||
(lambda (error-message)
|
||||
(error-response 400 "Malformed Request" protocol-file))
|
||||
|
||||
)
|
||||
|
||||
; timeouts = (make-timeouts nat^5)
|
||||
(make-timeouts
|
||||
; default-servlet-timeout
|
||||
60
|
||||
;password-connection-timeout
|
||||
300
|
||||
; servlet-connection-timeout
|
||||
86400
|
||||
; file-per-byte-connection-timeout
|
||||
1/20
|
||||
; file-base-connection-timeout
|
||||
30)
|
||||
|
||||
; paths = (make-paths str^6)
|
||||
(make-paths
|
||||
; configuration-root
|
||||
(build-path server-root-path "conf")
|
||||
; host-root
|
||||
(build-path server-root-path "default-web-root")
|
||||
; log-file-path
|
||||
"log"
|
||||
; file-root
|
||||
(build-path server-root-path "htdocs")
|
||||
; servlet-root
|
||||
(build-path "~" "plt-exp" "collects" "prototype-web-server" "servlets")
|
||||
; password-authentication
|
||||
(build-path server-root-path "passwords"))
|
||||
)])
|
||||
|
||||
(lambda (ignore)
|
||||
hardcoded-host)))
|
||||
)
|
||||
(lambda (ignore)
|
||||
hardcoded-host)))
|
||||
|
|
@ -3,5 +3,4 @@
|
|||
(provide (all-from-except mzscheme #%module-begin)
|
||||
(rename lang-module-begin #%module-begin)
|
||||
start-interaction
|
||||
send/suspend)
|
||||
)
|
||||
send/suspend))
|
||||
|
|
@ -2,8 +2,7 @@
|
|||
(require "syntax-utils.ss")
|
||||
(require-for-template mzscheme)
|
||||
(provide normalize-term
|
||||
normalize-definition
|
||||
)
|
||||
normalize-definition)
|
||||
;; **************************************************
|
||||
;; SOURCE LANGUAGE
|
||||
;;
|
||||
|
|
@ -12,9 +11,11 @@
|
|||
;; definition ::= (define-values (var ...) expr)
|
||||
;;
|
||||
;; expr ::= var
|
||||
;; | (lambda (var ...) expr)
|
||||
;; | (lambda (var ...) expr ...)
|
||||
;; | (if expr expr)
|
||||
;; | (if expr expr expr)
|
||||
;; | (let-values () expr)
|
||||
;; | (let-values () expr ...)
|
||||
;; | (let-values ([(var)] expr) expr)
|
||||
;; | (let-values ([(var ...)] expr) expr)
|
||||
;; | (let-values ([(var ...)] expr) expr ...)
|
||||
|
|
@ -69,8 +70,10 @@
|
|||
[(lambda (formals ...) body)
|
||||
(with-syntax ([body (recertify #'body expr)])
|
||||
(ctxt #`(lambda (formals ...) #,(normalize-term #'body))))]
|
||||
[(lambda (formals ...) bodies ...)
|
||||
(normalize ctxt #'(lambda (formals ...) (begin bodies ...)))]
|
||||
[(lambda . anything)
|
||||
(raise-syntax-error #f "Not all lambda-expressions supported" expr)]
|
||||
(raise-syntax-error #f "normalize: Not all lambda-expressions supported" expr)]
|
||||
[(if tst-expr csq-expr)
|
||||
(with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
|
||||
(normalize
|
||||
|
|
@ -87,6 +90,12 @@
|
|||
#,(normalize-term #'csq-expr)
|
||||
#,(normalize-term #'alt-expr))))
|
||||
#'tst-expr))]
|
||||
[(let-values () body)
|
||||
(normalize ctxt (recertify #'body expr))]
|
||||
[(let-values () body-expr rest-body-exprs ...)
|
||||
(with-syntax ([(body-expr rest-body-exprs ...)
|
||||
(recertify* (syntax->list #'(body-expr rest-body-exprs ...)) expr)])
|
||||
(normalize ctxt #'(let-values ([(throw-away) body-expr]) rest-body-exprs ...)))]
|
||||
[(let-values ([(var) rhs-expr]) body)
|
||||
(with-syntax ([(rhs-expr body) (recertify* (list #'rhs-expr #'body) expr)])
|
||||
(normalize ctxt #'(#%app (lambda (var) body) rhs-expr)))]
|
||||
|
|
@ -156,6 +165,4 @@
|
|||
(if (eq? ctxt id) frame
|
||||
(lambda (val)
|
||||
(let-values ([(x ref-to-x) (generate-formal 'x)])
|
||||
#`(#%app (lambda (#,x) #,(ctxt ref-to-x)) #,(frame val))))))
|
||||
)
|
||||
|
||||
#`(#%app (lambda (#,x) #,(ctxt ref-to-x)) #,(frame val)))))))
|
||||
|
|
@ -109,7 +109,4 @@
|
|||
[(_ rev-defs [])
|
||||
(raise-syntax-error #f "module has no body expression" stx)]
|
||||
[_else
|
||||
(raise-syntax-error #f "extra body expression, or expression out of order" stx)]))
|
||||
|
||||
)
|
||||
|
||||
(raise-syntax-error #f "extra body expression, or expression out of order" stx)])))
|
||||
|
|
@ -3,5 +3,4 @@
|
|||
(provide (all-from-except mzscheme #%module-begin)
|
||||
(rename lang-module-begin #%module-begin)
|
||||
start-interaction
|
||||
send/suspend)
|
||||
)
|
||||
send/suspend))
|
||||
|
|
@ -3,21 +3,25 @@
|
|||
(all-except "persistent-expander.ss" send/suspend)
|
||||
"session.ss"
|
||||
"stuff-url.ss"
|
||||
(lib "servlet-helpers.ss" "web-server")
|
||||
(lib "servlet-helpers.ss" "web-server" "private")
|
||||
(lib "serialize.ss")
|
||||
(lib "url.ss" "net")
|
||||
)
|
||||
(lib "url.ss" "net"))
|
||||
|
||||
(provide (all-from-except mzscheme #%module-begin)
|
||||
(rename lang-module-begin #%module-begin)
|
||||
send/suspend/hidden
|
||||
send/suspend/url
|
||||
send/suspend/dispatch
|
||||
extract-proc/url embed-proc/url
|
||||
redirect/get
|
||||
start-servlet)
|
||||
|
||||
;; start-servlet: -> request
|
||||
;; set the initial interaction point for the servlet
|
||||
(define (start-servlet)
|
||||
(printf "start-session~n")
|
||||
(start-session dispatch)
|
||||
(printf "start-interaction~n")
|
||||
(start-interaction
|
||||
(lambda (req)
|
||||
(or (request->continuation req)
|
||||
|
|
@ -31,7 +35,7 @@
|
|||
(let ([p-cont (serialize k)])
|
||||
(page-maker
|
||||
(session-url (current-session))
|
||||
`(input ([type "hidden"][name "kont"][value ,(format "~s" p-cont)])))))))
|
||||
`(input ([type "hidden"] [name "kont"] [value ,(format "~s" p-cont)])))))))
|
||||
|
||||
;; send/suspend/url: (url -> response) -> request
|
||||
;; like send/suspend except the continuation is encoded in the url
|
||||
|
|
@ -44,10 +48,51 @@
|
|||
(session-url ses)
|
||||
(session-mod-path ses)))))))
|
||||
|
||||
(define embed-label 'superkont)
|
||||
(define (embed-proc/url k-url proc)
|
||||
(define ses (current-session))
|
||||
(define superkont-url
|
||||
(stuff-url (serialize proc)
|
||||
(session-url ses)
|
||||
(session-mod-path ses)))
|
||||
(define result-uri
|
||||
(extend-url-query k-url embed-label
|
||||
(url->string superkont-url)))
|
||||
(begin0 result-uri
|
||||
(when (> (string-length (url->string result-uri))
|
||||
1024)
|
||||
(error "the url is too big: " (url->string result-uri)))))
|
||||
(define (extract-proc/url request)
|
||||
(define req-url (request-uri request))
|
||||
(define binds (url-query req-url))
|
||||
(if (exists-binding? embed-label binds)
|
||||
(let* ([ses (current-session)]
|
||||
[superkont-url (string->url (extract-binding/single embed-label binds))]
|
||||
[proc (deserialize
|
||||
(unstuff-url
|
||||
superkont-url (session-url ses)
|
||||
(session-mod-path ses)))])
|
||||
(proc request))
|
||||
(error 'send/suspend/dispatch "No ~a: ~S!" embed-label binds)))
|
||||
|
||||
(define-syntax send/suspend/dispatch
|
||||
(syntax-rules ()
|
||||
[(_ response-generator)
|
||||
(extract-proc/url
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
(response-generator
|
||||
(lambda (proc)
|
||||
(embed-proc/url k-url proc))))))]))
|
||||
|
||||
(define (redirect/get)
|
||||
(send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily))))
|
||||
|
||||
;; request->continuation: req -> continuation
|
||||
;; decode the continuation from the hidden field of a request
|
||||
(define (request->continuation req)
|
||||
(or
|
||||
; Look in url for c=<k>
|
||||
(let* ([ses (current-session)]
|
||||
[req-url (request-uri req)]
|
||||
[qry (url-query req-url)]
|
||||
|
|
@ -57,10 +102,10 @@
|
|||
(unstuff-url
|
||||
req-url (session-url ses)
|
||||
(session-mod-path ses)))))
|
||||
; Look in query for kont=<k>
|
||||
(let ([bdgs (request-bindings req)])
|
||||
(and (exists-binding? 'kont bdgs)
|
||||
(deserialize
|
||||
(read
|
||||
(open-input-string
|
||||
(extract-binding/single 'kont bdgs))))))))
|
||||
)
|
||||
(extract-binding/single 'kont bdgs)))))))))
|
||||
33
collects/web-server/prototype-web-server/run.ss
Normal file
33
collects/web-server/prototype-web-server/run.ss
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
(module run mzscheme
|
||||
(require (lib "unit.ss")
|
||||
(lib "tcp-sig.ss" "net"))
|
||||
(require (lib "dispatch-server-sig.ss" "web-server" "private")
|
||||
(lib "dispatch-server-unit.ss" "web-server" "private")
|
||||
(lib "request.ss" "web-server" "private")
|
||||
(lib "configuration-structures.ss" "web-server" "private")
|
||||
(prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers"))
|
||||
(prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers")))
|
||||
(require "hardcoded-configuration.ss"
|
||||
(prefix prototype: "server.ss"))
|
||||
|
||||
(define port 8080)
|
||||
(define listen-ip #f)
|
||||
(define max-waiting 40)
|
||||
(define initial-connection-timeout 60)
|
||||
(define host-info hardcoded-host)
|
||||
(define dispatch
|
||||
(sequencer:make
|
||||
(lambda (conn req)
|
||||
(prototype:dispatch conn req host-info))
|
||||
(files:make #:htdocs-path (paths-htdocs (host-paths host-info))
|
||||
#:mime-types-path (paths-mime-types (host-paths host-info))
|
||||
#:indices (host-indices host-info)
|
||||
#:file-not-found-responder (responders-file-not-found (host-responders host-info)))))
|
||||
|
||||
(define-values/invoke-unit
|
||||
dispatch-server@
|
||||
(import tcp^ dispatch-server-config^)
|
||||
(export dispatch-server^))
|
||||
|
||||
(define shutdown (serve))
|
||||
(semaphore-wait (make-semaphore 0)))
|
||||
|
|
@ -1,27 +1,35 @@
|
|||
(module server mzscheme
|
||||
(require (lib "connection-manager.ss" "web-server")
|
||||
(lib "request-parsing.ss" "web-server")
|
||||
(lib "response.ss" "web-server")
|
||||
;(lib "util.ss" "web-server")
|
||||
(require (lib "connection-manager.ss" "web-server" "private")
|
||||
(lib "request.ss" "web-server" "private")
|
||||
(lib "response.ss" "web-server")
|
||||
(lib "servlet-helpers.ss" "web-server" "private")
|
||||
(lib "response.ss" "web-server" "private")
|
||||
(lib "util.ss" "web-server" "private")
|
||||
(lib "url.ss" "net")
|
||||
(lib "string.ss")
|
||||
(lib "list.ss")
|
||||
|
||||
(lib "configuration-structures.ss" "web-server")
|
||||
|
||||
(lib "plt-match.ss")
|
||||
(lib "configuration-structures.ss" "web-server" "private")
|
||||
(lib "dispatch.ss" "web-server" "dispatchers")
|
||||
(lib "session.ss" "prototype-web-server")
|
||||
(only (lib "abort-resume.ss" "prototype-web-server")
|
||||
abort/cc
|
||||
safe-call?
|
||||
the-cont-key)
|
||||
(only (lib "persistent-web-interaction.ss" "prototype-web-server")
|
||||
start-servlet)
|
||||
(lib "web-cells.ss" "newcont")
|
||||
"xexpr-extras.ss"
|
||||
"utils.ss"
|
||||
"hardcoded-configuration.ss"
|
||||
"session.ss"
|
||||
)
|
||||
|
||||
(provide serve)
|
||||
|
||||
(define myprint printf)
|
||||
|
||||
"hardcoded-configuration.ss")
|
||||
|
||||
(provide serve dispatch)
|
||||
|
||||
(define myprint printf #;(lambda _ (void)))
|
||||
|
||||
(define thread-connection-state (make-thread-cell #f))
|
||||
(define-struct connection-state (conn req))
|
||||
(define top-cust (current-custodian))
|
||||
|
||||
|
||||
;; ************************************************************
|
||||
;; serve: -> -> void
|
||||
;; start the server and return a thunk to shut it down
|
||||
|
|
@ -41,7 +49,7 @@
|
|||
(server-loop get-ports)))))
|
||||
(lambda ()
|
||||
(custodian-shutdown-all the-server-custodian))))
|
||||
|
||||
|
||||
;; ************************************************************
|
||||
;; server-loop: (-> i-port o-port) -> void
|
||||
;; start a thread to handle each incoming connection
|
||||
|
|
@ -56,7 +64,7 @@
|
|||
(new-connection config:initial-connection-timeout
|
||||
ip op (current-custodian) #f)))))))
|
||||
(loop)))
|
||||
|
||||
|
||||
;; ************************************************************
|
||||
;; serve-connection: connection -> void
|
||||
;; respond to all requests on this connection
|
||||
|
|
@ -79,39 +87,26 @@
|
|||
(cond
|
||||
[close? (kill-connection! conn)]
|
||||
[else (connection-loop)])))))
|
||||
|
||||
;; get-host : Url (listof (cons Symbol String)) -> String
|
||||
;; host names are case insesitive---Internet RFC 1034
|
||||
(define DEFAULT-HOST-NAME "<none>")
|
||||
(define (get-host uri headers)
|
||||
(let ([lower!
|
||||
(lambda (s)
|
||||
(string-lowercase! s #;(bytes->string/utf-8 s))
|
||||
s)])
|
||||
(cond
|
||||
[(url-host uri) => lower!]
|
||||
[(assq 'host headers)
|
||||
=>
|
||||
(lambda (h) (lower! (bytes->string/utf-8 (cdr h))))]
|
||||
[else DEFAULT-HOST-NAME])))
|
||||
|
||||
|
||||
;; ************************************************************
|
||||
;; dispatch: connection request host -> void
|
||||
;; trivial dispatcher
|
||||
(define (dispatch conn req host-info)
|
||||
(define-values (uri method path) (decompose-request req))
|
||||
(myprint "dispatch~n")
|
||||
|
||||
(adjust-connection-timeout!
|
||||
conn
|
||||
(timeouts-servlet-connection (host-timeouts host-info)))
|
||||
;; more here - make timeouts proportional to size of bindings
|
||||
(servlet-content-producer conn req host-info))
|
||||
|
||||
|
||||
(if (regexp-match #rx"^/servlets" path)
|
||||
(begin
|
||||
(adjust-connection-timeout!
|
||||
conn
|
||||
(timeouts-servlet-connection (host-timeouts host-info)))
|
||||
;; more here - make timeouts proportional to size of bindings
|
||||
(servlet-content-producer conn req host-info))
|
||||
(next-dispatcher)))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING SERVLETS
|
||||
|
||||
|
||||
;; servlet-content-producer: connection request host -> void
|
||||
(define (servlet-content-producer conn req host-info)
|
||||
(myprint "servlet-content-producer~n")
|
||||
|
|
@ -124,10 +119,6 @@
|
|||
'() (list "ignored"))
|
||||
meth)
|
||||
(let ([uri (request-uri req)])
|
||||
(set-request-bindings!
|
||||
req
|
||||
(read-bindings/handled conn meth uri (request-headers req)
|
||||
host-info))
|
||||
(thread-cell-set! thread-connection-state
|
||||
(make-connection-state conn req))
|
||||
(with-handlers ([void
|
||||
|
|
@ -145,64 +136,43 @@
|
|||
(resume-session session-id host-info))]
|
||||
[else
|
||||
(begin-session host-info)]))))))
|
||||
|
||||
;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
|
||||
;; read the bindings and handle any exceptions
|
||||
(define (read-bindings/handled conn meth uri headers host-info)
|
||||
(with-handlers ([exn? (lambda (e)
|
||||
(output-response/method
|
||||
conn
|
||||
;((responders-protocol (host-responders host-info))
|
||||
; (exn-message e))
|
||||
((responders-servlet-loading (host-responders
|
||||
host-info))
|
||||
uri e)
|
||||
|
||||
|
||||
meth)
|
||||
'())])
|
||||
(read-bindings conn meth uri headers)))
|
||||
|
||||
|
||||
;; Parameter Parsing
|
||||
|
||||
;; old style: ;id15*0
|
||||
;(define URL-PARAMS:REGEXP (regexp "([^\\*]*)\\*(.*)"))
|
||||
|
||||
|
||||
;; encodes a simple number:
|
||||
(define URL-PARAMS:REGEXP (regexp "[0-9]*"))
|
||||
|
||||
|
||||
(define URL-PARAMS:REGEXP (regexp "([0-9]+)"))
|
||||
|
||||
(define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
|
||||
|
||||
|
||||
;; resume-session? url -> (union number #f)
|
||||
;; Determine if the url encodes a session-id and extract it
|
||||
(define (resume-session? a-url)
|
||||
(myprint "resume-session?: url-string = ~s~n" (url->string a-url))
|
||||
(let ([str (url->param a-url)])
|
||||
(and str
|
||||
(let ([param-match (match-url-params str)])
|
||||
(and (not (null? param-match))
|
||||
(string->number (car param-match)))))))
|
||||
|
||||
(let ([k-params (filter match-url-params
|
||||
(apply append
|
||||
(map path/param-param (url-path a-url))))])
|
||||
(myprint "resume-session?: ~S~n" k-params)
|
||||
(if (empty? k-params)
|
||||
#f
|
||||
(match (match-url-params (first k-params))
|
||||
[(list _ n)
|
||||
(myprint "resume-session?: Found ~a~n" n)
|
||||
(string->number n)]
|
||||
[_
|
||||
#f]))))
|
||||
|
||||
;; url->param: url -> (union string #f)
|
||||
(define (url->param a-url)
|
||||
(let ([l (filter path/param? (url-path a-url))])
|
||||
(and (not (null? l))
|
||||
(path/param-param (car l)))))
|
||||
|
||||
|
||||
;(resume-session? (string->url "http://localhost:9000/;123"))
|
||||
;(resume-session? (string->url "http://localhost:9000/;foo"))
|
||||
;(resume-session? (string->url "http://localhost:9000/foo/bar"))
|
||||
|
||||
|
||||
|
||||
;; ************************************************************
|
||||
|
||||
;; directory-part: path -> path
|
||||
(define (directory-part a-path)
|
||||
(let-values ([(base name must-be-dir?) (split-path a-path)])
|
||||
base))
|
||||
|
||||
;; begin-session: connection request host-info
|
||||
(define (begin-session host-info)
|
||||
(myprint "begin-session~n")
|
||||
|
|
@ -221,18 +191,30 @@
|
|||
[current-namespace ns]
|
||||
[current-session ses])
|
||||
(let* ([module-name `(file ,(path->string a-path))])
|
||||
(dynamic-require module-name #f)))
|
||||
(myprint "dynamic-require ...~n")
|
||||
(with-handlers ([exn:fail:contract?
|
||||
(lambda _
|
||||
(dynamic-require module-name #f))])
|
||||
(let ([start (dynamic-require module-name 'start)])
|
||||
(abort/cc
|
||||
(with-continuation-mark safe-call? '(#t start)
|
||||
(start
|
||||
(with-continuation-mark the-cont-key start
|
||||
(start-servlet)))))))))
|
||||
(myprint "resume-session~n")
|
||||
(resume-session (session-id ses) host-info)))
|
||||
(output-response/method
|
||||
(connection-state-conn (thread-cell-ref thread-connection-state))
|
||||
((responders-file-not-found (host-responders host-info)) uri)
|
||||
(request-method (connection-state-req (thread-cell-ref thread-connection-state))))))))
|
||||
|
||||
|
||||
(define to-be-copied-module-specs
|
||||
'(mzscheme
|
||||
(lib "web-cells.ss" "newcont")
|
||||
(lib "abort-resume.ss" "prototype-web-server")
|
||||
(lib "session.ss" "prototype-web-server")
|
||||
(lib "request-parsing.ss" "web-server")))
|
||||
|
||||
(lib "request.ss" "web-server" "private")))
|
||||
|
||||
;; get the names of those modules.
|
||||
(define to-be-copied-module-names
|
||||
(let ([get-name
|
||||
|
|
@ -241,7 +223,7 @@
|
|||
spec
|
||||
((current-module-name-resolver) spec #f #f)))])
|
||||
(map get-name to-be-copied-module-specs)))
|
||||
|
||||
|
||||
(define (make-servlet-namespace)
|
||||
(let ([server-namespace (current-namespace)]
|
||||
[new-namespace (make-namespace)])
|
||||
|
|
@ -249,27 +231,11 @@
|
|||
(for-each (lambda (name) (namespace-attach-module server-namespace name))
|
||||
to-be-copied-module-names)
|
||||
new-namespace)))
|
||||
|
||||
;; ripped this off from url-unit.ss
|
||||
(define (url-path->string strs)
|
||||
(apply
|
||||
string-append
|
||||
(let loop ([strs strs])
|
||||
(cond
|
||||
[(null? strs) '()]
|
||||
[else (list* "/"
|
||||
(maybe-join-params (car strs))
|
||||
(loop (cdr strs)))]))))
|
||||
|
||||
;; needs to unquote things!
|
||||
(define (maybe-join-params s)
|
||||
(cond
|
||||
[(string? s) s]
|
||||
[else (path/param-path s)]))
|
||||
|
||||
|
||||
;; ************************************************************
|
||||
;; resume-session: connection request number host-info
|
||||
(define (resume-session ses-id host-info)
|
||||
; XXX Check if session is for same servlet!
|
||||
(myprint "resume-session: ses-id = ~s~n" ses-id)
|
||||
(cond
|
||||
[(lookup-session ses-id)
|
||||
|
|
@ -287,17 +253,13 @@
|
|||
the-exn)
|
||||
(request-method
|
||||
(connection-state-req (thread-cell-ref thread-connection-state)))))])
|
||||
(printf "session-handler ~S~n" (session-handler ses))
|
||||
(output-response
|
||||
(connection-state-conn (thread-cell-ref thread-connection-state))
|
||||
((session-handler ses)
|
||||
(connection-state-req (thread-cell-ref thread-connection-state)))))))]
|
||||
(xexpr+extras->xexpr
|
||||
((session-handler ses)
|
||||
(connection-state-req (thread-cell-ref thread-connection-state))))))))]
|
||||
[else
|
||||
(myprint "resume-session: Unknown ses~n")
|
||||
;; TODO: should just start a new session here.
|
||||
(output-response/method
|
||||
(connection-state-conn (thread-cell-ref thread-connection-state))
|
||||
((responders-file-not-found (host-responders host-info))
|
||||
(request-uri (connection-state-req (thread-cell-ref thread-connection-state))))
|
||||
(request-method
|
||||
(connection-state-req (thread-cell-ref thread-connection-state))))]))
|
||||
|
||||
)
|
||||
(begin-session host-info)])))
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
(module add01 mzscheme
|
||||
(require (lib "session.ss" "prototype-web-server")
|
||||
(lib "request-parsing.ss" "web-server")
|
||||
(lib "url.ss" "net")
|
||||
)
|
||||
(lib "request.ss" "web-server" "private")
|
||||
(lib "request-structs.ss" "web-server")
|
||||
(lib "url.ss" "net"))
|
||||
|
||||
(define (dispatch req)
|
||||
(let* ([uri (request-uri req)]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
(module add02 "../web-interaction.ss"
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "request-parsing.ss" "web-server"))
|
||||
(lib "request.ss" "web-server" "private")
|
||||
(lib "request-structs.ss" "web-server"))
|
||||
|
||||
;; get-number-from-user: string -> number
|
||||
;; ask the user for a number
|
||||
|
|
@ -24,6 +25,4 @@
|
|||
(body
|
||||
(h1 "Final Page")
|
||||
(p ,(format "The answer is ~a"
|
||||
(+ (gn "first") (gn "second")))))))
|
||||
|
||||
)
|
||||
(+ (gn "first") (gn "second"))))))))
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
(module add03 "../persistent-web-interaction.ss"
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "servlet-helpers.ss" "web-server"))
|
||||
(lib "servlet-helpers.ss" "web-server" "private")
|
||||
(lib "request-structs.ss" "web-server"))
|
||||
|
||||
;; get-number-from-user: string -> number
|
||||
;; ask the user for a number
|
||||
|
|
@ -27,5 +28,4 @@
|
|||
(body
|
||||
(h1 "Final Page")
|
||||
(p ,(format "The answer is ~a"
|
||||
(+ (gn "first") (gn "second")))))))
|
||||
)
|
||||
(+ (gn "first") (gn "second"))))))))
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
(module add04 (lib "persistent-web-interaction.ss" "prototype-web-server")
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "servlet-helpers.ss" "web-server"))
|
||||
(lib "servlet-helpers.ss" "web-server" "private"))
|
||||
|
||||
;; get-number-from-user: string -> number
|
||||
;; ask the user for a number
|
||||
|
|
@ -26,5 +26,4 @@
|
|||
(body
|
||||
(h1 "Final Page")
|
||||
(p ,(format "The answer is ~a"
|
||||
(+ (gn "first") (gn "second")))))))
|
||||
)
|
||||
(+ (gn "first") (gn "second"))))))))
|
||||
49
collects/web-server/prototype-web-server/servlets/add05.ss
Normal file
49
collects/web-server/prototype-web-server/servlets/add05.ss
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
(module add05 (lib "persistent-web-interaction.ss" "prototype-web-server")
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "servlet-helpers.ss" "web-server" "private"))
|
||||
|
||||
;; get-number-from-user: string -> number
|
||||
;; ask the user for a number
|
||||
(define (gn msg)
|
||||
(extract-proc/url
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
`(hmtl (head (title ,(format "Get ~a number" msg)))
|
||||
(body
|
||||
(form ([action ,(url->string
|
||||
(embed-proc/url
|
||||
k-url
|
||||
(lambda (req)
|
||||
(string->number
|
||||
(extract-binding/single
|
||||
'number
|
||||
(request-bindings req))))))]
|
||||
[method "post"]
|
||||
[enctype "application/x-www-form-urlencoded"])
|
||||
,(format "Enter the ~a number to add: " msg)
|
||||
(input ([type "text"] [name "number"] [value ""]))
|
||||
(input ([type "submit"])))))))))
|
||||
|
||||
#;(define (gn msg)
|
||||
(send/suspend/dispatch
|
||||
(lambda (embed/url)
|
||||
`(hmtl (head (title ,(format "Get ~a number" msg)))
|
||||
(body
|
||||
(form ([action ,(url->string
|
||||
(embed/url
|
||||
(lambda (req)
|
||||
(string->number
|
||||
(extract-binding/single
|
||||
'number
|
||||
(request-bindings req))))))]
|
||||
[method "post"]
|
||||
[enctype "application/x-www-form-urlencoded"])
|
||||
,(format "Enter the ~a number to add: " msg)
|
||||
(input ([type "text"] [name "number"] [value ""]))
|
||||
(input ([type "submit"]))))))))
|
||||
|
||||
(let ([initial-request (start-servlet)])
|
||||
`(html (head (title "Final Page"))
|
||||
(body
|
||||
(h1 "Final Page")
|
||||
(p ,(format "The answer is ~a" (+ (gn "first") (gn "second"))))))))
|
||||
|
|
@ -1,7 +1,6 @@
|
|||
(module quiz-lib mzscheme
|
||||
(require (lib "serialize.ss")
|
||||
(lib "url.ss" "net")
|
||||
)
|
||||
(lib "url.ss" "net"))
|
||||
(provide (struct mc-question (cue answers correct-answer))
|
||||
make-cue-page
|
||||
quiz)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(module quiz01 (lib "persistent-web-interaction.ss" "prototype-web-server")
|
||||
(require "quiz-lib.ss"
|
||||
(lib "url.ss" "net")
|
||||
(lib "servlet-helpers.ss" "web-server"))
|
||||
(lib "servlet-helpers.ss" "web-server" "private"))
|
||||
|
||||
;; get-answer: mc-question -> number
|
||||
;; get an answer for a multiple choice question
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(module quiz02 (lib "persistent-web-interaction.ss" "prototype-web-server")
|
||||
(require "quiz-lib.ss"
|
||||
(lib "servlet-helpers.ss" "web-server"))
|
||||
(lib "servlet-helpers.ss" "web-server" "private"))
|
||||
|
||||
;; get-answer: mc-question -> number
|
||||
;; get an answer for a multiple choice question
|
||||
|
|
|
|||
37
collects/web-server/prototype-web-server/servlets/toobig.ss
Normal file
37
collects/web-server/prototype-web-server/servlets/toobig.ss
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
(module toobig (lib "persistent-web-interaction.ss" "prototype-web-server")
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "servlet-helpers.ss" "web-server" "private"))
|
||||
|
||||
(define (get-n)
|
||||
(let ([req
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
`(html (head (title "How many bytes?"))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "POST"]
|
||||
[enctype "application/x-www-form-urlencoded"])
|
||||
"How many bytes? (Try 1024)"
|
||||
(input ([type "text"] [name "number"] [value ""]))
|
||||
(input ([type "submit"])))))))])
|
||||
(string->number
|
||||
(extract-binding/single
|
||||
`number
|
||||
(request-bindings req)))))
|
||||
|
||||
(define (get-bytes)
|
||||
(let* ([the-bytes
|
||||
(make-bytes (get-n) (char->integer #\!))]
|
||||
[req
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
`(html (head (title "How are these bytes?"))
|
||||
(body
|
||||
(h3 ,(bytes->string/utf-8 the-bytes))
|
||||
(a ([href ,(url->string k-url)]) "OK!")))))])
|
||||
the-bytes))
|
||||
|
||||
(let ([initial-request (start-servlet)])
|
||||
`(html (head (title "You got here!"))
|
||||
(body
|
||||
(h1 ,(bytes->string/utf-8 (get-bytes)))))))
|
||||
|
|
@ -1,9 +1,8 @@
|
|||
(module session mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "request-parsing.ss" "web-server")
|
||||
(lib "request-structs.ss" "web-server")
|
||||
(lib "response.ss" "web-server"))
|
||||
(require-for-syntax (lib "url.ss" "net"))
|
||||
(provide current-session)
|
||||
|
||||
(define-struct session (id cust namespace handler url mod-path))
|
||||
|
|
@ -67,12 +66,12 @@
|
|||
(replace-path
|
||||
(lambda (old-path)
|
||||
(if (null? old-path)
|
||||
(list (make-path/param "" new-param-str))
|
||||
(list (make-path/param "" (list new-param-str)))
|
||||
(let* ([car-old-path (car old-path)])
|
||||
(cons (make-path/param (if (path/param? car-old-path)
|
||||
(path/param-path car-old-path)
|
||||
car-old-path)
|
||||
new-param-str)
|
||||
(list new-param-str))
|
||||
(cdr old-path)))))
|
||||
in-url))
|
||||
|
||||
|
|
@ -87,12 +86,7 @@
|
|||
(url-user in-url)
|
||||
(url-host in-url)
|
||||
(url-port in-url)
|
||||
#t
|
||||
new-path
|
||||
(url-query in-url)
|
||||
(url-fragment in-url))))
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(url-fragment in-url)))))
|
||||
|
|
@ -1,6 +1,12 @@
|
|||
(module stuff-url mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
"utils.ss")
|
||||
|
||||
; XXX url: first try continuation, then turn into hash
|
||||
|
||||
; XXX different ways to hash, different ways to store (maybe cookie?)
|
||||
|
||||
;; before reading this, familiarize yourself with serializable values
|
||||
;; covered in ch 36 in the MzScheme manual.
|
||||
|
|
@ -56,9 +62,68 @@
|
|||
;; If the graph and fixups are trivial, then they will be omitted from the query.
|
||||
|
||||
(provide stuff-url
|
||||
extend-url-query
|
||||
unstuff-url
|
||||
find-binding)
|
||||
|
||||
(define (read/string str)
|
||||
(read (open-input-string str)))
|
||||
(define (write/string v)
|
||||
(define str (open-output-string))
|
||||
(write v str)
|
||||
(get-output-string str))
|
||||
|
||||
;; compress-mod-map : (listof (cons mod-spec symbol)) -> (listof (cons (or mod-spec number) symbol))
|
||||
(define (compress-mod-map mm)
|
||||
(compress-mod-map/seen empty mm))
|
||||
|
||||
(define (lookup-seen ms seen)
|
||||
(match seen
|
||||
[(list)
|
||||
(values #f (list ms))]
|
||||
[(list-rest ms+ seen+)
|
||||
(if (equal? ms ms+)
|
||||
(values 0 (list* ms+ seen+))
|
||||
(let-values ([(i seen++) (lookup-seen ms seen+)])
|
||||
(values (if i (add1 i) #f) (list* ms+ seen++))))]))
|
||||
|
||||
(define (compress-mod-map/seen seen mm)
|
||||
(match mm
|
||||
[(list)
|
||||
(list)]
|
||||
[(list-rest (list-rest mod-spec sym) mm)
|
||||
(define-values (i seen+) (lookup-seen mod-spec seen))
|
||||
(if i
|
||||
(list* (cons i sym) (compress-mod-map/seen seen+ mm))
|
||||
(list* (cons mod-spec sym) (compress-mod-map/seen seen+ mm)))]))
|
||||
|
||||
;; decompress-mod-map : (listof (cons (or mod-spec number) symbol)) -> (listof (cons mod-spec symbol))
|
||||
(define (decompress-mod-map cmm)
|
||||
(decompress-mod-map/seen empty cmm))
|
||||
|
||||
(define (decompress-mod-map/seen seen cmm)
|
||||
(match cmm
|
||||
[(list)
|
||||
(list)]
|
||||
[(list-rest (list-rest mod-spec-or-n sym) cmm)
|
||||
(if (number? mod-spec-or-n)
|
||||
(list* (cons (list-ref seen mod-spec-or-n) sym)
|
||||
(decompress-mod-map/seen seen cmm))
|
||||
(list* (cons mod-spec-or-n sym)
|
||||
(decompress-mod-map/seen (append seen (list mod-spec-or-n)) cmm)))]))
|
||||
|
||||
; compress-serial : serial -> serial (with compressed mod-map)
|
||||
(define compress-serial
|
||||
(match-lambda
|
||||
[(list e0 mm e2 e3 e4 e5)
|
||||
(list e0 (compress-mod-map mm) e2 e3 e4 e5)]))
|
||||
|
||||
; decompress-serial : serial (with compressed mod-map) -> serial
|
||||
(define decompress-serial
|
||||
(match-lambda
|
||||
[(list e0 cmm e2 e3 e4 e5)
|
||||
(list e0 (decompress-mod-map cmm) e2 e3 e4 e5)]))
|
||||
|
||||
;; url-parts: module-path serial -> string (listof (union number 'k)) s-expr s-expr s-expr
|
||||
;; compute the parts for the url:
|
||||
;; labeling code
|
||||
|
|
@ -88,8 +153,8 @@
|
|||
(define (reconstruct-mod-map mod-path label-code simple-map)
|
||||
(map
|
||||
(lambda (n-or-k)
|
||||
(if (eqv? n-or-k 'k)
|
||||
'((lib "abort-resume.ss" "prototype-web-server") . web-deserialize-info:kont)
|
||||
(if (symbol? n-or-k)
|
||||
`((lib "abort-resume.ss" "prototype-web-server") . ,n-or-k)
|
||||
(cons
|
||||
mod-path
|
||||
(string->symbol
|
||||
|
|
@ -123,7 +188,7 @@
|
|||
(let ([match? (regexp-match WEB-DESERIALIZE-INFO-REGEXP (symbol->string sym))])
|
||||
(and match? (string->number (caddr match?)))))
|
||||
|
||||
;; simplify-module-map: module-path string module-map -> (listof (union number 'k))
|
||||
;; simplify-module-map: module-path string module-map -> (listof (union number symbol))
|
||||
;; convert the module-map into a simple list
|
||||
(define (simplify-module-map pth labeling-code mod-map)
|
||||
(let loop ([mm mod-map])
|
||||
|
|
@ -133,7 +198,7 @@
|
|||
(match-label (cdar mm)))
|
||||
=> (lambda (lab) (cons lab (loop (cdr mm))))]
|
||||
[(same-module? '(lib "abort-resume.ss" "prototype-web-server") (caar mm))
|
||||
(cons 'k (loop (cdr mm)))]
|
||||
(cons (cdar mm) (loop (cdr mm)))]
|
||||
[else
|
||||
(error "cannot construct abreviated module map" mod-map)])))
|
||||
|
||||
|
|
@ -145,15 +210,15 @@
|
|||
|
||||
;; stuff-url: serial url path -> url
|
||||
;; encode in the url
|
||||
(define (stuff-url svl uri pth)
|
||||
#;(define (stuff-url svl uri pth)
|
||||
(let-values ([(l-code simple-mod-map graph fixups sv)
|
||||
(url-parts pth svl)])
|
||||
(let ([new-query
|
||||
`(,(cons 'c l-code)
|
||||
,@(if (null? graph) '()
|
||||
(cons 'g (format "~s" graph)))
|
||||
(list (cons 'g (format "~s" graph))))
|
||||
,@(if (null? fixups) '()
|
||||
(cons 'f (format "~s" fixups)))
|
||||
(list (cons 'f (format "~s" fixups))))
|
||||
,(cons 'v (format "~s" sv)))])
|
||||
(let ([result-uri
|
||||
(make-url
|
||||
|
|
@ -161,9 +226,10 @@
|
|||
(url-user uri)
|
||||
(url-host uri)
|
||||
(url-port uri)
|
||||
#t
|
||||
(append (url-path uri)
|
||||
(map
|
||||
(lambda (n-or-sym) (format "~a" n-or-sym))
|
||||
(lambda (n-or-sym) (make-path/param (format "~a" n-or-sym) empty))
|
||||
simple-mod-map))
|
||||
new-query
|
||||
(url-fragment uri))])
|
||||
|
|
@ -172,23 +238,70 @@
|
|||
(when (> (string-length (url->string result-uri))
|
||||
1024)
|
||||
(error "the url is too big: " (url->string result-uri))))))))
|
||||
|
||||
(require (lib "md5.ss"))
|
||||
(define (md5-store str)
|
||||
(define hash (md5 (string->bytes/utf-8 str)))
|
||||
(with-output-to-file
|
||||
(format "/Users/jay/Development/plt/urls/~a" hash)
|
||||
(lambda ()
|
||||
(write str))
|
||||
'replace)
|
||||
(bytes->string/utf-8 hash))
|
||||
(define (md5-lookup hash)
|
||||
(with-input-from-file
|
||||
(format "/Users/jay/Development/plt/urls/~a" hash)
|
||||
(lambda () (read))))
|
||||
|
||||
(define (stuff-url svl uri pth)
|
||||
#;(printf "stuff: ~s~n" svl)
|
||||
(let ([result-uri
|
||||
(make-url
|
||||
(url-scheme uri)
|
||||
(url-user uri)
|
||||
(url-host uri)
|
||||
(url-port uri)
|
||||
#t
|
||||
(url-path uri)
|
||||
(list (cons 'c (md5-store (write/string (compress-serial svl)))))
|
||||
(url-fragment uri))])
|
||||
(begin0
|
||||
result-uri
|
||||
(when (> (string-length (url->string result-uri))
|
||||
1024)
|
||||
(error "the url is too big: " (url->string result-uri))))))
|
||||
|
||||
(define (extend-url-query uri key val)
|
||||
(make-url
|
||||
(url-scheme uri)
|
||||
(url-user uri)
|
||||
(url-host uri)
|
||||
(url-port uri)
|
||||
#t
|
||||
(url-path uri)
|
||||
(list* (cons key val)
|
||||
(url-query uri))
|
||||
(url-fragment uri)))
|
||||
|
||||
;; unstuff-url: url url path -> serial
|
||||
;; decode from the url and reconstruct the serial
|
||||
(define (unstuff-url req-url ses-url mod-path)
|
||||
#;(define (unstuff-url req-url ses-url mod-path)
|
||||
(let ([suff (split-url-path ses-url req-url)]
|
||||
[qry (url-query req-url)])
|
||||
[qry (url-query req-url)])
|
||||
(recover-serial
|
||||
mod-path
|
||||
(find-binding 'c qry)
|
||||
(map
|
||||
(lambda (elt)
|
||||
(if (string=? elt "k") 'k
|
||||
(string->number elt)))
|
||||
(define nelt (string->number elt))
|
||||
(if (not nelt) (string->symbol elt)
|
||||
nelt))
|
||||
suff)
|
||||
(or (find-binding 'g qry) '())
|
||||
(or (find-binding 'f qry) '())
|
||||
(find-binding 'v qry))))
|
||||
(define (unstuff-url req-url ses-url mod-path)
|
||||
(decompress-serial (read/string (md5-lookup (find-binding 'c (url-query req-url))))))
|
||||
|
||||
;; find-binding: symbol (list (cons symbol string)) -> (union string #f)
|
||||
;; find the binding in the query or return false
|
||||
|
|
@ -197,5 +310,4 @@
|
|||
[(null? qry) #f]
|
||||
[(eqv? key (caar qry))
|
||||
(read (open-input-string (cdar qry)))]
|
||||
[else (find-binding key (cdr qry))]))
|
||||
)
|
||||
[else (find-binding key (cdr qry))])))
|
||||
|
|
|
|||
|
|
@ -11,10 +11,8 @@
|
|||
;; (listof syntax) syntax -> syntax
|
||||
;; recertify a list of syntax parts given the whole
|
||||
(define (recertify* exprs old-expr)
|
||||
(map
|
||||
(lambda (expr)
|
||||
(syntax-recertify expr old-expr (current-code-inspector) #f))
|
||||
exprs))
|
||||
(map (lambda (expr) (recertify expr old-expr))
|
||||
exprs))
|
||||
|
||||
;; generate-formal: -> identifier
|
||||
(define (generate-formal sym-name)
|
||||
|
|
@ -23,8 +21,7 @@
|
|||
(if (syntax-transforming?)
|
||||
(local-expand #`(lambda (#,name) #,name) 'expression '())
|
||||
#`(lambda (#,name) #,name))])
|
||||
(values #'formal #'ref-to-formal))))
|
||||
)
|
||||
(values #'formal #'ref-to-formal)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
(module certify-error2 "../persistent-interaction.ss"
|
||||
(or #f #t))
|
||||
|
|
@ -23,7 +23,7 @@
|
|||
(parameterize ([current-namespace ns])
|
||||
(eval `(require (lib "client.ss" "prototype-web-server")
|
||||
(lib "serialize.ss")
|
||||
,pth))
|
||||
(file ,pth)))
|
||||
(lambda (expr)
|
||||
(parameterize ([current-namespace ns])
|
||||
(eval expr)))))))
|
||||
|
|
@ -287,7 +287,7 @@
|
|||
(let ([ignore (start-interaction car)])
|
||||
(let ([result (+ (gn "first") (gn "second"))])
|
||||
(let ([ignore (printf "The answer is: ~s~n" result)])
|
||||
result)))))])
|
||||
result)))))])
|
||||
|
||||
(let* ([first-key (test-m06.1 '(dispatch-start 'foo))]
|
||||
[second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))]
|
||||
|
|
|
|||
|
|
@ -33,11 +33,11 @@
|
|||
"Test same-module?"
|
||||
|
||||
(assert-true
|
||||
(same-module? (build-path "~/plt-exp/collects/prototype-web-server/abort-resume.ss")
|
||||
(same-module? `(file ,(build-path "~/Development/Projects/exp/prototype-web-server/abort-resume.ss"))
|
||||
'(lib "abort-resume.ss" "prototype-web-server")))
|
||||
|
||||
(assert-true
|
||||
(same-module? (build-absolute-path (current-directory) "../abort-resume.ss")
|
||||
(same-module? `(file ,(build-absolute-path (current-directory) "../abort-resume.ss"))
|
||||
'(lib "abort-resume.ss" "prototype-web-server")))
|
||||
|
||||
(assert-true
|
||||
|
|
|
|||
|
|
@ -1,20 +1,20 @@
|
|||
(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1))
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
"persistent-close-tests.ss"
|
||||
"test-normalizer.ss"
|
||||
"closure-tests.ss"
|
||||
"labels-tests.ss"
|
||||
"persistent-interaction-tests.ss"
|
||||
"stuff-url-tests.ss")
|
||||
|
||||
(test/graphical-ui
|
||||
(make-test-suite
|
||||
"Main Tests for Prototype Web Server"
|
||||
persistent-close-suite
|
||||
stuff-url-suite
|
||||
test-normalizer-suite
|
||||
closure-tests-suite
|
||||
labels-tests-suite
|
||||
persistent-interaction-suite
|
||||
))
|
||||
|
||||
(module suite mzscheme
|
||||
(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1))
|
||||
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
|
||||
"persistent-close-tests.ss"
|
||||
"test-normalizer.ss"
|
||||
"closure-tests.ss"
|
||||
"labels-tests.ss"
|
||||
"persistent-interaction-tests.ss"
|
||||
"stuff-url-tests.ss")
|
||||
|
||||
(test/graphical-ui
|
||||
(make-test-suite
|
||||
"Main Tests for Prototype Web Server"
|
||||
persistent-close-suite
|
||||
stuff-url-suite
|
||||
test-normalizer-suite
|
||||
closure-tests-suite
|
||||
labels-tests-suite
|
||||
persistent-interaction-suite
|
||||
)))
|
||||
|
|
@ -106,8 +106,9 @@
|
|||
[(_ expr)
|
||||
#'(with-handlers ([(lambda (x) #t)
|
||||
(lambda (the-exn)
|
||||
(string=? "lambda: Not all lambda-expressions supported"
|
||||
(exn-message the-exn)))])
|
||||
(and (regexp-match "normalize: Not all lambda-expressions supported"
|
||||
(exn-message the-exn))
|
||||
#t))])
|
||||
expr)]))
|
||||
|
||||
(define-syntax (check-unsupported-let stx)
|
||||
|
|
@ -282,7 +283,8 @@
|
|||
(make-test-suite
|
||||
"Check that certain errors are raised"
|
||||
|
||||
(make-test-case
|
||||
; this is supported now
|
||||
#;(make-test-case
|
||||
"multiple body expressions in lambda"
|
||||
(assert-true (check-unsupported-lambda
|
||||
(normalize-term (expand (syntax (lambda (x y z) 3 4)))))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(module utils mzscheme
|
||||
(require (lib "url.ss" "net"))
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "list.ss"))
|
||||
(provide url->servlet-path
|
||||
make-session-url
|
||||
split-url-path)
|
||||
|
|
@ -15,7 +16,9 @@
|
|||
(url-user uri)
|
||||
(url-host uri)
|
||||
(url-port uri)
|
||||
new-path
|
||||
#t
|
||||
(map (lambda (p) (make-path/param p empty))
|
||||
new-path)
|
||||
'()
|
||||
#f
|
||||
))
|
||||
|
|
@ -73,7 +76,7 @@
|
|||
;; The second value is the prefix of the url-path used to find the servlet.
|
||||
;; The third value is the remaining suffix of the url-path.
|
||||
(define (url->servlet-path servlet-dir uri)
|
||||
(printf " current-directory = ~s~n" (current-directory))
|
||||
#;(printf " current-directory = ~s~n" (current-directory))
|
||||
(let loop ([base-path servlet-dir]
|
||||
[servlet-path '()]
|
||||
[path-list (simplify-url-path uri)])
|
||||
|
|
@ -82,7 +85,7 @@
|
|||
(values #f #f #f)
|
||||
(let* ([next-path-segment (car path-list)]
|
||||
[new-base (build-path base-path next-path-segment)])
|
||||
(printf " new-base = ~s~n" new-base)
|
||||
#;(printf " new-base = ~s~n" new-base)
|
||||
(cond
|
||||
[(file-exists? new-base)
|
||||
(values new-base
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
(all-except "expander.ss" send/suspend)
|
||||
"utils.ss"
|
||||
"session.ss"
|
||||
(lib "request-parsing.ss" "web-server")
|
||||
(lib "list.ss")
|
||||
(lib "request-structs.ss" "web-server")
|
||||
(lib "url.ss" "net"))
|
||||
|
||||
(provide (all-from-except mzscheme #%module-begin)
|
||||
|
|
@ -38,19 +39,24 @@
|
|||
(let ([n 0])
|
||||
(lambda (k)
|
||||
(set! n (add1 n))
|
||||
(printf "Adding ~a to ~S~n" n (hash-table-map k-table (lambda (k v) k)))
|
||||
(hash-table-put! k-table n k)
|
||||
(printf "Now: ~S~n" (hash-table-map k-table (lambda (k v) k)))
|
||||
n)))
|
||||
|
||||
;; url/id->continuation: url -> (union continuation #f)
|
||||
;; extract the key from the url and then lookup the continuation
|
||||
(define (url/id->continuation req-uri)
|
||||
(let ([ses-uri (session-url (current-session))])
|
||||
(let ([url-path-suffix (split-url-path ses-uri req-uri)])
|
||||
(and url-path-suffix
|
||||
(not (null? url-path-suffix))
|
||||
(hash-table-get k-table
|
||||
(string->number (car url-path-suffix))
|
||||
(lambda () #f))))))
|
||||
(define ses-uri (session-url (current-session)))
|
||||
(define url-path-suffix (split-url-path ses-uri req-uri))
|
||||
(if ((length url-path-suffix) . >= . 1)
|
||||
(let ([k-id (string->number (first url-path-suffix))])
|
||||
(hash-table-get k-table k-id
|
||||
(lambda ()
|
||||
(printf "continuation ~a not found in ~S~n"
|
||||
k-id (hash-table-map k-table (lambda (k v) k)))
|
||||
#f)))
|
||||
#f))
|
||||
|
||||
;; encode-k-id-in-url: continuation -> url
|
||||
;; encode a continuation id in a url
|
||||
|
|
@ -61,7 +67,7 @@
|
|||
(url-user uri)
|
||||
(url-host uri)
|
||||
(url-port uri)
|
||||
(append (url-path uri) (list (number->string (continuation->number k))))
|
||||
#t
|
||||
(append (url-path uri) (list (make-path/param (number->string (continuation->number k)) empty)))
|
||||
(url-query uri)
|
||||
(url-fragment uri))))
|
||||
)
|
||||
(url-fragment uri)))))
|
||||
14
collects/web-server/prototype-web-server/xexpr-extras.ss
Normal file
14
collects/web-server/prototype-web-server/xexpr-extras.ss
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
(module xexpr-extras mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "plt-match.ss"))
|
||||
(provide xexpr+extras->xexpr)
|
||||
|
||||
(define xexpr+extras->xexpr
|
||||
(match-lambda
|
||||
[(list xe ...)
|
||||
(map xexpr+extras->xexpr xe)]
|
||||
[(and url (? url?))
|
||||
(url->string url)]
|
||||
[x
|
||||
x])))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user