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

Rename SERVLET --> SURFLET

This commit is contained in:
interp 2003-01-19 16:57:27 +00:00
parent 071b59a99f
commit 61fc543af2
25 changed files with 382 additions and 382 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
scheme/httpd/surflets/latex/surflet.tex
View File

@ -5,7 +5,7 @@
\usepackage{tex2page} \usepackage{tex2page}
\author{Andreas Bernauer \and Martin Gasbichler} \author{Andreas Bernauer \and Martin Gasbichler}
\title{The Servlet Handler of the \textit{SUnet} Web Server} \title{The SUrflet Handler of the \textit{SUnet} Web Server}
\input{../../../doc/latex/decls} \input{../../../doc/latex/decls}
\newcommand{\attrib}[1]{\textsf{#1}} \newcommand{\attrib}[1]{\textsf{#1}}
@ -14,22 +14,22 @@
\maketitle \maketitle
\begin{abstract} \begin{abstract}
\noindent The Scheme Untergrund Network Package (\textit{SUnet} for \noindent The Scheme Untergrund Network Package (\textit{SUnet} for
short) comes along with a modular web server. The servlet handler short) comes along with a modular web server. The SUrflet handler
described here extends it by the capability of writing programs in described here extends it by the capability of writing programs in
Scheme, that yield an HTML page. Scheme, that yield an HTML page.
Suspending of servlet computation. Suspending of SUrflet computation.
Using Oleg's SXML. Using Oleg's SXML.
blabla and something more. blabla and something more.
\end{abstract} \end{abstract}
\section{How to write a servlet} \section{How to write a SUrflet}
Use this skeleton to get started quickly: Use this skeleton to get started quickly:
\begin{alltt} \begin{alltt}
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open servlets (open surflets
scsh scsh
scheme scheme
; more packages... ; more packages...
@ -46,7 +46,7 @@ Use this skeleton to get started quickly:
See the examples for further informations. See the examples for further informations.
\section{The \texttt{servlets} structure} \section{The \texttt{surflets} structure}
\defun{send/suspend}{response-maker}{request} \defun{send/suspend}{response-maker}{request}
\defunx{send/finish}{response}{\noreturn} \defunx{send/finish}{response}{\noreturn}
@ -56,7 +56,7 @@ See the examples for further informations.
\defunx{send-html}{SXML}{\noreturn} \defunx{send-html}{SXML}{\noreturn}
\begin{desc} \begin{desc}
These procedures let the server send a response to the client. From These procedures let the server send a response to the client. From
the servlet's point of view, \ex{send/suspend} suspends the current the SUrflet's point of view, \ex{send/suspend} suspends the current
computation, calls \semvar{response-maker} with an argument and lets computation, calls \semvar{response-maker} with an argument and lets
the server send it to the client. \semvar{response-maker} is a the server send it to the client. \semvar{response-maker} is a
procedure getting one argument, the ``continuation address'' and procedure getting one argument, the ``continuation address'' and
@ -64,19 +64,19 @@ See the examples for further informations.
object. See the manual of the \ex{httpd} for details about object. See the manual of the \ex{httpd} for details about
generating such an object. If you use SXML, you won't need the generating such an object. If you use SXML, you won't need the
details, though. If the browser sends a request to the details, though. If the browser sends a request to the
``continuation address'', the computation of the servlet is resumed ``continuation address'', the computation of the SUrflet is resumed
and \ex{send/suspend} returns the browser's request. Note that, and \ex{send/suspend} returns the browser's request. Note that,
technically, the computation is not really suspended---it just technically, the computation is not really suspended---it just
looks this way from the servlet's point of view. looks this way from the SUrflet's point of view.
\ex{send/finish} returns the \semvar{response} to the server and \ex{send/finish} returns the \semvar{response} to the server and
finishes the computation of the servlet---\ie{} the instance of the finishes the computation of the SUrflet---\ie{} the instance of the
servlet will not accept any more requests. \semvar{response} must be SUrflet will not accept any more requests. \semvar{response} must be
a valid \ex{httpd} \ex{response} object. a valid \ex{httpd} \ex{response} object.
\ex{send} returns the \semvar{response} to the server. It does not \ex{send} returns the \semvar{response} to the server. It does not
finish the computation of the servlet, although it does not finish the computation of the SUrflet, although it does not
return---\ie{} the instance of the servlet may accept future return---\ie{} the instance of the SUrflet may accept future
requests. Usually, you won't need this procedure. requests. Usually, you won't need this procedure.
The \ex{send-html...} procedures do the same as their counterparts The \ex{send-html...} procedures do the same as their counterparts
@ -107,7 +107,7 @@ See the examples for further informations.
with this, you've been warned. with this, you've been warned.
\end{desc} \end{desc}
\dfn{servlet-form}{address \ovar{method} \ovar{attributes} \ovar{SXML \dfn{surflet-form}{address \ovar{method} \ovar{attributes} \ovar{SXML
...}}{form}{tag} ...}}{form}{tag}
\begin{desc} \begin{desc}
This creates an HTML form. Its \attrib{action} attribute will be This creates an HTML form. Its \attrib{action} attribute will be
@ -285,8 +285,8 @@ See the examples for further informations.
\defun{make-address}{}{address} \defun{make-address}{}{address}
\begin{desc} \begin{desc}
\ex{make-address} creates a return \semvar{address}, that may be \ex{make-address} creates a return \semvar{address}, that may be
used to create links in the output of the servlet. With this, the used to create links in the output of the SUrflet. With this, the
servlet can check which link was clicked by the user. SUrflet can check which link was clicked by the user.
\semvar{address} is a procedure expecting the prefix of the \semvar{address} is a procedure expecting the prefix of the
URL. Usually, it is called with the contination address given by URL. Usually, it is called with the contination address given by
\ex{send-html/suspend} (or \ex{send/suspend}). \ex{send-html/suspend} (or \ex{send/suspend}).
@ -305,14 +305,14 @@ See the examples for further informations.
\ex{make-callback}, \semvar{procedure} will be called. \ex{make-callback}, \semvar{procedure} will be called.
\end{desc} \end{desc}
\subsection{Servlet data} \subsection{SUrflet data}
\FIXME{Prolog to servlet data} \FIXME{Prolog to SUrflet data}
\defun{set-instance-data!}{new-value}{\undefined} \defun{set-instance-data!}{new-value}{\undefined}
\defunx{get-instance-data}{}{value} \defunx{get-instance-data}{}{value}
\begin{desc} \begin{desc}
\ex{set-instance-data!} saves \semvar{new-value} linked with the \ex{set-instance-data!} saves \semvar{new-value} linked with the
current instance of the servlet. \ex{get-instance-data} returns this current instance of the SUrflet. \ex{get-instance-data} returns this
linked value. linked value.
\end{desc} \end{desc}

10
scheme/httpd/surflets/load-surflet-server.scm
View File

@ -16,22 +16,22 @@
(or (getenv "SSAXPATH") (or (getenv "SSAXPATH")
(string-append ,*ASSUMED-SUNET-HOME* "/SSAX")) (string-append ,*ASSUMED-SUNET-HOME* "/SSAX"))
"/lib/packages.scm")))) "/lib/packages.scm"))))
(define *SERLVET-PACKAGE* (define *SURFLET-PACKAGE*
(in 'scsh `(run (string-append (in 'scsh `(run (string-append
(or (getenv "SUNETHOME") (or (getenv "SUNETHOME")
,*ASSUMED-SUNET-HOME*) ,*ASSUMED-SUNET-HOME*)
"/httpd/servlets/packages.scm")))) "/httpd/servlets/packages.scm"))))
(define *SERVLET-SERVER* (define *SURFLET-SERVER*
(in 'scsh `(run (string-append (in 'scsh `(run (string-append
(or (getenv "SUNETHOME") (or (getenv "SUNETHOME")
,*ASSUMED-SUNET-HOME*) ,*ASSUMED-SUNET-HOME*)
"/httpd/servlets/start-servlet-server")))) "/httpd/servlets/start-servlet-server"))))
(config `(load ,*SUNET-PACKAGE*)) (config `(load ,*SUNET-PACKAGE*))
(config `(load ,*SSAX-PACKAGE*)) (config `(load ,*SSAX-PACKAGE*))
(config `(load ,*SERLVET-PACKAGE*)) (config `(load ,*SURFLET-PACKAGE*))
(config `(load ,*SERVLET-SERVER*)) (config `(load ,*SURFLET-SERVER*))
(user) (user)
(open 'servlet-server) (open 'surflet-server)
(batch 'off) (batch 'off)
(in 'scsh '(run (display "type (server) to start the server\n"))) (in 'scsh '(run (display "type (server) to start the server\n")))

54
scheme/httpd/surflets/packages.scm
View File

@ -1,4 +1,4 @@
;; Structures and interfaces for servlets. ;; Structures and interfaces for surflets.
;; NOTE: SSAX/lib/packages.scm must be loaded before you can use this ;; NOTE: SSAX/lib/packages.scm must be loaded before you can use this
;; downloadable from http://sourceforge.net/project/showfiles.php?group_id=30687 ;; downloadable from http://sourceforge.net/project/showfiles.php?group_id=30687
;; (take the r5rs compliant version (ssax-sr5rs-plt200-4.9.tar.gz)) ;; (take the r5rs compliant version (ssax-sr5rs-plt200-4.9.tar.gz))
@ -32,7 +32,7 @@
(body (cddr expr))) (body (cddr expr)))
`(,%lambda ,(interface-value-names interface-name) ,@body)))) `(,%lambda ,(interface-value-names interface-name) ,@body))))
;(with-names-from-rt-structure servlet servlet-interface (main)) ;(with-names-from-rt-structure surflet surflet-interface (main))
(define-syntax with-names-from-rt-structure (define-syntax with-names-from-rt-structure
(lambda (expr rename compare) (lambda (expr rename compare)
(let ((%lambda (rename 'lambda)) (let ((%lambda (rename 'lambda))
@ -65,31 +65,31 @@
package-commands-internal) package-commands-internal)
(files rt-module)) (files rt-module))
(define-interface servlet-handler-interface (define-interface surflet-handler-interface
(export servlet-handler)) (export surflet-handler))
(define-interface servlet-handler/servlet-interface (define-interface surflet-handler/surflet-interface
(export send/suspend ;send and suspend (export send/suspend ;send and suspend
send/finish ;send and finish send/finish ;send and finish
send ;just send (no finish, no suspend) send ;just send (no finish, no suspend)
set-servlet-data! set-surflet-data!
get-servlet-data get-surflet-data
adjust-timeout ;adjusts timeout of current session adjust-timeout ;adjusts timeout of current session
;Without `!' because PLT ;Without `!' because PLT
;doesn't have it. ;doesn't have it.
)) ))
(define-interface servlet-handler/admin-interface (define-interface surflet-handler/admin-interface
(export get-loaded-servlets (export get-loaded-surflets
unload-servlet unload-surflet
set-options-session-lifetime set-options-session-lifetime
options-session-lifetime options-session-lifetime
set-options-cache-servlets? set-options-cache-surflets?
options-cache-servlets? options-cache-surflets?
options-servlet-path options-surflet-path
options-servlet-prefix options-surflet-prefix
get-sessions get-sessions
session-servlet-name session-surflet-name
session-memo session-memo
session-continuation-table session-continuation-table
session-continuation-table-lock session-continuation-table-lock
@ -106,9 +106,9 @@
resume-url-continuation-id)) resume-url-continuation-id))
(define-structures (define-structures
((servlet-handler servlet-handler-interface) ((surflet-handler surflet-handler-interface)
(servlet-handler/servlet servlet-handler/servlet-interface) (surflet-handler/surflet surflet-handler/surflet-interface)
(servlet-handler/admin servlet-handler/admin-interface)) (surflet-handler/admin surflet-handler/admin-interface))
(open httpd-responses (open httpd-responses
httpd-requests httpd-requests
httpd-error httpd-error
@ -138,7 +138,7 @@
(files servlet-handler)) (files servlet-handler))
(define-interface servlets-interface (define-interface surflets-interface
(export send/suspend (export send/suspend
send/finish send/finish
send send
@ -179,11 +179,11 @@
returned-via? returned-via?
make-callback make-callback
set-servlet-data! set-surflet-data!
get-servlet-data)) get-surflet-data))
(define-structure servlets servlets-interface (define-structure surflets surflets-interface
(open servlet-handler/servlet (open surflet-handler/surflet
httpd-responses httpd-responses
httpd-requests ; HTTP-URL:SEARCH httpd-requests ; HTTP-URL:SEARCH
url ; REQUEST:URL url ; REQUEST:URL
@ -203,7 +203,7 @@
scheme) scheme)
(files servlets)) (files servlets))
(define-interface servlet-interface (define-interface surflet-interface
(export main)) ; MAIN gets one parameter, the REQUEST (export main)) ; MAIN gets one parameter, the REQUEST
(define-interface shift-reset-interface (define-interface shift-reset-interface
@ -263,7 +263,7 @@
scheme) scheme)
(files profile)) (files profile))
(define-interface simple-servlet-api-interface (define-interface simple-surflet-api-interface
(export single-query (export single-query
queries queries
form-query form-query
@ -277,12 +277,12 @@
extract/single extract/single
extract)) extract))
(define-structure simple-servlet-api simple-servlet-api-interface (define-structure simple-surflet-api simple-surflet-api-interface
(open scsh (open scsh
scheme scheme
define-record-types define-record-types
let-opt let-opt
servlets surflets
(subset srfi-1 (zip filter find make-list)) (subset srfi-1 (zip filter find make-list))
handle-fatal-error handle-fatal-error
) )

8
scheme/httpd/surflets/rt-module.scm
View File

@ -5,14 +5,14 @@
;;(load-config-file "test.scm") --> nothing ;;(load-config-file "test.scm") --> nothing
;; load config file containing structure definition ;; load config file containing structure definition
;; ;;
;; (reify-structure 'servlet) --> #{Rt-stucture servlet} ;; (reify-structure 'surflet) --> #{Rt-stucture surflet}
;; gets structure info about a structure ;; gets structure info about a structure
;; ;;
;; (define servlet ##) ;; (define surflet ##)
;; (load-structure servlet) ;; (load-structure surflet)
;; loads rt-structure ;; loads rt-structure
;; ;;
;; (rt-structure-binding servlet 'main) --> value ;; (rt-structure-binding surflet 'main) --> value
;; get a binding of a structure ;; get a binding of a structure

10
scheme/httpd/surflets/simple-surflet-api.scm
View File

@ -1,4 +1,4 @@
;;; Simple Servlet API, shamelessly adapted / copied from PLT. ;;; Simple Surflet API, shamelessly adapted / copied from PLT.
;;; Copyright 2002, Andreas Bernauer ;;; Copyright 2002, Andreas Bernauer
;; Send a query, suspend the current program, and produce for an ;; Send a query, suspend the current program, and produce for an
@ -20,7 +20,7 @@
(let* ((queries (map transform-string-to-query queries)) (let* ((queries (map transform-string-to-query queries))
(req (send-html/suspend (req (send-html/suspend
(lambda (new-url) (lambda (new-url)
(generate-simple-servlet-page new-url update-text (generate-simple-surflet-page new-url update-text
title title
queries defaults)))) queries defaults))))
(bindings (get-bindings req)) (bindings (get-bindings req))
@ -42,14 +42,14 @@
(value-value (cdr query+value))) (value-value (cdr query+value)))
queries+values))))) queries+values)))))
(define (generate-simple-servlet-page new-url update-text title queries defaults) (define (generate-simple-surflet-page new-url update-text title queries defaults)
`(html `(html
(title ,title) (title ,title)
(body (@ (bgcolor "white")) (body (@ (bgcolor "white"))
(h3 ,(if update-text (h3 ,(if update-text
`(font (@ (color "red")) ,update-text) `(font (@ (color "red")) ,update-text)
title)) title))
(servlet-form ,new-url POST (surflet-form ,new-url POST
(table ,@(map (lambda (query default) (table ,@(map (lambda (query default)
(ask query 'html-table-row default)) (ask query 'html-table-row default))
queries defaults)) queries defaults))
@ -68,7 +68,7 @@
(br) (br)
(URL ,url "Continue")))))) (URL ,url "Continue"))))))
;; Post some information on a Web page, shut down the servlet and all ;; Post some information on a Web page, shut down the surflet and all
;; its continuations. ;; its continuations.
(define (final-page title . text) (define (final-page title . text)
(send-html/finish (send-html/finish

40
scheme/httpd/surflets/start-surflet-server
View File

@ -6,10 +6,10 @@ fullpath=`which $0`
sunet=${SUNETHOME:-`dirname $fullpath`/../..} sunet=${SUNETHOME:-`dirname $fullpath`/../..}
ssax=${SSAXPATH:-$sunet/SSAX} # path to SSAX ssax=${SSAXPATH:-$sunet/SSAX} # path to SSAX
exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/servlets/packages.scm -dm -o servlet-server -e main -s "$0" "$@" exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/servlets/packages.scm -dm -o surflet-server -e main -s "$0" "$@"
!# !#
(define-structure servlet-server (define-structure surflet-server
(export main ; sh jump entry point (export main ; sh jump entry point
server) ; scsh entry point server) ; scsh entry point
(open httpd-core (open httpd-core
@ -20,7 +20,7 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
; seval-handler ; seval-handler
; rman-gateway ; rman-gateway
; info-gateway ; info-gateway
servlet-handler surflet-handler
let-opt let-opt
scsh scsh
scheme) scheme)
@ -29,13 +29,13 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
(define (usage) (define (usage)
(format #f (format #f
"Usage: start-servlet-server [-h htdocs-dir] [-s servlet-dir] [-i images-dir] "Usage: start-servlet-server [-h htdocs-dir] [-s surflet-dir] [-i images-dir]
[-p port] [-l log-file-name] [-p port] [-l log-file-name]
[-r requests] [--help] [-r requests] [--help]
with with
htdocs-dir directory of html files (default: ./web-server/root/htdocs) htdocs-dir directory of html files (default: ./web-server/root/htdocs)
servlet-dir directory of servlet files (default: ./web-server/root/servlets) surflet-dir directory of SUrflet files (default: ./web-server/root/servlets)
images-dir directory of images files (default: ./web-server/root/img) images-dir directory of images files (default: ./web-server/root/img)
port port server is listening to (default: 8080) port port server is listening to (default: 8080)
log-file-name directory where to store the logfile in CLF log-file-name directory where to store the logfile in CLF
@ -43,7 +43,7 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
requests maximal amount of simultaneous requests (default 5) requests maximal amount of simultaneous requests (default 5)
--help show this help --help show this help
NOTE: This is the servlet-server. It does not support cgi-bin. NOTE: This is the SUrflet-server. It does not support cgi-bin.
" "
)) ))
@ -53,7 +53,7 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
(define port #f) (define port #f)
(define log-file-name #f) (define log-file-name #f)
(define root #f) (define root #f)
(define servlet-dir #f) (define surflet-dir #f)
(define simultaneous-requests #f) (define simultaneous-requests #f)
(define (init) (define (init)
@ -63,7 +63,7 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
(set! port "8088") (set! port "8088")
(set! log-file-name "./web-server/httpd.log") (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") (set! surflet-dir "./web-server/root/servlets")
(set! simultaneous-requests "5")) (set! simultaneous-requests "5"))
(define (normalize-options) (define (normalize-options)
@ -72,20 +72,20 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
(set! log-file-name (absolute-file-name log-file-name)) (set! log-file-name (absolute-file-name log-file-name))
; (set! cgi-bin-dir (absolute-file-name cgi-bin-dir)) ; (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)) (set! surflet-dir (absolute-file-name surflet-dir))
(set! simultaneous-requests (string->number simultaneous-requests))) (set! simultaneous-requests (string->number simultaneous-requests)))
(define get-options (define get-options
(let* ((unknown-option-error (let* ((unknown-option-error
(lambda (option) (lambda (option)
(format (error-output-port) (format (error-output-port)
"unknown option `~A'~%try `servlet-server --help'~%" "unknown option `~A'~%try `surflet-server --help'~%"
option) option)
(exit 1))) (exit 1)))
(missing-argument-error (missing-argument-error
(lambda (option) (lambda (option)
(format (error-output-port) (format (error-output-port)
"option `~A' requires an argument~%try `servlet-server --help'~%" "option `~A' requires an argument~%try `surflet-server --help'~%"
option) option)
(exit 1)))) (exit 1))))
(lambda (options) (lambda (options)
@ -105,7 +105,7 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
(loop (cddr options))) (loop (cddr options)))
((string=? (car options) "-c") ((string=? (car options) "-c")
(format (error-output-port) (format (error-output-port)
"This is the servlet server. It does not support cgi.~%") "This is the SUrflet server. It does not support cgi.~%")
; (if (null? (cdr options)) ; (if (null? (cdr options))
; (missing-argument-error (car options)) ; (missing-argument-error (car options))
; (set! cgi-bin-dir (cadr options))) ; (set! cgi-bin-dir (cadr options)))
@ -123,7 +123,7 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
((string=? (car options) "-s") ((string=? (car options) "-s")
(if (null? (cdr options)) (if (null? (cdr options))
(missing-argument-error (car options)) (missing-argument-error (car options))
(set! servlet-dir (cadr options))) (set! surflet-dir (cadr options)))
(loop (cddr options))) (loop (cddr options)))
((string=? (car options) "-r") ((string=? (car options) "-r")
(if (null? (cdr options)) (if (null? (cdr options))
@ -135,7 +135,7 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
(exit 0)) (exit 0))
((string=? (car options) "--dump") ((string=? (car options) "--dump")
(let ((image-name (if (null? (cdr options)) (let ((image-name (if (null? (cdr options))
"servlet-server" "surflet-server"
(cadr options)))) (cadr options))))
(dump-scsh-program main image-name)) (dump-scsh-program main image-name))
(exit 0)) (exit 0))
@ -155,19 +155,19 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
(set-gid (->gid "nobody")) (set-gid (->gid "nobody"))
(set-uid (->uid "nobody")))) (set-uid (->uid "nobody"))))
(format #t "Going to run Servlet server with: (format #t "Going to run SUrflet server with:
htdocs-dir: ~a htdocs-dir: ~a
servlet-dir: ~a surflet-dir: ~a
images-dir: ~a images-dir: ~a
port: ~a port: ~a
log-file-name: ~a log-file-name: ~a
a maximum of ~a simultaneous requests, syslogging activated, a maximum of ~a simultaneous requests, syslogging activated,
and home-dir-handler (public_html) activated. and home-dir-handler (public_html) activated.
NOTE: This is the Servlet server. It does not support cgi. NOTE: This is the SUrflet server. It does not support cgi.
" "
htdocs-dir htdocs-dir
servlet-dir surflet-dir
images-dir images-dir
port port
log-file-name log-file-name
@ -197,9 +197,9 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
;; should serve .SCM files as text/plain (I did ;; should serve .SCM files as text/plain (I did
;; not want to write a handler just for this file ;; not want to write a handler just for this file
;; type.) ;; type.)
(cons "source" (rooted-file-or-directory-handler servlet-dir)) (cons "source" (rooted-file-or-directory-handler surflet-dir))
(cons "img" (rooted-file-handler images-dir)) (cons "img" (rooted-file-handler images-dir))
(cons "servlet" (servlet-handler servlet-dir))) (cons "surflet" (surflet-handler surflet-dir)))
(rooted-file-or-directory-handler htdocs-dir))))))))))) (rooted-file-or-directory-handler htdocs-dir)))))))))))
)) ))
)) ))

204
scheme/httpd/surflets/surflet-handler.scm
View File

@ -1,22 +1,22 @@
;; the servlet handler ;; the surflet handler
;; Copyright Andreas Bernauer, 2002 ;; Copyright Andreas Bernauer, 2002
(define *debug* #t) (define *debug* #t)
;;; session-table: entry for every new request on a servlet page ;;; session-table: entry for every new request on a surflet page
(define-record-type session :session (define-record-type session :session
(make-session servlet-name memo (make-session surflet-name memo
continuation-table continuation-table-lock continuation-table continuation-table-lock
continuation-counter continuation-counter
servlet-data) surflet-data)
session? session?
(servlet-name session-servlet-name) (surflet-name session-surflet-name)
(memo session-memo set-session-memo!) (memo session-memo set-session-memo!)
(continuation-table session-continuation-table) (continuation-table session-continuation-table)
(continuation-table-lock session-continuation-table-lock) (continuation-table-lock session-continuation-table-lock)
(continuation-counter session-continuation-counter) (continuation-counter session-continuation-counter)
(servlet-data session-servlet-data set-session-servlet-data!)) (surflet-data session-surflet-data set-session-surflet-data!))
(define-record-type memo :memo (define-record-type memo :memo
(make-memo message value new-memo) (make-memo message value new-memo)
@ -41,33 +41,33 @@
set-instance-return-continuation!)) set-instance-return-continuation!))
(define-record-type options :options (define-record-type options :options
(make-options servlet-path servlet-prefix cache-servlets? session-lifetime) (make-options surflet-path surflet-prefix cache-surflets? session-lifetime)
options? options?
(servlet-path options:servlet-path set-options:servlet-path) (surflet-path options:surflet-path set-options:surflet-path)
(servlet-prefix options:servlet-prefix set-options:servlet-prefix) (surflet-prefix options:surflet-prefix set-options:surflet-prefix)
(cache-servlets? options:cache-servlets? set-options:cache-servlets?) (cache-surflets? options:cache-surflets? set-options:cache-surflets?)
;; session lifetime is in seconds ;; session lifetime is in seconds
(session-lifetime options:session-lifetime set-options:session-lifetime)) (session-lifetime options:session-lifetime set-options:session-lifetime))
;; Servlet-prefix is unused now. Formerly, it contained the virtual ;; Surflet-prefix is unused now. Formerly, it contained the virtual
;; path prefix for the handler. ;; path prefix for the handler.
(define (make-default-options servlet-path servlet-prefix) (define (make-default-options surflet-path surflet-prefix)
(make-options servlet-path servlet-prefix #t 600)) (make-options surflet-path surflet-prefix #t 600))
(define *options* (make-preserved-thread-fluid #f)) (define *options* (make-preserved-thread-fluid #f))
;; preserved thread fluid because between different calls to ;; preserved thread fluid because between different calls to
;; servlet-handler the options shall remain the same. ;; surflet-handler the options shall remain the same.
(define (make-fluid-selector selector) (define (make-fluid-selector selector)
(lambda () (selector (thread-fluid *options*)))) (lambda () (selector (thread-fluid *options*))))
(define (make-fluid-setter setter) (define (make-fluid-setter setter)
(lambda (value) (lambda (value)
(setter (thread-fluid *options*) value))) (setter (thread-fluid *options*) value)))
(define options-servlet-path (make-fluid-selector options:servlet-path)) (define options-surflet-path (make-fluid-selector options:surflet-path))
(define options-servlet-prefix (make-fluid-selector options:servlet-prefix)) (define options-surflet-prefix (make-fluid-selector options:surflet-prefix))
(define options-cache-servlets? (make-fluid-selector options:cache-servlets?)) (define options-cache-surflets? (make-fluid-selector options:cache-surflets?))
(define options-session-lifetime (make-fluid-selector options:session-lifetime)) (define options-session-lifetime (make-fluid-selector options:session-lifetime))
(define set-options-cache-servlets? (make-fluid-setter set-options:cache-servlets?)) (define set-options-cache-surflets? (make-fluid-setter set-options:cache-surflets?))
(define set-options-session-lifetime (make-fluid-setter set-options:session-lifetime)) (define set-options-session-lifetime (make-fluid-setter set-options:session-lifetime))
(define *session-table* (make-integer-table)) ; session-id is index (define *session-table* (make-integer-table)) ; session-id is index
@ -81,8 +81,8 @@
(lambda () (lambda ()
(random-integer 1073741824)))) ; I hope, 1+ billion is enough.... (random-integer 1073741824)))) ; I hope, 1+ billion is enough....
(define (servlet-handler servlet-path) (define (surflet-handler surflet-path)
(set-thread-fluid! *options* (make-default-options servlet-path #f)) (set-thread-fluid! *options* (make-default-options surflet-path #f))
(lambda (path req) (lambda (path req)
(if (pair? path) ; need at least one element (if (pair? path) ; need at least one element
(let ((request-method (request-method req)) (let ((request-method (request-method req))
@ -90,16 +90,16 @@
(if (or (string=? request-method "GET") (if (or (string=? request-method "GET")
(string=? request-method "POST")) (string=? request-method "POST"))
(if (resume-url? path-string) (if (resume-url? path-string)
(resume-url path-string servlet-path req) (resume-url path-string surflet-path req)
(launch-new-session path-string servlet-path req)) (launch-new-session path-string surflet-path req))
(make-error-response (status-code method-not-allowed) req (make-error-response (status-code method-not-allowed) req
request-method))) request-method)))
(make-error-response (status-code bad-request) req (make-error-response (status-code bad-request) req
(format #f "Bad path: ~s" path))))) (format #f "Bad path: ~s" path)))))
(define (launch-new-session path-string servlet-path req) (define (launch-new-session path-string surflet-path req)
(cond (cond
((file-not-exists? (absolute-file-name path-string servlet-path)) ((file-not-exists? (absolute-file-name path-string surflet-path))
(make-error-response (status-code not-found) req path-string)) (make-error-response (status-code not-found) req path-string))
((string=? (file-name-extension path-string) ".scm") ((string=? (file-name-extension path-string) ".scm")
(obtain-lock *session-table-lock*) (obtain-lock *session-table-lock*)
@ -113,37 +113,37 @@
(make-integer-table) ; continuation table (make-integer-table) ; continuation table
(make-lock) ; continuation table lock (make-lock) ; continuation table lock
(make-thread-safe-counter) ; continuation counter (make-thread-safe-counter) ; continuation counter
#f)) ; servlet-data #f)) ; surflet-data
(release-lock *session-table-lock*) (release-lock *session-table-lock*)
(register-instance! session-id 'no-return) (register-instance! session-id 'no-return)
(with-fatal-handler (with-fatal-handler
;; Catch conditions from get-servlet-rt-structure. ;; Catch conditions from get-surflet-rt-structure.
(lambda (condition decline) (lambda (condition decline)
(delete-session! session-id) (delete-session! session-id)
(bad-gateway-error-response req path-string condition)) (bad-gateway-error-response req path-string condition))
(let ((servlet (get-servlet-rt-structure path-string servlet-path))) (let ((surflet (get-surflet-rt-structure path-string surflet-path)))
(fork-thread (fork-thread
(session-surveillance session-id (session-surveillance session-id
(+ (time) (options-session-lifetime)) (+ (time) (options-session-lifetime))
memo)) memo))
(reset (reset
(with-fatal-handler (with-fatal-handler
;; Catch conditions that occur while running the servlet. ;; Catch conditions that occur while running the surflet.
(lambda (condition decline) (lambda (condition decline)
(delete-session! session-id) (delete-session! session-id)
;; Restore correct continuation with shift. ;; Restore correct continuation with shift.
(shift unused (shift unused
(bad-gateway-error-response req path-string condition))) (bad-gateway-error-response req path-string condition)))
(with-cwd servlet-path (with-cwd surflet-path
(with-names-from-rt-structure (with-names-from-rt-structure
servlet servlet-interface surflet surflet-interface
(main req))))))))) ; Launch serlvet's main procedure. (main req))))))))) ; Launch serlvet's main procedure.
(else ; We'll serve every non-scm file. (else ; We'll serve every non-scm file.
;; We need access to SEND-FILE-RESPONSE of ;; We need access to SEND-FILE-RESPONSE of
;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we ;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we
;; don't have it, so we disable this feature here. ;; don't have it, so we disable this feature here.
; (let ((full-file-name (absolute-file-name path-string servlet-path))) ; (let ((full-file-name (absolute-file-name path-string surflet-path)))
; (send-file-response full-file-name ; (send-file-response full-file-name
; (file-info full-file-name) ; (file-info full-file-name)
; req)) ; req))
@ -191,15 +191,15 @@
(status-code bad-request) req (status-code bad-request) req
(format #f (format #f
"<br> "<br>
<p>There may be several reasons, why your request for a servlet was denied: <p>There may be several reasons, why your request for a surflet was denied:
<ul> <ul>
<li>The servlet does not accept any requests any more.</li> <li>The surflet does not accept any requests any more.</li>
<li>The servlet URL has timed out.</li> <li>The surflet URL has timed out.</li>
<li>You URL is illformed.</li> <li>You URL is illformed.</li>
</ul> </ul>
</p> </p>
<p>In any case, you may try to restart the servlet from the <a href=\"~a\">beginning</a>. Your browser may also have cached an old session of this servlet. In this case, try to reload the page.</p>" <p>In any case, you may try to restart the surflet from the <a href=\"~a\">beginning</a>. Your browser may also have cached an old session of this surflet. In this case, try to reload the page.</p>"
(resume-url-servlet-name path-string))))) (resume-url-surflet-name path-string)))))
(lookup-continuation-table (lookup-continuation-table
(lambda (session continuation-table continuation-id) (lambda (session continuation-table continuation-id)
(let ((continuation-table-lock (session-continuation-table-lock session))) (let ((continuation-table-lock (session-continuation-table-lock session)))
@ -208,7 +208,7 @@
(release-lock continuation-table-lock) (release-lock continuation-table-lock)
result))))) result)))))
(lambda (path-string servlet-path req) (lambda (path-string surflet-path req)
(receive (session-id continuation-id) (receive (session-id continuation-id)
(resume-url-ids path-string) (resume-url-ids path-string)
(let ((session (session-lookup session-id))) (let ((session (session-lookup session-id)))
@ -217,7 +217,7 @@
(resume (lookup-continuation-table session continuation-table (resume (lookup-continuation-table session continuation-table
continuation-id))) continuation-id)))
(if resume (if resume
(with-cwd servlet-path (with-cwd surflet-path
(reset (reset
(begin (begin
(register-instance! session-id 'no-return) (register-instance! session-id 'no-return)
@ -242,13 +242,13 @@
(let ((continuation-id (generate-new-table-id continuations-table))) (let ((continuation-id (generate-new-table-id continuations-table)))
(table-set! continuations-table continuation-id return) (table-set! continuations-table continuation-id return)
(release-lock continuation-table-lock) (release-lock continuation-table-lock)
(let ((new-url (make-resume-url (session-servlet-name session) (let ((new-url (make-resume-url (session-surflet-name session)
session-id session-id
continuation-counter continuation-counter
continuation-id))) continuation-id)))
(make-servlet-response (response-maker new-url)))))) (make-surflet-response (response-maker new-url))))))
(make-error-response (status-code not-found) #f (make-error-response (status-code not-found) #f
"The URL refers to a servlet, whose session is no longer alive."))))) "The URL refers to a surflet, whose session is no longer alive.")))))
(define (send/finish response) (define (send/finish response)
(delete-session! (instance-session-id)) (delete-session! (instance-session-id))
@ -257,16 +257,16 @@
(define (send response) (define (send response)
(shift unsused response)) (shift unsused response))
(define (make-servlet-response response) (define (make-surflet-response response)
(let ((servlet-out-port (open-output-string)) (let ((surflet-out-port (open-output-string))
(servlet-in-port #f) ;; FIXME: no input-port available (surflet-in-port #f) ;; FIXME: no input-port available
(options #f)) ;; FIXME: No access to httpd-options :-( (options #f)) ;; FIXME: No access to httpd-options :-(
(if (writer-body? (response-body response)) (if (writer-body? (response-body response))
(begin (begin
;; Error-handler is already installed. ;; Error-handler is already installed.
;; Force string-output to resolve all send/... calls. ;; Force string-output to resolve all send/... calls.
(display-http-body (response-body response) (display-http-body (response-body response)
servlet-in-port servlet-out-port surflet-in-port surflet-out-port
options) options)
;; Create write-out-response for webserver. ;; Create write-out-response for webserver.
(make-response (make-response
@ -277,9 +277,9 @@
(response-extras response) (response-extras response)
(make-writer-body (make-writer-body
(lambda (out options) (lambda (out options)
(display (get-output-string servlet-out-port) out))))) (display (get-output-string surflet-out-port) out)))))
(make-error-response (status-code bad-gateway) #f (make-error-response (status-code bad-gateway) #f
"The servlet returned an invalid response object (no writer-body).")))) "The surflet returned an invalid response object (no writer-body)."))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -376,18 +376,18 @@
(table-set! continuation-table continuation-id #f)) (table-set! continuation-table continuation-id #f))
(release-lock continuation-table-lock))))) (release-lock continuation-table-lock)))))
(define (set-servlet-data! new-data) (define (set-surflet-data! new-data)
(let ((session (session-lookup (instance-session-id)))) (let ((session (session-lookup (instance-session-id))))
(if session (if session
(begin (begin
(set-session-servlet-data! session new-data) (set-session-surflet-data! session new-data)
#t) #t)
#f))) #f)))
(define (get-servlet-data) (define (get-surflet-data)
(let ((session (session-lookup (instance-session-id)))) (let ((session (session-lookup (instance-session-id))))
(if session (if session
(session-servlet-data session) (session-surflet-data session)
(error "Instance no longer alive.")))) (error "Instance no longer alive."))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -401,77 +401,77 @@
id))) id)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SERVLETs CACHE ;; SURFLETs CACHE
(define *servlet-table* (make-string-table)) ; path-string is index (define *surflet-table* (make-string-table)) ; path-string is index
(define *servlet-table-lock* (make-lock)) (define *surflet-table-lock* (make-lock))
;; SERVLET-NAME is like "news-dir/latest-news.scm" ;; SURFLET-NAME is like "news-dir/latest-news.scm"
(define (get-servlet-rt-structure servlet-name directory) (define (get-surflet-rt-structure surflet-name directory)
(let* ((full-servlet-name (absolute-file-name servlet-name directory)) (let* ((full-surflet-name (absolute-file-name surflet-name directory))
(load-servlet (load-surflet
(lambda (cached?) (lambda (cached?)
(with-fatal-handler* (with-fatal-handler*
(lambda (condition decline) (lambda (condition decline)
(if cached? (release-lock *servlet-table-lock*)) (if cached? (release-lock *surflet-table-lock*))
(decline)) (decline))
(lambda () (lambda ()
;; load-config-file does not care about cwd(?) ;; load-config-file does not care about cwd(?)
;; --> absolute file name needed ;; --> absolute file name needed
(load-config-file full-servlet-name) (load-config-file full-surflet-name)
;; servlet-structure to load must be named "servlet" ;; surflet-structure to load must be named "surflet"
(let ((servlet-structure (reify-structure 'servlet))) (let ((surflet-structure (reify-structure 'surflet)))
(load-structure servlet-structure) (load-structure surflet-structure)
(if cached? (if cached?
(begin (begin
(table-set! *servlet-table* full-servlet-name (table-set! *surflet-table* full-surflet-name
(cons servlet-structure (cons surflet-structure
(file-last-mod full-servlet-name))) (file-last-mod full-surflet-name)))
;; only now the lock may be released ;; only now the lock may be released
(release-lock *servlet-table-lock*))) (release-lock *surflet-table-lock*)))
servlet-structure)))))) surflet-structure))))))
(if (options-cache-servlets?) (if (options-cache-surflets?)
(begin (begin
;; The lock is only obtained and released, if servlets are ;; The lock is only obtained and released, if surflets are
;; cached. LOAD-SERVLET gets the CACHED? parameter, so ;; cached. LOAD-SURFLET gets the CACHED? parameter, so
;; nothing may happen, if in the meanwhile caching is turned ;; nothing may happen, if in the meanwhile caching is turned
;; off. ;; off.
(obtain-lock *servlet-table-lock*) (obtain-lock *surflet-table-lock*)
(let ((servlet (table-ref *servlet-table* full-servlet-name))) (let ((surflet (table-ref *surflet-table* full-surflet-name)))
(if servlet (if surflet
(if (equal? (file-last-mod full-servlet-name) (if (equal? (file-last-mod full-surflet-name)
(cdr servlet)) (cdr surflet))
(begin (begin
(release-lock *servlet-table-lock*) (release-lock *surflet-table-lock*)
(car servlet)) (car surflet))
(load-servlet #t)) (load-surflet #t))
(load-servlet #t)))) (load-surflet #t))))
(load-servlet #f)))) (load-surflet #f))))
(define (get-loaded-servlets) (define (get-loaded-surflets)
(obtain-lock *servlet-table-lock*) (obtain-lock *surflet-table-lock*)
(let ((loaded-servlets '())) (let ((loaded-surflets '()))
(table-walk (table-walk
(lambda (servlet-path rt-structure) (lambda (surflet-path rt-structure)
(set! loaded-servlets (cons servlet-path loaded-servlets))) (set! loaded-surflets (cons surflet-path loaded-surflets)))
*servlet-table*) *surflet-table*)
(release-lock *servlet-table-lock*) (release-lock *surflet-table-lock*)
loaded-servlets)) loaded-surflets))
(define (unload-servlet servlet-name) (define (unload-surflet surflet-name)
(obtain-lock *servlet-table-lock*) (obtain-lock *surflet-table-lock*)
(if (table-ref *servlet-table* servlet-name) (if (table-ref *surflet-table* surflet-name)
(table-set! *servlet-table* servlet-name #f)) (table-set! *surflet-table* surflet-name #f))
(release-lock *servlet-table-lock*)) (release-lock *surflet-table-lock*))
(define (reset-servlet-cache!) (define (reset-surflet-cache!)
(with-fatal-error-handler* (with-fatal-error-handler*
(lambda (condition decline) (lambda (condition decline)
(release-lock *servlet-table-lock*) (release-lock *surflet-table-lock*)
(decline)) (decline))
(lambda () (lambda ()
(obtain-lock *servlet-table-lock*) (obtain-lock *surflet-table-lock*)
(set! *servlet-table* (make-string-table)) (set! *surflet-table* (make-string-table))
(release-lock *servlet-table-lock*)))) (release-lock *surflet-table-lock*))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INSTANCE ;; INSTANCE
@ -522,7 +522,7 @@
(string->number (match:substring match 3))) (string->number (match:substring match 3)))
(values #f #f)))) (values #f #f))))
(define (resume-url-servlet-name id-url) (define (resume-url-surflet-name id-url)
(let ((match (regexp-search *resume-url-regexp* id-url))) (let ((match (regexp-search *resume-url-regexp* id-url)))
(if match (if match
(match:substring match 1) (match:substring match 1)
@ -562,7 +562,7 @@
;; ;;
;; Adopted from WITH-FATAL-ERROR-HANDLER, but handles everything that ;; Adopted from WITH-FATAL-ERROR-HANDLER, but handles everything that
;; is catchable. We must catch everything because we also want ;; is catchable. We must catch everything because we also want
;; exceptions (and warnings) to be catched (e.g. when the servlet is ;; exceptions (and warnings) to be catched (e.g. when the surflet is
;; loaded.) ;; loaded.)
(define (with-fatal-handler* handler thunk) (define (with-fatal-handler* handler thunk)
(call-with-current-continuation (call-with-current-continuation
@ -585,7 +585,7 @@
(define (bad-gateway-error-response req path-string condition) (define (bad-gateway-error-response req path-string condition)
(make-error-response (make-error-response
(status-code bad-gateway) req (status-code bad-gateway) req
(format #f "Error in servlet ~s." path-string) (format #f "Error in surflet ~s." path-string)
condition)) condition))

16
scheme/httpd/surflets/surflets.scm
View File

@ -1,4 +1,4 @@
;; utilities for servlet ;; utilities for surflet
;; Copyright 2002, Andreas Bernauer ;; Copyright 2002, Andreas Bernauer
(define (send-html/suspend html-tree-maker) (define (send-html/suspend html-tree-maker)
@ -6,7 +6,7 @@
(lambda (new-url) (lambda (new-url)
(make-usual-html-response (make-usual-html-response
(lambda (out options) (lambda (out options)
(display (servlet-XML->HTML #f (html-tree-maker new-url)) out)))))) (display (surflet-XML->HTML #f (html-tree-maker new-url)) out))))))
(define (send-html/finish html-tree) (define (send-html/finish html-tree)
(do-sending send/finish html-tree)) (do-sending send/finish html-tree))
@ -15,7 +15,7 @@
(do-sending send html-tree)) (do-sending send html-tree))
(define (do-sending send html-tree) (define (do-sending send html-tree)
(let ((html-page (servlet-XML->HTML #f html-tree))) (let ((html-page (surflet-XML->HTML #f html-tree)))
(send (make-usual-html-response (send (make-usual-html-response
(lambda (out options) (lambda (out options)
(display html-page out)))))) (display html-page out))))))
@ -155,7 +155,7 @@
;; adapted from Oleg's SXML-to-HTML.scm ;; adapted from Oleg's SXML-to-HTML.scm
;; extended by additional port argument ;; extended by additional port argument
(define (servlet-XML->HTML out html-tree) (define (surflet-XML->HTML out html-tree)
(formated-reply out (formated-reply out
(reformat html-tree))) (reformat html-tree)))
@ -171,20 +171,20 @@
. ,(lambda (trigger input-field) . ,(lambda (trigger input-field)
(reformat (input-field-HTML-tree input-field)))) (reformat (input-field-HTML-tree input-field))))
(servlet-form (surflet-form
;; Must do something to prevent the callback-function string to ;; Must do something to prevent the callback-function string to
;; be HTML escaped. ;; be HTML escaped.
*preorder* *preorder*
. ,(lambda (trigger call-back-function . args) . ,(lambda (trigger call-back-function . args)
(receive (parameters elems) (receive (parameters elems)
(typed-optionals (list symbol? XML-attribute?) args) (typed-optionals (list symbol? XML-attribute?) args)
(make-servlet-form call-back-function (make-surflet-form call-back-function
(car parameters) (car parameters)
(cadr parameters) (cadr parameters)
elems))))) elems)))))
)) ))
(define (make-servlet-form call-back-function method attributes elems) (define (make-surflet-form call-back-function method attributes elems)
(let ((real-method (case method (let ((real-method (case method
((get GET) "GET") ((get GET) "GET")
((post POST) "POST") ((post POST) "POST")
@ -279,7 +279,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; input-fields ;;; input-fields
;;; defines input-fields for servlets ;;; defines input-fields for surflets
(define-record-type input-field :input-field (define-record-type input-field :input-field
(real-make-input-field name transformer HTML-tree get-bindings?) (real-make-input-field name transformer HTML-tree get-bindings?)

24
scheme/httpd/surflets/web-server/root/htdocs/index.html
View File

@ -7,19 +7,19 @@
<h2>Main Menu</h2> <h2>Main Menu</h2>
Following files are available from here: Following files are available from here:
<ul> <ul>
<li><a href="servlet/news.scm">News</a></li> <li><a href="surflet/news.scm">News</a></li>
<li><a href="servlet/add-raw.scm">Adding (raw HTML version)</a></li> <li><a href="surflet/add-raw.scm">Adding (raw HTML version)</a></li>
<li><a href="servlet/add-html.scm">Adding (servlets version)</a></li> <li><a href="surflet/add-html.scm">Adding (SUrflets version)</a></li>
<li><a href="servlet/add-servlet.scm">Adding (input-field <li><a href="surflet/add-servlet.scm">Adding (input-field
version)</a></li> version)</a></li>
<li><a href="servlet/add-simple.scm">Adding (simple servlet <li><a href="surflet/add-simple.scm">Adding (simple SUrflet
version)</a></li> version)</a></li>
<li><a href="servlet/calculate.scm">Simple Calculator</a></li> <li><a href="surflet/calculate.scm">Simple Calculator</a></li>
<li><a href="servlet/byte-input.scm">Byte Input Widget</a></li> <li><a href="surflet/byte-input.scm">Byte Input Widget</a></li>
<li><a href="servlet/simple-servlet.scm">Simple Servlet</a></li> <li><a href="surflet/simple-servlet.scm">Simple SUrflet</a></li>
<li><a href="servlet/spaceship.scm">Spaceship builder</a></li> <li><a href="surflet/spaceship.scm">Spaceship builder</a></li>
<!-- <li><a href=/servlet/test.scm>A test servlet</a></li> --> <!-- <li><a href=/surflet/test.scm>A test SUrflet</a></li> -->
<li><a href="servlet/admin.scm">Servlet Administration</a></li> <li><a href="surflet/admin.scm">SUrflet Administration</a></li>
<!-- <li><a href=index.html>This file</a></li>--> <!-- <li><a href=index.html>This file</a></li>-->
</ul> </ul>
<br> <br>
@ -28,7 +28,7 @@
<hr> <hr>
<!-- Created: Thu Aug 22 16:44:16 CEST 2002 --> <!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
<!-- hhmts start --> <!-- hhmts start -->
Last modified: Sun Dec 8 19:45:23 CET 2002 Last modified: Sun Jan 19 17:34:31 CET 2003
<!-- hhmts end --> <!-- hhmts end -->
</body> </body>
</html> </html>

4
scheme/httpd/surflets/web-server/root/surflets/add-html.scm
View File

@ -1,5 +1,5 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open servlets (open surflets
httpd-requests httpd-requests
httpd-responses httpd-responses
url url

4
scheme/httpd/surflets/web-server/root/surflets/add-raw.scm
View File

@ -1,10 +1,10 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open httpd-requests ; REQUEST-URL (open httpd-requests ; REQUEST-URL
httpd-responses ; MAKE-RESPONSE httpd-responses ; MAKE-RESPONSE
parse-html-forms ; PARSE-HTML-FORM-QUERY parse-html-forms ; PARSE-HTML-FORM-QUERY
url ; HTTP-URL-SEARCH url ; HTTP-URL-SEARCH
srfi-1 ; FILTER srfi-1 ; FILTER
servlet-handler/servlet ; SEND/SUSPEND, SEND/FINISH surflet-handler/surflet ; SEND/SUSPEND, SEND/FINISH
scheme-with-scsh) scheme-with-scsh)
(begin (begin

6
scheme/httpd/surflets/web-server/root/surflets/add-servlet.scm
View File

@ -1,5 +1,5 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open servlets (open surflets
httpd-requests httpd-requests
url url
handle-fatal-error handle-fatal-error
@ -17,7 +17,7 @@
(body (body
(h2 ,title) (h2 ,title)
(p (p
(servlet-form ,new-url (surflet-form ,new-url
,input-text " " ,input-text " "
,number-input-field ,number-input-field
,(make-submit-button))) ,(make-submit-button)))

6
scheme/httpd/surflets/web-server/root/surflets/add-simple.scm
View File

@ -1,7 +1,7 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
servlets surflets
simple-servlet-api simple-surflet-api
) )
(begin (begin

18
scheme/httpd/surflets/web-server/root/surflets/admin-handler.scm
View File

@ -1,9 +1,9 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
handle-fatal-error handle-fatal-error
let-opt let-opt
servlets surflets
servlet-handler/admin surflet-handler/admin
httpd-responses httpd-responses
) )
(begin (begin
@ -12,13 +12,13 @@
(send-html/suspend (send-html/suspend
(lambda (new-url) (lambda (new-url)
`(html `(html
(title "Servlet Adminstration - Handler options") (title "SUrflet Adminstration - Handler options")
(body (body
(h1 "Servlet Administration") (h1 "SUrflet Administration")
(h2 "Handler options") (h2 "Handler options")
,(and (pair? update-text) update-text) ,(and (pair? update-text) update-text)
(p "These are the runtime configurable options of the handler:") (p "These are the runtime configurable options of the handler:")
(servlet-form (surflet-form
,new-url ,new-url
POST POST
(table (table
@ -45,9 +45,9 @@
,(:optional maybe-update-text ""))) ,(:optional maybe-update-text "")))
(number-field (number-field
(make-number-input-field (options-session-lifetime))) (make-number-input-field (options-session-lifetime)))
(cache-checkbox (make-checkbox-input-field (options-cache-servlets?))) (cache-checkbox (make-checkbox-input-field (options-cache-surflets?)))
(options `(("Current session lifetime: " ,number-field ,submit-timeout) (options `(("Current session lifetime: " ,number-field ,submit-timeout)
("Cache servlets?" ,cache-checkbox ,submit-cache))) ("Cache SUrflets?" ,cache-checkbox ,submit-cache)))
(req (get-option-change return-address update-text options)) (req (get-option-change return-address update-text options))
(bindings (get-bindings req))) (bindings (get-bindings req)))
(cond (cond
@ -69,7 +69,7 @@
(let ((cache-plugins? (if (input-field-binding cache-checkbox bindings) (let ((cache-plugins? (if (input-field-binding cache-checkbox bindings)
#t #t
#f))) #f)))
(set-options-cache-servlets? cache-plugins?) (set-options-cache-surflets? cache-plugins?)
(handler-options req (handler-options req
(format #f "Caching turned ~s." (format #f "Caching turned ~s."
(if cache-plugins? "on" "off"))))) (if cache-plugins? "on" "off")))))

42
scheme/httpd/surflets/web-server/root/surflets/admin-profiling.scm
View File

@ -1,7 +1,7 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
servlets surflets
servlet-handler/admin surflet-handler/admin
profiling profiling
handle-fatal-error handle-fatal-error
httpd-responses httpd-responses
@ -26,11 +26,11 @@
(counter state:counter set-state:counter!)) (counter state:counter set-state:counter!))
(define (state-file-name) (define (state-file-name)
(state:file-name (get-servlet-data))) (state:file-name (get-surflet-data)))
(define (state-file-names-to-delete) (define (state-file-names-to-delete)
(state:file-names-to-delete (get-servlet-data))) (state:file-names-to-delete (get-surflet-data)))
(define (state-counter) (define (state-counter)
(state:counter (get-servlet-data))) (state:counter (get-surflet-data)))
;; Leave this global. Servers are running on a single system. ;; Leave this global. Servers are running on a single system.
(define gnuplot #f) ;; Set in main. (define gnuplot #f) ;; Set in main.
@ -49,8 +49,8 @@
(send-html/suspend (send-html/suspend
(lambda (new-url) (lambda (new-url)
`(html `(html
(title "Servlet Administration -- Profiling") (title "SUrflet Administration -- Profiling")
(body (h1 "Serlvet Administration") (body (h1 "SUrflet Administration")
(h2 "Profiling") (h2 "Profiling")
(p "Note: The operations performable via this interface take a while depending on the speed of the machine the server is running. Please be patient.") (p "Note: The operations performable via this interface take a while depending on the speed of the machine the server is running. Please be patient.")
(font (@ (color "red")) ,update-text) (font (@ (color "red")) ,update-text)
@ -61,7 +61,7 @@
(li (URL ,(result-address new-url) (li (URL ,(result-address new-url)
"Show profile results") "Show profile results")
(br) (br)
(servlet-form (surflet-form
,new-url ,new-url
POST POST
(p "This uses " (var "gnuplot") " that is searched at " (p "This uses " (var "gnuplot") " that is searched at "
@ -107,7 +107,7 @@
(file-executable? gnuplot-file-name))) (file-executable? gnuplot-file-name)))
(define (new-profile req) (define (new-profile req)
(let ((state (get-servlet-data))) (let ((state (get-surflet-data)))
(format #t "profiling...~%") (format #t "profiling...~%")
(obtain-lock lock) (obtain-lock lock)
(profile-space (state:file-name state)) (profile-space (state:file-name state))
@ -118,9 +118,9 @@
(define (result req) (define (result req)
(let ((results (profile-results (state-file-name))) (let ((results (profile-results (state-file-name)))
(gnuplot-data-file-name (create-temp-file "servlet-profiling.data")) (gnuplot-data-file-name (create-temp-file "surflet-profiling.data"))
(picture-file-name (create-empty-picture-file (picture-file-name (create-empty-picture-file
"../img/servlet-profiling.picture" "../img/surflet-profiling.picture"
".pbm")) ".pbm"))
(get-total-bytes (lambda (space-info) (get-total-bytes (lambda (space-info)
(total-bytes (space-info-total space-info)))) (total-bytes (space-info-total space-info))))
@ -134,7 +134,7 @@
(<< ,(format #f "set terminal pbm color (<< ,(format #f "set terminal pbm color
set output '~a' set output '~a'
set size 0.7,0.7 set size 0.7,0.7
plot '~a' title 'Servlet Profiling ~a' with lines" plot '~a' title 'SUrflet Profiling ~a' with lines"
picture-file-name picture-file-name
gnuplot-data-file-name gnuplot-data-file-name
(format-date "~c" (date)) (format-date "~c" (date))
@ -168,9 +168,9 @@ plot '~a' title 'Servlet Profiling ~a' with lines"
(send-html/suspend (send-html/suspend
(lambda (new-url) (lambda (new-url)
`(html `(html
(title "Servlet Administration -- Profiling Results") (title "SUrflet Administration -- Profiling Results")
(body (body
(h1 "Servlet-Administration") (h1 "SUrflet-Administration")
(h2 "Profiling Results") (h2 "Profiling Results")
(h3 "Picture") (h3 "Picture")
(p "Note: The picture cannot be shown by your browser, currently. This will be fixed.") (p "Note: The picture cannot be shown by your browser, currently. This will be fixed.")
@ -200,7 +200,7 @@ plot '~a' title 'Servlet Profiling ~a' with lines"
(profile req "Profiling state reseted.")) (profile req "Profiling state reseted."))
(define (add-file-name-to-delete! file-name) (define (add-file-name-to-delete! file-name)
(let ((state (get-servlet-data))) (let ((state (get-surflet-data)))
(set-state:file-names-to-delete! (set-state:file-names-to-delete!
state state
(cons file-name (cons file-name
@ -212,18 +212,18 @@ plot '~a' title 'Servlet Profiling ~a' with lines"
(for-each delete-filesys-object file-names-to-delete)))) (for-each delete-filesys-object file-names-to-delete))))
(define (reset-profiling-state!) (define (reset-profiling-state!)
(let ((state (get-servlet-data))) (let ((state (get-surflet-data)))
(set-state:counter! state 0) (set-state:counter! state 0)
(delete-files state) (delete-files state)
(set-state:file-name! state (set-state:file-name! state
(absolute-file-name (create-temp-file "servlet-profiling"))) (absolute-file-name (create-temp-file "surflet-profiling")))
(set-state:file-names-to-delete! state (set-state:file-names-to-delete! state
(list (state:file-name state))))) (list (state:file-name state)))))
(define (reset-and-return-to-main-page req) (define (reset-and-return-to-main-page req)
;; Overhead included :-| ;; Overhead included :-|
(reset-profiling-state!) (reset-profiling-state!)
(delete-files (get-servlet-data)) (delete-files (get-surflet-data))
(return-to-main-page req)) (return-to-main-page req))
(define (return-to-main-page req) (define (return-to-main-page req)
@ -233,10 +233,10 @@ plot '~a' title 'Servlet Profiling ~a' with lines"
(define (main req) (define (main req)
;; We'll fill this out soon. ;; We'll fill this out soon.
(set! gnuplot (search-gnuplot)) (set! gnuplot (search-gnuplot))
(set-servlet-data! (make-state #f #f 0)) (set-surflet-data! (make-state #f #f 0))
(reset-profiling-state!) (reset-profiling-state!)
;; Remove state files if user did not do it. ;; Remove state files if user did not do it.
(add-finalizer! (get-servlet-data) delete-files) (add-finalizer! (get-surflet-data) delete-files)
(profile req)) (profile req))
(define (search-gnuplot) (define (search-gnuplot)

108
scheme/httpd/surflets/web-server/root/surflets/admin-servlets-cb.scm
View File

@ -1,7 +1,7 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
servlets surflets
servlet-handler/admin surflet-handler/admin
httpd-responses httpd-responses
handle-fatal-error handle-fatal-error
let-opt let-opt
@ -10,8 +10,8 @@
) )
(begin (begin
(define remove-servlet-path (define remove-surflet-path
(let ((regexp (rx ,(file-name-as-directory (options-servlet-path)) (let ((regexp (rx ,(file-name-as-directory (options-surflet-path))
(submatch (* any))))) (submatch (* any)))))
(lambda (file-name) (lambda (file-name)
(let ((match (regexp-search regexp file-name))) (let ((match (regexp-search regexp file-name)))
@ -36,7 +36,7 @@
(title ,title) (title ,title)
(body (body
,header ,header
(servlet-form (surflet-form
,new-url ,new-url
(table (table
,@(cons '(th) header-row) ,@(cons '(th) header-row)
@ -63,72 +63,72 @@
checkboxes checkboxes
table-elements))))) table-elements)))))
(define (unload-servlets outdated? servlet-names) (define (unload-surflets outdated? surflet-names)
(if-outdated outdated? (if-outdated outdated?
(show-outdated (make-callback servlets)) (show-outdated (make-callback surflets))
(for-each unload-servlet servlet-names))) (for-each unload-surflet surflet-names)))
(define (no-servlets) (define (no-surflets)
`(p "Currently, there are no servlets loaded " `(p "Currently, there are no SUrflets loaded "
(URL ,(make-callback servlets) "(reload)."))) (URL ,(make-callback surflets) "(reload).")))
(define (servlets req . maybe-update-text) (define (surflets req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(loaded-servlets (sort-list! (get-loaded-servlets) string<?)) (loaded-surflets (sort-list! (get-loaded-surflets) string<?))
(outdated? (make-outdater)) (outdated? (make-outdater))
(title "Servlet-Administration -- Servlets") (title "SUrflet-Administration -- SUrflets")
(header `((h1 "Servlet Administration") (header `((h1 "SUrflet Administration")
(h2 "Servlets") (h2 "SUrflets")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (footer `((hr)
(URL ,(make-callback return-to-main-page) "Return to main page"))) (URL ,(make-callback return-to-main-page) "Return to main page")))
(actions '("unload" "unload all" "view sessions"))) (actions '("unload" "unload all" "view sessions")))
(if (null? loaded-servlets) (if (null? loaded-surflets)
(send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer))) (send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer)))
(receive (action selected-servlets) (receive (action selected-surflets)
(select-table title ; title (select-table title ; title
header ; header header ; header
'((th "Name")) ; table-header '((th "Name")) ; table-header
loaded-servlets ; list of elements loaded-surflets ; list of elements
(lambda (servlet) ; selector (lambda (surflet) ; selector
`((td `((td
,(remove-servlet-path servlet)))) ,(remove-surflet-path surflet))))
actions ; actions to perform actions ; actions to perform
(cons ; footer (cons ; footer
`(p "Note that unloading the servlets does not imply " `(p "Note that unloading the SUrflet does not imply "
"the unloading of sessions of this servlet." "the unloading of sessions of this SUrflet."
"This can be done on the " "This can be done on the "
(URL ,(make-callback sessions) (URL ,(make-callback sessions)
"sessions adminstration page.")) "sessions adminstration page."))
footer)) footer))
(if (null? selected-servlets) (if (null? selected-surflets)
(servlets 'no-req "You must choose at least one element.") (surflets 'no-req "You must choose at least one element.")
(cond (cond
((string=? action "unload") ((string=? action "unload")
(unload-servlets outdated? selected-servlets) (unload-surflets outdated? selected-surflets)
(servlets 'no-req "Servlets unloaded.")) (surflets 'no-req "SUrflets unloaded."))
((string=? action "unload all") ((string=? action "unload all")
(unload-servlets outdated? loaded-servlets) (unload-surflets outdated? loaded-surflets)
(servlets 'no-req "Servlets unloaded.")) (surflets 'no-req "SUrflets unloaded."))
((string=? action "view sessions") ((string=? action "view sessions")
(format #t "~s~%" selected-servlets) (format #t "~s~%" selected-surflets)
(let* ((path-stripped-selected-servlets (let* ((path-stripped-selected-surflets
(map remove-servlet-path selected-servlets)) (map remove-surflet-path selected-surflets))
(selected-sessions (selected-sessions
(filter (lambda (session-pair) (filter (lambda (session-pair)
(member (session-servlet-name (cdr session-pair)) (member (session-surflet-name (cdr session-pair))
path-stripped-selected-servlets)) path-stripped-selected-surflets))
(get-sessions)))) (get-sessions))))
;; this does not return ;; this does not return
(real-sessions (sort-list! selected-sessions (real-sessions (sort-list! selected-sessions
session-servlet-name<?) session-surflet-name<?)
""))) "")))
(else (else
(error "unknown action" action)))))))) (error "unknown action" action))))))))
(define (session-servlet-name<? entry1 entry2) (define (session-surflet-name<? entry1 entry2)
(let ((name1 (session-servlet-name (cdr entry1))) (let ((name1 (session-surflet-name (cdr entry1)))
(name2 (session-servlet-name (cdr entry2)))) (name2 (session-surflet-name (cdr entry2))))
;; handle multiple session names ;; handle multiple session names
(if (string=? name1 name2) (if (string=? name1 name2)
(session-id<? entry1 entry2) (session-id<? entry1 entry2)
@ -138,26 +138,26 @@
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (session-id>? entry1 entry2) (define (session-id>? entry1 entry2)
(session-id<? entry2 entry1)) (session-id<? entry2 entry1))
(define (session-servlet-name>? entry1 entry2) (define (session-surflet-name>? entry1 entry2)
(session-servlet-name<? entry2 entry1)) (session-surflet-name<? entry2 entry1))
(define (no-current-sessions) (define (no-current-sessions)
;; Avoid using send/suspend in this context as there ;; Avoid using send/suspend in this context as there
;; are no sessions available any more. ;; are no sessions available any more.
'(p "Currently, there are no sessions, " '(p "Currently, there are no sessions, "
"i.e. the administration servlet is no longer running. " "i.e. the administration SUrflet is no longer running. "
;; Can't use callback here, as there are no valid sessions left. ;; Can't use callback here, as there are no valid sessions left.
(URL "admin.scm" "Go back to main page."))) (URL "admin.scm" "Go back to main page.")))
(define (sessions req . maybe-update-text) (define (sessions req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(current-sessions (sort-list! (get-sessions) session-servlet-name<?))) (current-sessions (sort-list! (get-sessions) session-surflet-name<?)))
(real-sessions current-sessions update-text))) (real-sessions current-sessions update-text)))
(define (real-sessions current-sessions update-text) (define (real-sessions current-sessions update-text)
(let ((outdated? (make-outdater)) (let ((outdated? (make-outdater))
(title "Servlet Adminstration - Sessions") (title "SUrflet Adminstration - Sessions")
(header `((h1 "Servlet Administration") (header `((h1 "SUrflet Administration")
(h2 "Sessions") (h2 "Sessions")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (footer `((hr)
@ -172,12 +172,12 @@
(receive (action selected-sessions) (receive (action selected-sessions)
(select-table title (select-table title
header header
`((th "Servlet Name") (th "Session-Id")) `((th "SUrflet Name") (th "Session-Id"))
current-sessions current-sessions
(lambda (session-pair) (lambda (session-pair)
(let ((session-id (car session-pair)) (let ((session-id (car session-pair))
(session-entry (cdr session-pair))) (session-entry (cdr session-pair)))
`((td ,(session-servlet-name session-entry)) `((td ,(session-surflet-name session-entry))
(td ,session-id)))) (td ,session-id))))
actions actions
footer) footer)
@ -219,7 +219,7 @@
(define (no-more-than-one-session title header1) (define (no-more-than-one-session title header1)
(send-html (send-html
`(html (title ,title) `(html (title ,title)
(body (h1 "Servlet Administration") (body (h1 "SUrflet Administration")
(p "Currently, you may only view the continuations of " (p "Currently, you may only view the continuations of "
"one session at a time. This will be changed in " "one session at a time. This will be changed in "
"future revisions. Sorry for any inconvenience.") "future revisions. Sorry for any inconvenience.")
@ -232,8 +232,8 @@
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (continuations sessions . maybe-update-text) (define (continuations sessions . maybe-update-text)
(let ((title "Servlet Adminstration - Continuations") (let ((title "SUrflet Adminstration - Continuations")
(header1 '(h1 "Servlet Administration"))) (header1 '(h1 "SUrflet Administration")))
(if (not (= 1 (length sessions))) (if (not (= 1 (length sessions)))
(no-more-than-one-session title header1) (no-more-than-one-session title header1)
(let* ((session-pair (car sessions)) (let* ((session-pair (car sessions))
@ -247,8 +247,8 @@
(header (cons header1 (header (cons header1
`((h2 "Continuations of " ,session-id) `((h2 "Continuations of " ,session-id)
(p "(belongs to the servlet '" (p "(belongs to the SUrflet '"
,(session-servlet-name session-entry) "')") ,(session-surflet-name session-entry) "')")
(p (font (@ (color "red")) ,update-text))))) (p (font (@ (color "red")) ,update-text)))))
(footer (footer
`((hr) `((hr)
@ -299,6 +299,6 @@
"admin.scm" "admin.scm"))) "admin.scm" "admin.scm")))
(define (main req) (define (main req)
(servlets req)) (surflets req))
)) ))

104
scheme/httpd/surflets/web-server/root/surflets/admin-servlets.scm
View File

@ -1,7 +1,7 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
servlets surflets
servlet-handler/admin surflet-handler/admin
httpd-responses httpd-responses
httpd-requests httpd-requests
url url
@ -12,8 +12,8 @@
) )
(begin (begin
(define remove-servlet-path (define remove-surflet-path
(let ((regexp (rx ,(file-name-as-directory (options-servlet-path)) (let ((regexp (rx ,(file-name-as-directory (options-surflet-path))
(submatch (* any))))) (submatch (* any)))))
(lambda (file-name) (lambda (file-name)
(let ((match (regexp-search regexp file-name))) (let ((match (regexp-search regexp file-name)))
@ -38,7 +38,7 @@
(title ,title) (title ,title)
(body (body
,header ,header
(servlet-form (surflet-form
,new-url ,new-url
POST POST
(table (table
@ -66,67 +66,67 @@
table-elements) table-elements)
req)))) req))))
(define (unload-servlets outdated? servlet-names) (define (unload-surflets outdated? surflet-names)
(if-outdated outdated? (if-outdated outdated?
(show-outdated (make-callback show-servlets)) (show-outdated (make-callback show-surflets))
(for-each unload-servlet servlet-names))) (for-each unload-surflet surflet-names)))
(define (no-servlets) (define (no-surflets)
`(p "Currently, there are no servlets loaded " `(p "Currently, there are no SUrflets loaded "
(URL ,(make-callback show-servlets) "(reload)") (URL ,(make-callback show-surflets) "(reload)")
", but there may be " ", but there may be "
(URL ,(make-callback show-sessions) "sessions") (URL ,(make-callback show-sessions) "sessions")
" you want to administer.")) " you want to administer."))
(define (show-servlets req . maybe-update-text) (define (show-surflets req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(loaded-servlets (sort-list! (get-loaded-servlets) string<?)) (loaded-surflets (sort-list! (get-loaded-surflets) string<?))
(outdated? (make-outdater)) (outdated? (make-outdater))
(title "Servlet-Administration -- Servlets") (title "SUrflet-Administration -- SUrflets")
(header `((h1 "Servlet Administration") (header `((h1 "SUrflet Administration")
(h2 "Servlets") (h2 "SUrflets")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `((hr) (footer `((hr)
(URL ,(make-callback return-to-main-page) "Return to administration menu.") (URL ,(make-callback return-to-main-page) "Return to administration menu.")
(br) (br)
(URL "/" "Return to main menu."))) (URL "/" "Return to main menu.")))
(actions '("unload" "unload all"))) (actions '("unload" "unload all")))
(if (null? loaded-servlets) (if (null? loaded-surflets)
(send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer))) (send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer)))
(receive (action selected-servlets req) (receive (action selected-surflets req)
(select-table title ; title (select-table title ; title
header ; header header ; header
'((th "Name")) ; table-header '((th "Name")) ; table-header
loaded-servlets ; list of elements loaded-surflets ; list of elements
(lambda (servlet) ; selector (lambda (surflet) ; selector
`((td `((td
,(remove-servlet-path servlet)))) ,(remove-surflet-path surflet))))
actions ; actions to perform actions ; actions to perform
(cons ; footer (cons ; footer
`(p "Note that unloading the servlets does not imply " `(p "Note that unloading the SUrflets does not imply "
"the unloading of sessions of this servlet. " (br) "the unloading of sessions of this SUrflet. " (br)
"This can be done on the " "This can be done on the "
(URL ,(make-callback show-sessions) (URL ,(make-callback show-sessions)
"sessions adminstration page.")) "sessions adminstration page."))
footer)) footer))
(if (not action) (if (not action)
(show-servlets 'no-req "Choose an action.") (show-surflets 'no-req "Choose an action.")
(if (and (null? selected-servlets) (if (and (null? selected-surflets)
(not (string=? action "unload all"))) (not (string=? action "unload all")))
(show-servlets 'no-req "You must choose at least one element.") (show-surflets 'no-req "You must choose at least one element.")
(cond (cond
((string=? action "unload") ((string=? action "unload")
(unload-servlets outdated? selected-servlets) (unload-surflets outdated? selected-surflets)
(show-servlets 'no-req "Servlets unloaded.")) (show-surflets 'no-req "SUrflets unloaded."))
((string=? action "unload all") ((string=? action "unload all")
(unload-servlets outdated? loaded-servlets) (unload-surflets outdated? loaded-surflets)
(show-servlets 'no-req "Servlets unloaded.")) (show-surflets 'no-req "SUrflets unloaded."))
(else (else
(error "unknown action" action))))))))) (error "unknown action" action)))))))))
(define (session-servlet-name<? entry1 entry2) (define (session-surflet-name<? entry1 entry2)
(let ((name1 (session-servlet-name (cdr entry1))) (let ((name1 (session-surflet-name (cdr entry1)))
(name2 (session-servlet-name (cdr entry2)))) (name2 (session-surflet-name (cdr entry2))))
;; handle multiple session names ;; handle multiple session names
(if (string=? name1 name2) (if (string=? name1 name2)
(session-id<? entry1 entry2) (session-id<? entry1 entry2)
@ -136,28 +136,28 @@
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (session-id>? entry1 entry2) (define (session-id>? entry1 entry2)
(session-id<? entry2 entry1)) (session-id<? entry2 entry1))
(define (session-servlet-name>? entry1 entry2) (define (session-surflet-name>? entry1 entry2)
(session-servlet-name<? entry2 entry1)) (session-surflet-name<? entry2 entry1))
(define (no-current-sessions) (define (no-current-sessions)
;; Avoid using send/suspend in this context as there ;; Avoid using send/suspend in this context as there
;; are no sessions available any more. ;; are no sessions available any more.
'(p "Currently, there are no sessions, " '(p "Currently, there are no sessions, "
"i.e. the administration servlet is no longer running. " "i.e. the administration SUrflet is no longer running. "
;; Can't use callback here, as there are no valid sessions left. ;; Can't use callback here, as there are no valid sessions left.
(URL "admin.scm" "Go back to main page."))) (URL "admin.scm" "Go back to main page.")))
(define (show-sessions req . maybe-update-text) (define (show-sessions req . maybe-update-text)
(let* ((update-text (:optional maybe-update-text "")) (let* ((update-text (:optional maybe-update-text ""))
(current-sessions (sort-list! (get-sessions) session-servlet-name<?))) (current-sessions (sort-list! (get-sessions) session-surflet-name<?)))
(real-sessions current-sessions update-text (real-sessions current-sessions update-text
(resume-url-session-id (resume-url-session-id
(last (http-url-path (request-url req))))))) (last (http-url-path (request-url req)))))))
(define (real-sessions current-sessions update-text this-session-id) (define (real-sessions current-sessions update-text this-session-id)
(let ((outdated? (make-outdater)) (let ((outdated? (make-outdater))
(title "Servlet Adminstration - Sessions") (title "SUrflet Adminstration - Sessions")
(header `((h1 "Servlet Administration") (header `((h1 "SUrflet Administration")
(h2 "Sessions") (h2 "Sessions")
(p (font (@ (color "red")) ,update-text)))) (p (font (@ (color "red")) ,update-text))))
(footer `(,(if (not (null? current-sessions)) (footer `(,(if (not (null? current-sessions))
@ -165,7 +165,7 @@
"session (id: " ,this-session-id ").") "session (id: " ,this-session-id ").")
#f) #f)
(hr) (hr)
(URL ,(make-callback show-servlets) "Return to servlets menu.") (br) (URL ,(make-callback show-surflets) "Return to SUrflets menu.") (br)
(URL ,(make-callback return-to-main-page) "Return to administration menu.") (URL ,(make-callback return-to-main-page) "Return to administration menu.")
(br) (br)
(URL "/" "Return to main menu."))) (URL "/" "Return to main menu.")))
@ -179,12 +179,12 @@
(receive (action selected-sessions req) (receive (action selected-sessions req)
(select-table title (select-table title
header header
`((th "Servlet Name") (th "Session-Id")) `((th "SUrflet Name") (th "Session-Id"))
current-sessions current-sessions
(lambda (session-pair) (lambda (session-pair)
(let ((session-id (car session-pair)) (let ((session-id (car session-pair))
(session-entry (cdr session-pair))) (session-entry (cdr session-pair)))
`((td ,(session-servlet-name session-entry)) `((td ,(session-surflet-name session-entry))
(td (@ (align "right")) ,session-id)))) (td (@ (align "right")) ,session-id))))
actions actions
footer) footer)
@ -228,7 +228,7 @@
(define (no-more-than-one-session title header1 sessions req) (define (no-more-than-one-session title header1 sessions req)
(send-html (send-html
`(html (title ,title) `(html (title ,title)
(body (h1 "Servlet Administration") (body (h1 "SUrflet Administration")
(p "Currently, you may only view the continuations of " (p "Currently, you may only view the continuations of "
"one session at a time. This will be changed in " "one session at a time. This will be changed in "
"future revisions. Sorry for any inconvenience.") "future revisions. Sorry for any inconvenience.")
@ -242,7 +242,7 @@
`(li (URL ,(make-callback `(li (URL ,(make-callback
(lambda (req) (lambda (req)
(show-continuations (list session) req))) (show-continuations (list session) req)))
,(session-servlet-name (cdr session)) ,(session-surflet-name (cdr session))
" (" ,(car session) ")"))) " (" ,(car session) ")")))
sessions))))))) sessions)))))))
@ -250,8 +250,8 @@
(< (car entry1) (car entry2))) (< (car entry1) (car entry2)))
(define (show-continuations sessions req . maybe-update-text) (define (show-continuations sessions req . maybe-update-text)
(let ((title "Servlet Adminstration - Continuations") (let ((title "SUrflet Adminstration - Continuations")
(header1 '(h1 "Servlet Administration"))) (header1 '(h1 "SUrflet Administration")))
(if (not (= 1 (length sessions))) (if (not (= 1 (length sessions)))
(no-more-than-one-session title header1 sessions req) (no-more-than-one-session title header1 sessions req)
(let* ((session-pair (car sessions)) (let* ((session-pair (car sessions))
@ -267,8 +267,8 @@
(header (cons header1 (header (cons header1
`((h2 "Continuations of " ,session-id) `((h2 "Continuations of " ,session-id)
(p "(belongs to the servlet '" (p "(belongs to the SUrflet '"
,(session-servlet-name session-entry) "')") ,(session-surflet-name session-entry) "')")
(p (font (@ (color "red")) ,update-text))))) (p (font (@ (color "red")) ,update-text)))))
(footer (footer
`(,(if (not (null? current-continuations)) `(,(if (not (null? current-continuations))
@ -276,7 +276,7 @@
"continuation (id: " ,this-continuation-id ").") "continuation (id: " ,this-continuation-id ").")
#f) #f)
(hr) (hr)
(URL ,(make-callback show-servlets) "Return to servlets menu.") (br) (URL ,(make-callback show-surflets) "Return to SUrflets menu.") (br)
(URL ,(make-callback show-sessions) "Return to sessions menu.") (br) (URL ,(make-callback show-sessions) "Return to sessions menu.") (br)
(URL ,(make-callback return-to-main-page) "Return to administration menu.") (URL ,(make-callback return-to-main-page) "Return to administration menu.")
(br) (br)
@ -332,6 +332,6 @@
"admin.scm" "admin.scm"))) "admin.scm" "admin.scm")))
(define (main req) (define (main req)
(show-servlets req)) (show-surflets req))
)) ))

14
scheme/httpd/surflets/web-server/root/surflets/admin.scm
View File

@ -1,19 +1,19 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
servlets surflets
servlet-handler/admin surflet-handler/admin
) )
(begin (begin
(define (main-page) (define (main-page)
`(html (title "Servlet Administration") `(html (title "SUrflet Administration")
(body (h1 "Servlet Administration Menu") (body (h1 "SUrflet Administration Menu")
(p "This servlet allows you to do some adminstration tasks.") (p "This SUrflet allows you to do some adminstration tasks.")
(p "Choose one of the following submenus:") (p "Choose one of the following submenus:")
(p (p
(ul (ul
(li (URL "admin-handler.scm" "Set handler options...")) (li (URL "admin-handler.scm" "Set handler options..."))
(li (URL "admin-servlets.scm" "Servlets...")) (li (URL "admin-servlets.scm" "SUrflets..."))
(li (URL "admin-profiling.scm" "Profiling...")))) (li (URL "admin-profiling.scm" "Profiling..."))))
(hr) (hr)
(p (URL "/" "Return to main menu."))))) (p (URL "/" "Return to main menu.")))))

6
scheme/httpd/surflets/web-server/root/surflets/byte-input.scm
View File

@ -1,5 +1,5 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open servlets (open surflets
httpd-requests httpd-requests
handle-fatal-error handle-fatal-error
url url
@ -50,7 +50,7 @@
(body (body
(h1 "Byte Input Widget") (h1 "Byte Input Widget")
(p "Enter your byte (msb left):") (p "Enter your byte (msb left):")
(servlet-form ,new-url (surflet-form ,new-url
,byte-input-fields ,byte-input-fields
,(make-submit-button)) ,(make-submit-button))
(hr) (hr)

8
scheme/httpd/surflets/web-server/root/surflets/calculate-cb.scm
View File

@ -1,5 +1,5 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open servlets (open surflets
httpd-requests httpd-requests
handle-fatal-error handle-fatal-error
let-opt let-opt
@ -58,7 +58,7 @@
(title "Simple calculator") (title "Simple calculator")
(body (h1 "Simple calculator") (body (h1 "Simple calculator")
(font (@ (color "red")) ,update-text) (font (@ (color "red")) ,update-text)
(servlet-form (surflet-form
,new-url ,new-url
(table (table
(tr (td "Do calculation:")) (tr (td "Do calculation:"))
@ -69,7 +69,7 @@
(td ,(make-submit-button '(@ (value "calculate"))))))) (td ,(make-submit-button '(@ (value "calculate")))))))
(hr) (hr)
(p "You may choose another operator:") (p "You may choose another operator:")
(servlet-form (surflet-form
,(change-operator-callback) ,(change-operator-callback)
(table (table
(tr (td ,operator-input-field) (tr (td ,operator-input-field)

6
scheme/httpd/surflets/web-server/root/surflets/calculate.scm
View File

@ -1,5 +1,5 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open servlets (open surflets
httpd-requests httpd-requests
handle-fatal-error handle-fatal-error
let-opt let-opt
@ -51,7 +51,7 @@
(title "Simple calculator") (title "Simple calculator")
(body (h1 "Simple calculator") (body (h1 "Simple calculator")
(font (@ (color "red")) ,update-text) (font (@ (color "red")) ,update-text)
(servlet-form (surflet-form
,new-url ,new-url
(table (table
(tr (td "Do calculation:")) (tr (td "Do calculation:"))

4
scheme/httpd/surflets/web-server/root/surflets/news.scm
View File

@ -1,6 +1,6 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
servlets) surflets)
(begin (begin
(define *news* '()) (define *news* '())

4
scheme/httpd/surflets/web-server/root/surflets/simple-servlet.scm
View File

@ -1,6 +1,6 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
simple-servlet-api) simple-surflet-api)
(begin (begin
(define (main req) (define (main req)

16
scheme/httpd/surflets/web-server/root/surflets/spaceship.scm
View File

@ -1,6 +1,6 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
servlets surflets
let-opt let-opt
receiving receiving
define-record-types define-record-types
@ -306,7 +306,7 @@
(p "Here you can build your own space ship.") (p "Here you can build your own space ship.")
(h2 "Step 1 -- Selecting components") (h2 "Step 1 -- Selecting components")
,(and update-text `(font (@ (color "red")) ,update-text)) ,(and update-text `(font (@ (color "red")) ,update-text))
(servlet-form ,new-url (surflet-form ,new-url
GET GET
(table (table
(tr (@ (valign "top")) (tr (@ (valign "top"))
@ -331,7 +331,7 @@
will have. The builder will add as many treatment beds and accomodations as necessary to will have. The builder will add as many treatment beds and accomodations as necessary to
fullfill UFP Spaceship Crew's Rights Act 023/1000285.0/AB") fullfill UFP Spaceship Crew's Rights Act 023/1000285.0/AB")
,(print-update update-text) ,(print-update update-text)
(servlet-form ,new-url (surflet-form ,new-url
GET GET
(table (table
(tr (td "My ship is for a crew of ") (tr (td "My ship is for a crew of ")
@ -361,7 +361,7 @@ specify a positive number.")
`(html `(html
,(make-title) ,(make-title)
(body (body
(servlet-form ,new-url (surflet-form ,new-url
GET GET
,(if (and checkboxes+text energy-input) ,(if (and checkboxes+text energy-input)
`((h2 "Step 3 -- Specify arming") `((h2 "Step 3 -- Specify arming")
@ -429,7 +429,7 @@ specify a positive number.")
,@(map (lambda (extra-text) ,@(map (lambda (extra-text)
`(li ,extra-text)) `(li ,extra-text))
extras)) extras))
(servlet-form ,new-url (surflet-form ,new-url
POST POST
,(make-submit-button "Order now")) ,(make-submit-button "Order now"))
,(return-links first-page-return-link main-return-link)))) ,(return-links first-page-return-link main-return-link))))
@ -443,7 +443,7 @@ specify a positive number.")
(h2 "Step 5 -- Extras") (h2 "Step 5 -- Extras")
(p "Select one or more extras that are available for (p "Select one or more extras that are available for
spaceships of class " ,class ":") spaceships of class " ,class ":")
(servlet-form ,new-url (surflet-form ,new-url
GET GET
(table ,@(map (lambda (checkbox+text) (table ,@(map (lambda (checkbox+text)
`(tr (td ,(car checkbox+text)) `(tr (td ,(car checkbox+text))
@ -474,7 +474,7 @@ spaceships of class " ,class ":")
`(URL ,prev "Return to previous page.")) `(URL ,prev "Return to previous page."))
(define first-page-return-link (define first-page-return-link
'(URL "/servlet/spaceship.scm" "Return to spaceship builder entry page.")) '(URL "/surflet/spaceship.scm" "Return to spaceship builder entry page."))
(define (return-links . links) (define (return-links . links)
`(p `(p

8
scheme/httpd/surflets/web-server/root/surflets/test.scm
View File

@ -1,6 +1,6 @@
(define-structure servlet servlet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
servlets surflets
httpd-responses) httpd-responses)
(begin (begin
(define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2)))) (define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2))))
@ -8,8 +8,8 @@
(define (main req) (define (main req)
(let ((req (send-html/suspend (let ((req (send-html/suspend
(lambda (new-url) (lambda (new-url)
`(html (body (h1 "This is from servlet") `(html (body (h1 "This is from SUrflet")
(servlet-form (surflet-form
,new-url ,new-url
POST POST
,select ,select