* use Oleg's SSAX (SSAX->HTML et al.)

* add continuation counter in servlet-handler, thus the generated continuation
  urls are a bit more human readable.
This commit is contained in:
interp 2002-09-19 11:16:29 +00:00
parent e866228288
commit abd747a49b
3 changed files with 57 additions and 43 deletions

View File

@ -1,4 +1,7 @@
;; Structures and interfaces for servlets. ;; Structures and interfaces for servlets.
;; NOTE: SSAX/lib/packages.scm must be loaded before you can use this
;; downloadable from http://sourceforge.net/project/showfiles.php?group_id=30687
;; (take the r5rs compliant version (ssax-sr5rs-plt200-4.9.tar.gz))
(define-interface rt-module-language-interface (define-interface rt-module-language-interface
(export ((lambda-interface (export ((lambda-interface
@ -84,14 +87,15 @@
profiling ;PROFILE-SPACE profiling ;PROFILE-SPACE
httpd-logging ;HTTP-SYSLOG httpd-logging ;HTTP-SYSLOG
shift-reset ;SHIFT and RESET shift-reset ;SHIFT and RESET
sxml-to-html ;SXML->HTML
scsh ;regexp et al. scsh ;regexp et al.
scheme scheme
) )
(files servlet-handler)) (files servlet-handler))
(define-interface plugin-utilities-interface (define-interface plugin-utilities-interface
(export send/suspend (export send-html/suspend
send/finish send-html/finish
)) ))
(define-interface plugin-interface (define-interface plugin-interface

View File

@ -4,12 +4,14 @@
;;; instance-table: entry for every new request on a servlet page ;;; instance-table: entry for every new request on a servlet page
(define-record-type instance :instance (define-record-type instance :instance
(make-instance servlet-name continuation-table) (make-instance servlet-name continuation-table continuation-counter)
instance? instance?
(servlet-name really-instance-servlet-name (servlet-name really-instance-servlet-name
set-instance-servlet-name!) set-instance-servlet-name!)
(continuation-table really-instance-continuation-table (continuation-table really-instance-continuation-table
set-instance-continuation-table!)) set-instance-continuation-table!)
(continuation-counter really-instance-continuation-counter
set-instance-continuation-counter!))
(define-record-type session :session (define-record-type session :session
(really-make-session instance-id return-continuation) (really-make-session instance-id return-continuation)
@ -95,26 +97,45 @@ You can try starting at the <A HREF=~a>beginning</a>."
(resume req))))))))))) (resume req)))))))))))
(define (send/suspend response-maker) (define (send-html/suspend html-tree-maker)
(shift return (shift return
(let* ((instance-id (session-instance-id)) (let* ((instance-id (session-instance-id))
(continuations-table (instance-continuation-table instance-id)) (continuations-table (instance-continuation-table instance-id))
(continuation-counter (instance-next-continuation-counter instance-id))
(continuation-id (generate-new-continuation-id instance-id))) (continuation-id (generate-new-continuation-id instance-id)))
(table-set! continuations-table continuation-id return) (table-set! continuations-table continuation-id return)
(let ((new-url (make-resume-url (instance-servlet-name instance-id) (let ((new-url (make-resume-url (instance-servlet-name instance-id)
instance-id instance-id
continuation-counter
continuation-id))) continuation-id)))
(response-maker new-url))))) (make-usual-html-response
(lambda (out options)
(with-current-output-port*
out
(lambda () (SXML->HTML (html-tree-maker new-url))))))))))
(define (send/finish response) (define (send-html/finish html-tree)
(instance-delete (session-instance-id)) (instance-delete (session-instance-id))
response) (make-usual-html-response
(lambda (out options)
(with-current-output-port* ; don't want to blame Oleg, but...
out
(lambda () (SXML->HTML html-tree))))))
(define (make-usual-html-response writer-proc)
(make-response
http-status/ok
(status-code->text http-status/ok)
(time)
"text/html"
'()
(make-writer-body writer-proc)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; access to instance-table ;; access to instance-table
(define (save-instance! servlet-name instance-id) (define (save-instance! servlet-name instance-id)
(table-set! *instance-table* instance-id (table-set! *instance-table* instance-id
(make-instance servlet-name (make-integer-table)))) (make-instance servlet-name (make-integer-table) 0)))
;; FIXME: make continuation-table thread-safe ;; FIXME: make continuation-table thread-safe
(define (instance instance-id) (define (instance instance-id)
@ -126,6 +147,16 @@ You can try starting at the <A HREF=~a>beginning</a>."
(define (instance-continuation-table instance-id) (define (instance-continuation-table instance-id)
(really-instance-continuation-table (instance instance-id))) (really-instance-continuation-table (instance instance-id)))
(define (instance-continuation-counter instance-id)
(really-instance-continuation-counter (instance instance-id)))
(define (instance-next-continuation-counter instance-id)
(let ((instance (instance instance-id)))
(set-instance-continuation-counter!
instance
(+ 1 (really-instance-continuation-counter instance)))
(really-instance-continuation-counter instance)))
(define (instance-delete instance-id) (define (instance-delete instance-id)
(table-set! *instance-table* instance-id #f)) (table-set! *instance-table* instance-id #f))
@ -133,8 +164,7 @@ You can try starting at the <A HREF=~a>beginning</a>."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ID generation ;; ID generation
;; FIXME: make this thread safe ;; FIXME: make this thread safe
;; FIXME: this may loop forever, if the table is full ;; FIXME: this may loop forever, if the table is full (can this happen?)
;;(max. 2**28-1 instances)
(define (generate-new-instance-id) (define (generate-new-instance-id)
(let loop ((instance-id (random))) (let loop ((instance-id (random)))
(if (instance instance-id) (if (instance instance-id)
@ -143,8 +173,7 @@ You can try starting at the <A HREF=~a>beginning</a>."
;; FIXME make this thread-safe (locks) ;; FIXME make this thread-safe (locks)
;; FIXME this may loop forever, if the table is full ;; FIXME this may loop forever, if the table is full (can this happen?)
;; (max. 2**28-1 continuations)
(define (generate-new-continuation-id instance-id) (define (generate-new-continuation-id instance-id)
(let ((continuation-table (instance-continuation-table instance-id))) (let ((continuation-table (instance-continuation-table instance-id)))
(let loop ((continuation-id (random))) (let loop ((continuation-id (random)))
@ -214,12 +243,13 @@ You can try starting at the <A HREF=~a>beginning</a>."
;; RESUME-URL ;; RESUME-URL
(define *resume-url-regexp* (rx (submatch (* (- printing ";"))) (define *resume-url-regexp* (rx (submatch (* (- printing ";")))
";k" (submatch (* digit)) ; Instance-ID ";k" (submatch (* digit)) ; Instance-ID
";c" (submatch (* digit)))) ; Continuation-ID ";c" (+ digit) "-" (submatch (* digit)))) ; Continuation-ID
(define (make-resume-url full-path instance-id continuation-id) (define (make-resume-url full-path instance-id continuation-counter continuation-id)
(string-append full-path (string-append full-path
";k" (number->string instance-id) ";k" (number->string (session-instance-id))
";c" (number->string continuation-id))) ";c" (number->string continuation-counter)
"-" (number->string continuation-id)))
(define (resume-url-instance-id id-url) (define (resume-url-instance-id id-url)
(receive (instance-id continuation-id) (receive (instance-id continuation-id)

View File

@ -20,34 +20,14 @@
(if (null? *data*) (read-data)) (if (null? *data*) (read-data))
(let loop ((count (- (length *data*) 1))) (let loop ((count (- (length *data*) 1)))
(if (< count 0) (if (< count 0)
(send/finish (send-html/finish
(make-response `(html (body (p (h1 "THAT'S IT"))
http-status/ok (p ("That's it...")))))
(status-code->text http-status/ok)
(time)
"text/html"
'()
(make-writer-body
(lambda (out options)
(format out
"<HTML><BODY><H1>THAT'S IT<H1><P>
That's it...</BODY></HTML>")))))
(begin (begin
(send/suspend (send-html/suspend
(lambda (next-url) (lambda (next-url)
(make-response `(html (body (p (h1 ,(list-ref *data* count))))
http-status/ok (a (@ href ,next-url) "read more..."))))
(status-code->text http-status/ok)
(time)
"text/html"
'()
(make-writer-body
(lambda (out options)
(format out
"<HTML><BODY><H1>~a<H1><P>
<A href=~a>read more...</A></BODY></HTML>"
(list-ref *data* count)
next-url))))))
(loop (- count 1)))))) (loop (- count 1))))))
)) ))