diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
new file mode 100644
index 0000000..fb6551a
--- /dev/null
+++ b/scheme/httpd/surflets/packages.scm
@@ -0,0 +1,95 @@
+;; Structures and interfaces for servlets.
+
+(define-interface rt-module-language-interface
+ (export ((lambda-interface
+ with-names-from-rt-structure)
+ :syntax)
+ reify-structure
+ load-structure
+ load-config-file
+ rt-structure-binding))
+
+(define-interface rt-modules-interface
+ (export interface-value-names
+ reify-structure
+ load-config-file
+ rt-structure-binding
+ load-structure))
+
+(define-structure rt-module-language rt-module-language-interface
+ (open scheme
+ rt-modules)
+ (for-syntax (open scheme
+ rt-modules))
+ (begin
+ (define-syntax lambda-interface
+ (lambda (expr rename compare)
+ (let ((%lambda (rename 'lambda))
+ (interface-name (cadr expr))
+ (body (cddr expr)))
+ `(,%lambda ,(interface-value-names interface-name) ,@body))))
+
+;(with-names-from-rt-structure plugin plugin-interface (main))
+ (define-syntax with-names-from-rt-structure
+ (lambda (expr rename compare)
+ (let ((%lambda (rename 'lambda))
+ (%let (rename 'let))
+ (%rt-structure-value (rename 'rt-structure-value))
+ (%rt-structure-binding (rename 'rt-structure-binding))
+ (rt-structure (cadr expr))
+ (interface-name (caddr expr))
+ (body (cdddr expr)))
+ (let ((ivn (interface-value-names interface-name)))
+ `(,%let ((,%rt-structure-value ,rt-structure))
+ ((,%lambda ,ivn ,@body)
+ ,@(map (lambda (name)
+ `(,%rt-structure-binding ,%rt-structure-value ',name))
+ ivn)))))))))
+
+(define-structure rt-modules rt-modules-interface
+ (open scheme
+ meta-types ; syntax-type
+ interfaces ; for-each-declaration
+ define-record-types
+ records
+ signals
+ bindings
+ packages
+ packages-internal
+ locations
+ environments
+ ensures-loaded
+ package-commands-internal)
+ (files rt-module))
+
+(define-interface servlet-handler-interface
+ (export servlet-handler))
+
+
+(define-structures
+ ((servlet-handler servlet-handler-interface)
+ (plugin-utilities plugin-utilities-interface))
+ (open httpd-responses
+ httpd-request
+ uri
+ tables ;hash-tables
+ define-record-types
+ rt-module-language ;get structures dynamically
+ srfi-13
+ srfi-14 ;CHAR-SET:DIGIT
+ handle-fatal-error
+ random ;not quite random
+ locks
+ thread-cells
+ scsh
+ scheme
+ )
+ (files servlet-handler))
+
+(define-interface plugin-utilities-interface
+ (export send/suspend
+ send/finish
+ ))
+
+(define-interface plugin-interface
+ (export main))
diff --git a/scheme/httpd/surflets/rt-module.scm b/scheme/httpd/surflets/rt-module.scm
new file mode 100644
index 0000000..63f4642
--- /dev/null
+++ b/scheme/httpd/surflets/rt-module.scm
@@ -0,0 +1,58 @@
+;; rt-module.scm
+;; Copyright Martin Gasbichler, 2002
+
+;; Receipt:
+;;(load-config-file "test.scm") --> nothing
+;; load config file containing structure definition
+;;
+;; (reify-structure 'plugin) --> #{Rt-stucture plugin}
+;; gets structure info about a structure
+;;
+;; (define plugin ##)
+;; (load-structure plugin)
+;; loads rt-structure
+;;
+;; (rt-structure-binding plugin 'main) --> value
+;; get a binding of a structure
+
+
+(define (interface-value-names interface-name)
+ (let ((interface (environment-ref (config-package) interface-name))
+ (value-names '()))
+ (for-each-declaration
+ (lambda (name base-neme type)
+ (if (not (equal? type syntax-type))
+ (set! value-names (cons name value-names))))
+ interface)
+ value-names))
+
+(define-record-type rt-structure :rt-structure
+ (make-rt-structure meta-structure)
+ rt-structure?
+ (meta-structure rt-structure-meta-structure))
+
+(define (rt-structure-loaded? rt-structure)
+ (package-loaded?
+ (structure-package (rt-structure-meta-structure rt-structure))))
+
+(define-record-discloser :rt-structure
+ (lambda (s)
+ (list 'rt-stucture (structure-name (rt-structure-meta-structure s)))))
+
+(define (reify-structure name)
+ (let ((struct (get-structure name)))
+ (make-rt-structure struct)))
+
+(define (load-structure rts)
+ (ensure-loaded (rt-structure-meta-structure rts)))
+
+(define (rt-structure-binding structure name)
+ (if (not (rt-structure-loaded? structure))
+ (error "Structure not loaded" structure))
+ (contents
+ (binding-place
+ (generic-lookup (rt-structure-meta-structure structure)
+ name))))
+
+(define (load-config-file file)
+ (load file (config-package)))
diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm
new file mode 100644
index 0000000..8df7ff6
--- /dev/null
+++ b/scheme/httpd/surflets/surflet-handler.scm
@@ -0,0 +1,245 @@
+;; the servlet handler
+;; Copyright Andreas Bernauer, 2002
+
+
+;(define-record-type continuation-table-entry :continuation-table-entry
+; (make-continuation-table-entry continuation)
+; continuation-table-entry?
+; (id continuation-table-entry-id set-continuation-table-entry-id!)
+; (continuation continuation-table-entry-continuation
+; set-continuation-table-entry-continuation!))
+
+
+;;; instance-table: entry for every new request on a servlet page
+(define-record-type instance :instance
+ (make-instance servlet-name continuation-table)
+ instance?
+ (servlet-name really-instance-servlet-name
+ set-instance-servlet-name!)
+ (continuation-table really-instance-continuation-table
+ set-instance-continuation-table!))
+
+(define-record-type session :session
+ (really-make-session instance-id return-continuation)
+ session?
+ (instance-id really-session-instance-id
+ set-session-instance-id!)
+ (return-continuation really-session-return-continuation
+ set-session-return-continuation!))
+
+;; FIXME: Make this thread-safe
+(define *instance-table* (make-integer-table)) ; instance-id is index
+(define random (make-random (modulo (time)268435455))) ; not really random
+ ; generator
+
+(define (servlet-handler servlet-path)
+ (lambda (path req)
+ (if (pair? path) ; need at least one element
+ (let ((request-method (request:method req))
+ (full-path (uri-path-list->path path)))
+ (cond
+ ((or (string=? request-method "GET")
+ (string=? request-method "PUT"))
+ (with-cwd
+ servlet-path
+ (if (resume-url? full-path)
+ (resume-url full-path req)
+ (launch-new-instance full-path req))))
+ (else
+ (make-http-error-response http-status/method-not-allowed req
+ request-method))))
+ (make-http-error-response http-status/bad-request req
+ (format #f "Bad path: ~s" path)))))
+
+(define (launch-new-instance full-path req)
+ (let ((instance-id (generate-new-instance-id))
+ (plugin (get-plugin-rt-structure full-path)))
+ (call-with-current-continuation
+ (lambda (return)
+ (save-instance! full-path instance-id) ; make entry in instance-table
+ (register-session! instance-id return)
+ (with-names-from-rt-structure
+ plugin plugin-interface
+ ;; MAIN may return in another thread, so we have to lookup
+ ;; return continuation explicitly
+ ((session-return-continuation) (main req)))))))
+
+;; try to get continuation-table and then the continuation
+(define (resume-url full-path req)
+ (call-with-current-continuation
+ (lambda (return)
+ (with-fatal-error-handler*
+ (lambda (condition decline)
+ (return (make-http-error-response
+ http-status/bad-request req
+ (format #f "The servlet does not accept any requests any more or your URL is illformed.
+You can try starting at the beginning."
+ (resume-url-servlet-name full-path)))))
+ (lambda ()
+ (receive (instance-id continuation-id)
+ (resume-url-ids full-path)
+
+ (let* ((continuation-table (instance-continuation-table instance-id))
+ (resume (table-ref continuation-table continuation-id)))
+ (if resume
+ (call-with-current-continuation
+ (lambda (return)
+ (register-session! instance-id return)
+ (error "This may never return." ; for debugging
+ (resume req))))))))))))
+
+
+(define (send/suspend response-maker)
+ (call-with-current-continuation
+ (lambda (return)
+ (let* ((instance-id (session-instance-id))
+ (continuations-table (instance-continuation-table 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-id)))
+ ((session-return-continuation) (response-maker new-url)))))))
+
+(define (send/finish response)
+ (instance-delete (session-instance-id))
+ ((session-return-continuation) response))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; access to instance-table
+(define (save-instance! servlet-name instance-id)
+ (table-set! *instance-table* instance-id
+ (make-instance servlet-name (make-integer-table))))
+;; FIXME: make continuation-table thread-safe
+
+(define (instance instance-id)
+ (table-ref *instance-table* instance-id))
+
+(define (instance-servlet-name instance-id)
+ (really-instance-servlet-name (instance instance-id)))
+
+(define (instance-continuation-table instance-id)
+ (really-instance-continuation-table (instance instance-id)))
+
+(define (instance-delete instance-id)
+ (table-set! *instance-table* instance-id #f))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ID generation
+;; FIXME: make this thread safe
+;; FIXME: this may loop forever, if the table is full
+;;(max. 2**28-1 instances)
+(define (generate-new-instance-id)
+ (let loop ((instance-id (random)))
+ (if (instance instance-id)
+ (loop (random))
+ instance-id)))
+
+
+;; FIXME make this thread-safe (locks)
+;; FIXME this may loop forever, if the table is full
+;; (max. 2**28-1 continuations)
+(define (generate-new-continuation-id instance-id)
+ (let ((continuation-table (instance-continuation-table instance-id)))
+ (let loop ((continuation-id (random)))
+ (if (table-ref continuation-table continuation-id)
+ (loop (random))
+ continuation-id))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PLUGINs CACHE
+;; FIXME: make this thread-safe
+(define *plugin-table* (make-string-table)) ; full-path is index
+(define plugin-table-lock (make-lock))
+
+;; FIXME: reload plugin if timestamp has changed
+;; PLUGIN-NAME is like "news-dir/latest-news.scm"
+(define (get-plugin-rt-structure plugin-name)
+ (let ((plugin (table-ref *plugin-table* plugin-name)))
+ (if plugin
+ plugin
+ (with-fatal-error-handler*
+ (lambda (condition decline)
+ (release-lock plugin-table-lock)
+ (decline))
+ (lambda ()
+ (obtain-lock plugin-table-lock)
+ ;; load-config-file does not care about cwd(?)
+ ;; --> absolute file name needed
+ (load-config-file (absolute-file-name plugin-name))
+ ;; plugin-structure to load must be named "plugin"
+ (let ((plugin-structure (reify-structure 'plugin)))
+ (load-structure plugin-structure)
+ (table-set! *plugin-table* plugin-name plugin-structure)
+ (release-lock plugin-table-lock)
+ plugin-structure))))))
+
+(define (reset-plugin-cache!)
+ (with-fatal-error-handler*
+ (lambda (condition decline)
+ (release-lock plugin-table-lock)
+ (decline))
+ (lambda ()
+ (obtain-lock plugin-table-lock)
+ (set! *plugin-table* (make-string-table))
+ (release-lock plugin-table-lock))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SESSION
+(define *session* (make-thread-cell #f))
+
+(define (register-session! instance-id return-continuation)
+ (thread-cell-set! *session*
+ (really-make-session instance-id return-continuation)))
+
+
+;(define (save-session-return-continuation! return-continuation)
+; (set-session-instance-id! (thread-cell-ref *session*)
+; return-continuation))
+
+(define (session-instance-id)
+ (really-session-instance-id (thread-cell-ref *session*)))
+
+(define (session-return-continuation)
+ (really-session-return-continuation (thread-cell-ref *session*)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; RESUME-URL
+(define *resume-url-regexp* (rx (submatch (* (- printing ";")))
+ ";k" (submatch (* digit)) ; Instance-ID
+ ";c" (submatch (* digit)))) ; Continuation-ID
+
+(define (make-resume-url full-path instance-id continuation-id)
+ (string-append full-path
+ ";k" (number->string instance-id)
+ ";c" (number->string continuation-id)))
+
+(define (resume-url-instance-id id-url)
+ (receive (instance-id continuation-id)
+ (resume-url-ids id-url)
+ instance-id))
+
+(define (resume-url-continuation-id id-url)
+ (receive (instance-id continuation-id)
+ (resume-url-ids id-url)
+ continuation-id))
+
+(define (resume-url-ids id-url)
+ (let ((match (regexp-search *resume-url-regexp* id-url)))
+ (if match
+ (values (string->number (match:substring match 2))
+ (string->number (match:substring match 3)))
+ (error "resume-url-ids: no instance/continuation id" id-url))))
+
+(define (resume-url-servlet-name id-url)
+ (let ((match (regexp-search *resume-url-regexp* id-url)))
+ (if match
+ (match:substring match 1)
+ (error "resume-url-servlet-name: no servlet-name found"))))
+
+(define (resume-url? id-url)
+ (regexp-search? *resume-url-regexp* id-url))
+
+
diff --git a/scheme/packages.scm b/scheme/packages.scm
index b9259ec..1f5cf6c 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -696,7 +696,6 @@
fluids ; let-fluid
enumerated ; enum
architecture ; exception, os-error
-
handle-fatal-error
httpd-read-options
diff --git a/start-web-server b/start-web-server
index 1ca0952..b34563d 100755
--- a/start-web-server
+++ b/start-web-server
@@ -1,6 +1,6 @@
#!/bin/sh
echo "Loading..."
-exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
+exec scsh -lm packages.scm -lm httpd/servlets/packages.scm -dm -o http-test -e main -s "$0" "$@"
!#
(define-structure http-test
@@ -13,6 +13,7 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
seval-handler
rman-gateway
info-gateway
+ servlet-handler
let-opt
scsh
scheme)
@@ -39,13 +40,15 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
(define port #f)
(define log-file-name #f)
(define root #f)
+ (define servlet-dir #f)
(define (init)
(set! htdocs-dir "web-server/root/htdocs")
(set! cgi-bin-dir "web-server/root/cgi-bin")
(set! port "8080")
(set! log-file-name "web-server/httpd.log")
- (set! root "web-server/root"))
+ (set! root "web-server/root")
+ (set! servlet-dir "web-server/root/servlets"))
(define get-options
(let* ((unknown-option-error
@@ -67,7 +70,8 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
(set! htdocs-dir (absolute-file-name htdocs-dir))
(set! log-file-name (absolute-file-name log-file-name))
(set! cgi-bin-dir (absolute-file-name cgi-bin-dir))
- (set! port (string->number port)))
+ (set! port (string->number port))
+ (set! servlet-dir (absolute-file-name servlet-dir)))
(cond
((string=? (car options) "-h")
(if (null? (cdr options))
@@ -89,6 +93,11 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
(missing-argument-error (car options))
(set! log-file-name (cadr options)))
(loop (cddr options)))
+ ((string=? (car options) "-s")
+ (if (null? (cdr options))
+ (missing-argument-error (car options))
+ (set! servlet-dir (cadr options)))
+ (loop (cddr options)))
((string=? (car options) "--help")
(display (usage))
(exit 0))
@@ -104,6 +113,7 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
(define (main args)
(init)
+ (write args)
(get-options (cdr args))
(format #t "options read~%")
(cond ((zero? (user-uid))
@@ -137,7 +147,8 @@ exec scsh -lm packages.scm -dm -o http-test -e main -s "$0" "$@"
"Generated by rman-gateway"))
(cons "info" (info-handler #f #f #f
"Generated by info-gateway"))
- (cons "cgi-bin" (cgi-handler cgi-bin-dir)))
+ (cons "cgi-bin" (cgi-handler cgi-bin-dir))
+ (cons "servlet" (servlet-handler servlet-dir)))
(rooted-file-or-directory-handler htdocs-dir)))))))))
))
;; EOF
diff --git a/web-server/root/htdocs/index2.html b/web-server/root/htdocs/index2.html
index ecc8d6f..2ed5c55 100644
--- a/web-server/root/htdocs/index2.html
+++ b/web-server/root/htdocs/index2.html
@@ -16,6 +16,8 @@
Get the dir info page
(needs a matching info page installation;
among others, we need non-gzipped info pages)
+ A test servlet
+ News
Text file
Directory
Compressed File
@@ -28,7 +30,7 @@
-Last modified: Thu Aug 29 16:37:20 CEST 2002
+Last modified: Thu Sep 12 17:06:32 CEST 2002