scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

first shot on adding servlets to HTTPD

This commit is contained in:
interp 2002-09-13 07:21:19 +00:00
parent becf14ce30
commit d5b2b448d9
9 changed files with 478 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
scheme/httpd/surflets/packages.scm Normal file
View File

@ -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))

58
scheme/httpd/surflets/rt-module.scm Normal file
View File

@ -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)))

245
scheme/httpd/surflets/surflet-handler.scm Normal file
View File

@ -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))

1
scheme/packages.scm
View File

@ -696,7 +696,6 @@
fluids ; let-fluid
enumerated ; enum
architecture ; exception, os-error
handle-fatal-error
httpd-read-options

19
start-web-server
View File

@ -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

4
web-server/root/htdocs/index2.html
View File

@ -16,6 +16,8 @@
<li><a href=info?(dir)Top>Get the dir info page</a><br>
(needs a matching info page installation;<br>
&nbsp;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>

42
web-server/root/surflets/news.scm Normal file
View File

@ -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)))))))
))

4
web-server/root/surflets/news.txt Normal file
View File

@ -0,0 +1,4 @@
Bin Laden still alive!
Mahadma Ghandi's grave stolen!
MAKE MONEY FAST!
Get mor bucks!!!

16
web-server/root/surflets/test.scm Normal file
View File

@ -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>~%")))))))