first shot on adding servlets to HTTPD
This commit is contained in:
interp
parent
becf14ce30
commit
d5b2b448d9
|
|
@ -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))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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.<BR>
|
||||
You can try starting at the <A HREF=~a>beginning</a>."
|
||||
(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))
|
||||
|
||||
|
||||
|
|
@ -697,7 +697,6 @@
|
|||
enumerated ; enum
|
||||
architecture ; exception, os-error
|
||||
|
||||
|
||||
handle-fatal-error
|
||||
httpd-read-options
|
||||
httpd-error
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -16,6 +16,8 @@
|
|||
<li><a href=info?(dir)Top>Get the dir info page</a><br>
|
||||
(needs a matching info page installation;<br>
|
||||
among others, we need non-gzipped info pages)</li>
|
||||
<li><a href=/servlet/test.scm>A test servlet</a></li>
|
||||
<li><a href=/servlet/news.scm>News</a></li>
|
||||
<li><a href=files/text.txt>Text file</a></li>
|
||||
<li><a href=files>Directory</a></li>
|
||||
<li><a href=files/zipped.gz>Compressed File</a></li>
|
||||
|
|
@ -28,7 +30,7 @@
|
|||
<hr>
|
||||
<!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
|
||||
<!-- hhmts start -->
|
||||
Last modified: Thu Aug 29 16:37:20 CEST 2002
|
||||
Last modified: Thu Sep 12 17:06:32 CEST 2002
|
||||
<!-- hhmts end -->
|
||||
</body>
|
||||
</html>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
"<HTML><BODY><H1>THAT'S IT<H1><P>
|
||||
That's it...</BODY></HTML>")))))
|
||||
(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
|
||||
"<HTML><BODY><H1>~a<H1><P>
|
||||
<A href=~a>read more...</A></BODY></HTML>"
|
||||
next-line
|
||||
next-url))))))
|
||||
(loop)))))))
|
||||
))
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
Bin Laden still alive!
|
||||
Mahadma Ghandi's grave stolen!
|
||||
MAKE MONEY FAST!
|
||||
Get mor bucks!!!
|
||||
|
|
@ -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 "<HTML><BODY><H1>THIS IS FROM SERVLET</H1></BODY></HTML>~%")))))))
|
||||
|
||||
Loading…
Reference in New Issue