From d5b2b448d928b05e87d62e1dd304caf6c034f0bb Mon Sep 17 00:00:00 2001 From: interp Date: Fri, 13 Sep 2002 07:21:19 +0000 Subject: [PATCH] first shot on adding servlets to HTTPD --- scheme/httpd/surflets/packages.scm | 95 +++++++++ scheme/httpd/surflets/rt-module.scm | 58 +++++ scheme/httpd/surflets/surflet-handler.scm | 245 ++++++++++++++++++++++ scheme/packages.scm | 1 - start-web-server | 19 +- web-server/root/htdocs/index2.html | 4 +- web-server/root/surflets/news.scm | 42 ++++ web-server/root/surflets/news.txt | 4 + web-server/root/surflets/test.scm | 16 ++ 9 files changed, 478 insertions(+), 6 deletions(-) create mode 100644 scheme/httpd/surflets/packages.scm create mode 100644 scheme/httpd/surflets/rt-module.scm create mode 100644 scheme/httpd/surflets/surflet-handler.scm create mode 100644 web-server/root/surflets/news.scm create mode 100644 web-server/root/surflets/news.txt create mode 100644 web-server/root/surflets/test.scm 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 diff --git a/web-server/root/surflets/news.scm b/web-server/root/surflets/news.scm new file mode 100644 index 0000000..20b64b6 --- /dev/null +++ b/web-server/root/surflets/news.scm @@ -0,0 +1,42 @@ +(define-structure plugin plugin-interface + (open scsh + scheme + plugin-utilities + httpd-responses + crlf-io) + (begin + (define (main req) + (let ((news-input (open-input-file "news.txt"))) + (let loop () + (let ((next-line (read-crlf-line news-input))) + (if (eof-object? next-line) + (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

    +That's it..."))))) + (begin + (send/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 + "

    ~a

    +read more..." + next-line + next-url)))))) + (loop))))))) + )) diff --git a/web-server/root/surflets/news.txt b/web-server/root/surflets/news.txt new file mode 100644 index 0000000..422c9a7 --- /dev/null +++ b/web-server/root/surflets/news.txt @@ -0,0 +1,4 @@ +Bin Laden still alive! +Mahadma Ghandi's grave stolen! +MAKE MONEY FAST! +Get mor bucks!!! diff --git a/web-server/root/surflets/test.scm b/web-server/root/surflets/test.scm new file mode 100644 index 0000000..da2b9ba --- /dev/null +++ b/web-server/root/surflets/test.scm @@ -0,0 +1,16 @@ +(define-structure plugin plugin-interface + (open scsh + scheme + httpd-responses) + (begin + (define (main send/suspend) + (make-response + http-status/ok + (status-code->text http-status/ok) + (time) + "text/html" + '() + (make-writer-body + (lambda (out options) + (format out "

    THIS IS FROM SERVLET

    ~%"))))))) + \ No newline at end of file