* 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:
parent
e866228288
commit
abd747a49b
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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))))))
|
||||||
))
|
))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue