diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index 0c1a21d..8f1f204 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -1,4 +1,7 @@ ;; 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 (export ((lambda-interface @@ -84,14 +87,15 @@ profiling ;PROFILE-SPACE httpd-logging ;HTTP-SYSLOG shift-reset ;SHIFT and RESET + sxml-to-html ;SXML->HTML scsh ;regexp et al. scheme ) (files servlet-handler)) (define-interface plugin-utilities-interface - (export send/suspend - send/finish + (export send-html/suspend + send-html/finish )) (define-interface plugin-interface diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 089e4ea..f6223c5 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -4,12 +4,14 @@ ;;; instance-table: entry for every new request on a servlet page (define-record-type instance :instance - (make-instance servlet-name continuation-table) + (make-instance servlet-name continuation-table continuation-counter) instance? (servlet-name really-instance-servlet-name set-instance-servlet-name!) (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 (really-make-session instance-id return-continuation) @@ -95,26 +97,45 @@ You can try starting at the beginning." (resume req))))))))))) -(define (send/suspend response-maker) +(define (send-html/suspend html-tree-maker) (shift return (let* ((instance-id (session-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))) (table-set! continuations-table continuation-id return) (let ((new-url (make-resume-url (instance-servlet-name instance-id) instance-id + continuation-counter 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)) - 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 (define (save-instance! servlet-name 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 (define (instance instance-id) @@ -126,6 +147,16 @@ You can try starting at the beginning." (define (instance-continuation-table 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) (table-set! *instance-table* instance-id #f)) @@ -133,8 +164,7 @@ You can try starting at the beginning." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ID generation ;; FIXME: make this thread safe -;; FIXME: this may loop forever, if the table is full -;;(max. 2**28-1 instances) +;; FIXME: this may loop forever, if the table is full (can this happen?) (define (generate-new-instance-id) (let loop ((instance-id (random))) (if (instance instance-id) @@ -143,8 +173,7 @@ You can try starting at the beginning." ;; FIXME make this thread-safe (locks) -;; FIXME this may loop forever, if the table is full -;; (max. 2**28-1 continuations) +;; FIXME this may loop forever, if the table is full (can this happen?) (define (generate-new-continuation-id instance-id) (let ((continuation-table (instance-continuation-table instance-id))) (let loop ((continuation-id (random))) @@ -214,12 +243,13 @@ You can try starting at the beginning." ;; RESUME-URL (define *resume-url-regexp* (rx (submatch (* (- printing ";"))) ";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 - ";k" (number->string instance-id) - ";c" (number->string continuation-id))) + ";k" (number->string (session-instance-id)) + ";c" (number->string continuation-counter) + "-" (number->string continuation-id))) (define (resume-url-instance-id id-url) (receive (instance-id continuation-id) diff --git a/web-server/root/surflets/news.scm b/web-server/root/surflets/news.scm index 2c3b946..0a732cc 100644 --- a/web-server/root/surflets/news.scm +++ b/web-server/root/surflets/news.scm @@ -20,34 +20,14 @@ (if (null? *data*) (read-data)) (let loop ((count (- (length *data*) 1))) (if (< count 0) - (send/finish - (make-response - http-status/ok - (status-code->text http-status/ok) - (time) - "text/html" - '() - (make-writer-body - (lambda (out options) - (format out - "
-That's it..."))))) + (send-html/finish + `(html (body (p (h1 "THAT'S IT")) + (p ("That's it..."))))) (begin - (send/suspend + (send-html/suspend (lambda (next-url) - (make-response - http-status/ok - (status-code->text http-status/ok) - (time) - "text/html" - '() - (make-writer-body - (lambda (out options) - (format out - "
-read more..." - (list-ref *data* count) - next-url)))))) + `(html (body (p (h1 ,(list-ref *data* count)))) + (a (@ href ,next-url) "read more...")))) (loop (- count 1)))))) ))