Rename SERVLET --> SURFLET
This commit is contained in:
interp
parent
071b59a99f
commit
61fc543af2
|
|
@ -5,7 +5,7 @@
|
|||
\usepackage{tex2page}
|
||||
|
||||
\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}
|
||||
\newcommand{\attrib}[1]{\textsf{#1}}
|
||||
|
|
@ -14,22 +14,22 @@
|
|||
\maketitle
|
||||
\begin{abstract}
|
||||
\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
|
||||
Scheme, that yield an HTML page.
|
||||
|
||||
Suspending of servlet computation.
|
||||
Suspending of SUrflet computation.
|
||||
Using Oleg's SXML.
|
||||
|
||||
blabla and something more.
|
||||
\end{abstract}
|
||||
|
||||
\section{How to write a servlet}
|
||||
\section{How to write a SUrflet}
|
||||
|
||||
Use this skeleton to get started quickly:
|
||||
\begin{alltt}
|
||||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
scsh
|
||||
scheme
|
||||
; more packages...
|
||||
|
|
@ -46,7 +46,7 @@ Use this skeleton to get started quickly:
|
|||
|
||||
See the examples for further informations.
|
||||
|
||||
\section{The \texttt{servlets} structure}
|
||||
\section{The \texttt{surflets} structure}
|
||||
|
||||
\defun{send/suspend}{response-maker}{request}
|
||||
\defunx{send/finish}{response}{\noreturn}
|
||||
|
|
@ -56,7 +56,7 @@ See the examples for further informations.
|
|||
\defunx{send-html}{SXML}{\noreturn}
|
||||
\begin{desc}
|
||||
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
|
||||
the server send it to the client. \semvar{response-maker} is a
|
||||
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
|
||||
generating such an object. If you use SXML, you won't need 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,
|
||||
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
|
||||
finishes the computation of the servlet---\ie{} the instance of the
|
||||
servlet will not accept any more requests. \semvar{response} must be
|
||||
finishes the computation of the SUrflet---\ie{} the instance of the
|
||||
SUrflet will not accept any more requests. \semvar{response} must be
|
||||
a valid \ex{httpd} \ex{response} object.
|
||||
|
||||
\ex{send} returns the \semvar{response} to the server. It does not
|
||||
finish the computation of the servlet, although it does not
|
||||
return---\ie{} the instance of the servlet may accept future
|
||||
finish the computation of the SUrflet, although it does not
|
||||
return---\ie{} the instance of the SUrflet may accept future
|
||||
requests. Usually, you won't need this procedure.
|
||||
|
||||
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.
|
||||
\end{desc}
|
||||
|
||||
\dfn{servlet-form}{address \ovar{method} \ovar{attributes} \ovar{SXML
|
||||
\dfn{surflet-form}{address \ovar{method} \ovar{attributes} \ovar{SXML
|
||||
...}}{form}{tag}
|
||||
\begin{desc}
|
||||
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}
|
||||
\begin{desc}
|
||||
\ex{make-address} creates a return \semvar{address}, that may be
|
||||
used to create links in the output of the servlet. With this, the
|
||||
servlet can check which link was clicked by the user.
|
||||
used to create links in the output of the SUrflet. With this, the
|
||||
SUrflet can check which link was clicked by the user.
|
||||
\semvar{address} is a procedure expecting the prefix of the
|
||||
URL. Usually, it is called with the contination address given by
|
||||
\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.
|
||||
\end{desc}
|
||||
|
||||
\subsection{Servlet data}
|
||||
\FIXME{Prolog to servlet data}
|
||||
\subsection{SUrflet data}
|
||||
\FIXME{Prolog to SUrflet data}
|
||||
|
||||
\defun{set-instance-data!}{new-value}{\undefined}
|
||||
\defunx{get-instance-data}{}{value}
|
||||
\begin{desc}
|
||||
\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.
|
||||
\end{desc}
|
||||
|
||||
|
|
|
|||
|
|
@ -16,22 +16,22 @@
|
|||
(or (getenv "SSAXPATH")
|
||||
(string-append ,*ASSUMED-SUNET-HOME* "/SSAX"))
|
||||
"/lib/packages.scm"))))
|
||||
(define *SERLVET-PACKAGE*
|
||||
(define *SURFLET-PACKAGE*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SUNETHOME")
|
||||
,*ASSUMED-SUNET-HOME*)
|
||||
"/httpd/servlets/packages.scm"))))
|
||||
(define *SERVLET-SERVER*
|
||||
(define *SURFLET-SERVER*
|
||||
(in 'scsh `(run (string-append
|
||||
(or (getenv "SUNETHOME")
|
||||
,*ASSUMED-SUNET-HOME*)
|
||||
"/httpd/servlets/start-servlet-server"))))
|
||||
(config `(load ,*SUNET-PACKAGE*))
|
||||
(config `(load ,*SSAX-PACKAGE*))
|
||||
(config `(load ,*SERLVET-PACKAGE*))
|
||||
(config `(load ,*SERVLET-SERVER*))
|
||||
(config `(load ,*SURFLET-PACKAGE*))
|
||||
(config `(load ,*SURFLET-SERVER*))
|
||||
(user)
|
||||
(open 'servlet-server)
|
||||
(open 'surflet-server)
|
||||
(batch 'off)
|
||||
(in 'scsh '(run (display "type (server) to start the server\n")))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;; downloadable from http://sourceforge.net/project/showfiles.php?group_id=30687
|
||||
;; (take the r5rs compliant version (ssax-sr5rs-plt200-4.9.tar.gz))
|
||||
|
|
@ -32,7 +32,7 @@
|
|||
(body (cddr expr)))
|
||||
`(,%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
|
||||
(lambda (expr rename compare)
|
||||
(let ((%lambda (rename 'lambda))
|
||||
|
|
@ -65,31 +65,31 @@
|
|||
package-commands-internal)
|
||||
(files rt-module))
|
||||
|
||||
(define-interface servlet-handler-interface
|
||||
(export servlet-handler))
|
||||
(define-interface surflet-handler-interface
|
||||
(export surflet-handler))
|
||||
|
||||
(define-interface servlet-handler/servlet-interface
|
||||
(define-interface surflet-handler/surflet-interface
|
||||
(export send/suspend ;send and suspend
|
||||
send/finish ;send and finish
|
||||
send ;just send (no finish, no suspend)
|
||||
set-servlet-data!
|
||||
get-servlet-data
|
||||
set-surflet-data!
|
||||
get-surflet-data
|
||||
adjust-timeout ;adjusts timeout of current session
|
||||
;Without `!' because PLT
|
||||
;doesn't have it.
|
||||
))
|
||||
|
||||
(define-interface servlet-handler/admin-interface
|
||||
(export get-loaded-servlets
|
||||
unload-servlet
|
||||
(define-interface surflet-handler/admin-interface
|
||||
(export get-loaded-surflets
|
||||
unload-surflet
|
||||
set-options-session-lifetime
|
||||
options-session-lifetime
|
||||
set-options-cache-servlets?
|
||||
options-cache-servlets?
|
||||
options-servlet-path
|
||||
options-servlet-prefix
|
||||
set-options-cache-surflets?
|
||||
options-cache-surflets?
|
||||
options-surflet-path
|
||||
options-surflet-prefix
|
||||
get-sessions
|
||||
session-servlet-name
|
||||
session-surflet-name
|
||||
session-memo
|
||||
session-continuation-table
|
||||
session-continuation-table-lock
|
||||
|
|
@ -106,9 +106,9 @@
|
|||
resume-url-continuation-id))
|
||||
|
||||
(define-structures
|
||||
((servlet-handler servlet-handler-interface)
|
||||
(servlet-handler/servlet servlet-handler/servlet-interface)
|
||||
(servlet-handler/admin servlet-handler/admin-interface))
|
||||
((surflet-handler surflet-handler-interface)
|
||||
(surflet-handler/surflet surflet-handler/surflet-interface)
|
||||
(surflet-handler/admin surflet-handler/admin-interface))
|
||||
(open httpd-responses
|
||||
httpd-requests
|
||||
httpd-error
|
||||
|
|
@ -138,7 +138,7 @@
|
|||
(files servlet-handler))
|
||||
|
||||
|
||||
(define-interface servlets-interface
|
||||
(define-interface surflets-interface
|
||||
(export send/suspend
|
||||
send/finish
|
||||
send
|
||||
|
|
@ -179,11 +179,11 @@
|
|||
returned-via?
|
||||
make-callback
|
||||
|
||||
set-servlet-data!
|
||||
get-servlet-data))
|
||||
set-surflet-data!
|
||||
get-surflet-data))
|
||||
|
||||
(define-structure servlets servlets-interface
|
||||
(open servlet-handler/servlet
|
||||
(define-structure surflets surflets-interface
|
||||
(open surflet-handler/surflet
|
||||
httpd-responses
|
||||
httpd-requests ; HTTP-URL:SEARCH
|
||||
url ; REQUEST:URL
|
||||
|
|
@ -203,7 +203,7 @@
|
|||
scheme)
|
||||
(files servlets))
|
||||
|
||||
(define-interface servlet-interface
|
||||
(define-interface surflet-interface
|
||||
(export main)) ; MAIN gets one parameter, the REQUEST
|
||||
|
||||
(define-interface shift-reset-interface
|
||||
|
|
@ -263,7 +263,7 @@
|
|||
scheme)
|
||||
(files profile))
|
||||
|
||||
(define-interface simple-servlet-api-interface
|
||||
(define-interface simple-surflet-api-interface
|
||||
(export single-query
|
||||
queries
|
||||
form-query
|
||||
|
|
@ -277,12 +277,12 @@
|
|||
extract/single
|
||||
extract))
|
||||
|
||||
(define-structure simple-servlet-api simple-servlet-api-interface
|
||||
(define-structure simple-surflet-api simple-surflet-api-interface
|
||||
(open scsh
|
||||
scheme
|
||||
define-record-types
|
||||
let-opt
|
||||
servlets
|
||||
surflets
|
||||
(subset srfi-1 (zip filter find make-list))
|
||||
handle-fatal-error
|
||||
)
|
||||
|
|
|
|||
|
|
@ -5,14 +5,14 @@
|
|||
;;(load-config-file "test.scm") --> nothing
|
||||
;; load config file containing structure definition
|
||||
;;
|
||||
;; (reify-structure 'servlet) --> #{Rt-stucture servlet}
|
||||
;; (reify-structure 'surflet) --> #{Rt-stucture surflet}
|
||||
;; gets structure info about a structure
|
||||
;;
|
||||
;; (define servlet ##)
|
||||
;; (load-structure servlet)
|
||||
;; (define surflet ##)
|
||||
;; (load-structure surflet)
|
||||
;; loads rt-structure
|
||||
;;
|
||||
;; (rt-structure-binding servlet 'main) --> value
|
||||
;; (rt-structure-binding surflet 'main) --> value
|
||||
;; get a binding of a structure
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;; Simple Servlet API, shamelessly adapted / copied from PLT.
|
||||
;;; Simple Surflet API, shamelessly adapted / copied from PLT.
|
||||
;;; Copyright 2002, Andreas Bernauer
|
||||
|
||||
;; Send a query, suspend the current program, and produce for an
|
||||
|
|
@ -20,7 +20,7 @@
|
|||
(let* ((queries (map transform-string-to-query queries))
|
||||
(req (send-html/suspend
|
||||
(lambda (new-url)
|
||||
(generate-simple-servlet-page new-url update-text
|
||||
(generate-simple-surflet-page new-url update-text
|
||||
title
|
||||
queries defaults))))
|
||||
(bindings (get-bindings req))
|
||||
|
|
@ -42,14 +42,14 @@
|
|||
(value-value (cdr query+value)))
|
||||
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
|
||||
(title ,title)
|
||||
(body (@ (bgcolor "white"))
|
||||
(h3 ,(if update-text
|
||||
`(font (@ (color "red")) ,update-text)
|
||||
title))
|
||||
(servlet-form ,new-url POST
|
||||
(surflet-form ,new-url POST
|
||||
(table ,@(map (lambda (query default)
|
||||
(ask query 'html-table-row default))
|
||||
queries defaults))
|
||||
|
|
@ -68,7 +68,7 @@
|
|||
(br)
|
||||
(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.
|
||||
(define (final-page title . text)
|
||||
(send-html/finish
|
||||
|
|
|
|||
|
|
@ -6,10 +6,10 @@ fullpath=`which $0`
|
|||
sunet=${SUNETHOME:-`dirname $fullpath`/../..}
|
||||
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
|
||||
server) ; scsh entry point
|
||||
(open httpd-core
|
||||
|
|
@ -20,7 +20,7 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
|
|||
; seval-handler
|
||||
; rman-gateway
|
||||
; info-gateway
|
||||
servlet-handler
|
||||
surflet-handler
|
||||
let-opt
|
||||
scsh
|
||||
scheme)
|
||||
|
|
@ -29,13 +29,13 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
|
|||
|
||||
(define (usage)
|
||||
(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]
|
||||
[-r requests] [--help]
|
||||
|
||||
with
|
||||
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)
|
||||
port port server is listening to (default: 8080)
|
||||
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)
|
||||
--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 log-file-name #f)
|
||||
(define root #f)
|
||||
(define servlet-dir #f)
|
||||
(define surflet-dir #f)
|
||||
(define simultaneous-requests #f)
|
||||
|
||||
(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! log-file-name "./web-server/httpd.log")
|
||||
(set! root "./web-server/root")
|
||||
(set! servlet-dir "./web-server/root/servlets")
|
||||
(set! surflet-dir "./web-server/root/servlets")
|
||||
(set! simultaneous-requests "5"))
|
||||
|
||||
(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! cgi-bin-dir (absolute-file-name cgi-bin-dir))
|
||||
(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)))
|
||||
|
||||
(define get-options
|
||||
(let* ((unknown-option-error
|
||||
(lambda (option)
|
||||
(format (error-output-port)
|
||||
"unknown option `~A'~%try `servlet-server --help'~%"
|
||||
"unknown option `~A'~%try `surflet-server --help'~%"
|
||||
option)
|
||||
(exit 1)))
|
||||
(missing-argument-error
|
||||
(lambda (option)
|
||||
(format (error-output-port)
|
||||
"option `~A' requires an argument~%try `servlet-server --help'~%"
|
||||
"option `~A' requires an argument~%try `surflet-server --help'~%"
|
||||
option)
|
||||
(exit 1))))
|
||||
(lambda (options)
|
||||
|
|
@ -105,7 +105,7 @@ exec scsh -lm $sunet/packages.scm -lm $ssax/lib/packages.scm -lm $sunet/httpd/se
|
|||
(loop (cddr options)))
|
||||
((string=? (car options) "-c")
|
||||
(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))
|
||||
; (missing-argument-error (car 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")
|
||||
(if (null? (cdr options))
|
||||
(missing-argument-error (car options))
|
||||
(set! servlet-dir (cadr options)))
|
||||
(set! surflet-dir (cadr options)))
|
||||
(loop (cddr options)))
|
||||
((string=? (car options) "-r")
|
||||
(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))
|
||||
((string=? (car options) "--dump")
|
||||
(let ((image-name (if (null? (cdr options))
|
||||
"servlet-server"
|
||||
"surflet-server"
|
||||
(cadr options))))
|
||||
(dump-scsh-program main image-name))
|
||||
(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-uid (->uid "nobody"))))
|
||||
|
||||
(format #t "Going to run Servlet server with:
|
||||
(format #t "Going to run SUrflet server with:
|
||||
htdocs-dir: ~a
|
||||
servlet-dir: ~a
|
||||
surflet-dir: ~a
|
||||
images-dir: ~a
|
||||
port: ~a
|
||||
log-file-name: ~a
|
||||
a maximum of ~a simultaneous requests, syslogging 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
|
||||
servlet-dir
|
||||
surflet-dir
|
||||
images-dir
|
||||
port
|
||||
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
|
||||
;; not want to write a handler just for this file
|
||||
;; 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 "servlet" (servlet-handler servlet-dir)))
|
||||
(cons "surflet" (surflet-handler surflet-dir)))
|
||||
(rooted-file-or-directory-handler htdocs-dir)))))))))))
|
||||
))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -1,22 +1,22 @@
|
|||
;; the servlet handler
|
||||
;; the surflet handler
|
||||
;; Copyright Andreas Bernauer, 2002
|
||||
|
||||
|
||||
(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
|
||||
(make-session servlet-name memo
|
||||
(make-session surflet-name memo
|
||||
continuation-table continuation-table-lock
|
||||
continuation-counter
|
||||
servlet-data)
|
||||
surflet-data)
|
||||
session?
|
||||
(servlet-name session-servlet-name)
|
||||
(surflet-name session-surflet-name)
|
||||
(memo session-memo set-session-memo!)
|
||||
(continuation-table session-continuation-table)
|
||||
(continuation-table-lock session-continuation-table-lock)
|
||||
(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
|
||||
(make-memo message value new-memo)
|
||||
|
|
@ -41,33 +41,33 @@
|
|||
set-instance-return-continuation!))
|
||||
|
||||
(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?
|
||||
(servlet-path options:servlet-path set-options:servlet-path)
|
||||
(servlet-prefix options:servlet-prefix set-options:servlet-prefix)
|
||||
(cache-servlets? options:cache-servlets? set-options:cache-servlets?)
|
||||
(surflet-path options:surflet-path set-options:surflet-path)
|
||||
(surflet-prefix options:surflet-prefix set-options:surflet-prefix)
|
||||
(cache-surflets? options:cache-surflets? set-options:cache-surflets?)
|
||||
;; session lifetime is in seconds
|
||||
(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.
|
||||
(define (make-default-options servlet-path servlet-prefix)
|
||||
(make-options servlet-path servlet-prefix #t 600))
|
||||
(define (make-default-options surflet-path surflet-prefix)
|
||||
(make-options surflet-path surflet-prefix #t 600))
|
||||
|
||||
(define *options* (make-preserved-thread-fluid #f))
|
||||
;; 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)
|
||||
(lambda () (selector (thread-fluid *options*))))
|
||||
(define (make-fluid-setter setter)
|
||||
(lambda (value)
|
||||
(setter (thread-fluid *options*) value)))
|
||||
(define options-servlet-path (make-fluid-selector options:servlet-path))
|
||||
(define options-servlet-prefix (make-fluid-selector options:servlet-prefix))
|
||||
(define options-cache-servlets? (make-fluid-selector options:cache-servlets?))
|
||||
(define options-surflet-path (make-fluid-selector options:surflet-path))
|
||||
(define options-surflet-prefix (make-fluid-selector options:surflet-prefix))
|
||||
(define options-cache-surflets? (make-fluid-selector options:cache-surflets?))
|
||||
(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 *session-table* (make-integer-table)) ; session-id is index
|
||||
|
|
@ -81,8 +81,8 @@
|
|||
(lambda ()
|
||||
(random-integer 1073741824)))) ; I hope, 1+ billion is enough....
|
||||
|
||||
(define (servlet-handler servlet-path)
|
||||
(set-thread-fluid! *options* (make-default-options servlet-path #f))
|
||||
(define (surflet-handler surflet-path)
|
||||
(set-thread-fluid! *options* (make-default-options surflet-path #f))
|
||||
(lambda (path req)
|
||||
(if (pair? path) ; need at least one element
|
||||
(let ((request-method (request-method req))
|
||||
|
|
@ -90,16 +90,16 @@
|
|||
(if (or (string=? request-method "GET")
|
||||
(string=? request-method "POST"))
|
||||
(if (resume-url? path-string)
|
||||
(resume-url path-string servlet-path req)
|
||||
(launch-new-session path-string servlet-path req))
|
||||
(resume-url path-string surflet-path req)
|
||||
(launch-new-session path-string surflet-path req))
|
||||
(make-error-response (status-code method-not-allowed) req
|
||||
request-method)))
|
||||
(make-error-response (status-code bad-request) req
|
||||
(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
|
||||
((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))
|
||||
((string=? (file-name-extension path-string) ".scm")
|
||||
(obtain-lock *session-table-lock*)
|
||||
|
|
@ -113,37 +113,37 @@
|
|||
(make-integer-table) ; continuation table
|
||||
(make-lock) ; continuation table lock
|
||||
(make-thread-safe-counter) ; continuation counter
|
||||
#f)) ; servlet-data
|
||||
#f)) ; surflet-data
|
||||
(release-lock *session-table-lock*)
|
||||
(register-instance! session-id 'no-return)
|
||||
|
||||
(with-fatal-handler
|
||||
;; Catch conditions from get-servlet-rt-structure.
|
||||
;; Catch conditions from get-surflet-rt-structure.
|
||||
(lambda (condition decline)
|
||||
(delete-session! session-id)
|
||||
(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
|
||||
(session-surveillance session-id
|
||||
(+ (time) (options-session-lifetime))
|
||||
memo))
|
||||
(reset
|
||||
(with-fatal-handler
|
||||
;; Catch conditions that occur while running the servlet.
|
||||
;; Catch conditions that occur while running the surflet.
|
||||
(lambda (condition decline)
|
||||
(delete-session! session-id)
|
||||
;; Restore correct continuation with shift.
|
||||
(shift unused
|
||||
(bad-gateway-error-response req path-string condition)))
|
||||
(with-cwd servlet-path
|
||||
(with-cwd surflet-path
|
||||
(with-names-from-rt-structure
|
||||
servlet servlet-interface
|
||||
surflet surflet-interface
|
||||
(main req))))))))) ; Launch serlvet's main procedure.
|
||||
(else ; We'll serve every non-scm file.
|
||||
;; We need access to SEND-FILE-RESPONSE of
|
||||
;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we
|
||||
;; 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
|
||||
; (file-info full-file-name)
|
||||
; req))
|
||||
|
|
@ -191,15 +191,15 @@
|
|||
(status-code bad-request) req
|
||||
(format #f
|
||||
"<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>
|
||||
<li>The servlet does not accept any requests any more.</li>
|
||||
<li>The servlet URL has timed out.</li>
|
||||
<li>The surflet does not accept any requests any more.</li>
|
||||
<li>The surflet URL has timed out.</li>
|
||||
<li>You URL is illformed.</li>
|
||||
</ul>
|
||||
</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>"
|
||||
(resume-url-servlet-name path-string)))))
|
||||
<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-surflet-name path-string)))))
|
||||
(lookup-continuation-table
|
||||
(lambda (session continuation-table continuation-id)
|
||||
(let ((continuation-table-lock (session-continuation-table-lock session)))
|
||||
|
|
@ -208,7 +208,7 @@
|
|||
(release-lock continuation-table-lock)
|
||||
result)))))
|
||||
|
||||
(lambda (path-string servlet-path req)
|
||||
(lambda (path-string surflet-path req)
|
||||
(receive (session-id continuation-id)
|
||||
(resume-url-ids path-string)
|
||||
(let ((session (session-lookup session-id)))
|
||||
|
|
@ -217,7 +217,7 @@
|
|||
(resume (lookup-continuation-table session continuation-table
|
||||
continuation-id)))
|
||||
(if resume
|
||||
(with-cwd servlet-path
|
||||
(with-cwd surflet-path
|
||||
(reset
|
||||
(begin
|
||||
(register-instance! session-id 'no-return)
|
||||
|
|
@ -242,13 +242,13 @@
|
|||
(let ((continuation-id (generate-new-table-id continuations-table)))
|
||||
(table-set! continuations-table continuation-id return)
|
||||
(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
|
||||
continuation-counter
|
||||
continuation-id)))
|
||||
(make-servlet-response (response-maker new-url))))))
|
||||
(make-surflet-response (response-maker new-url))))))
|
||||
(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)
|
||||
(delete-session! (instance-session-id))
|
||||
|
|
@ -257,16 +257,16 @@
|
|||
(define (send response)
|
||||
(shift unsused response))
|
||||
|
||||
(define (make-servlet-response response)
|
||||
(let ((servlet-out-port (open-output-string))
|
||||
(servlet-in-port #f) ;; FIXME: no input-port available
|
||||
(define (make-surflet-response response)
|
||||
(let ((surflet-out-port (open-output-string))
|
||||
(surflet-in-port #f) ;; FIXME: no input-port available
|
||||
(options #f)) ;; FIXME: No access to httpd-options :-(
|
||||
(if (writer-body? (response-body response))
|
||||
(begin
|
||||
;; Error-handler is already installed.
|
||||
;; Force string-output to resolve all send/... calls.
|
||||
(display-http-body (response-body response)
|
||||
servlet-in-port servlet-out-port
|
||||
surflet-in-port surflet-out-port
|
||||
options)
|
||||
;; Create write-out-response for webserver.
|
||||
(make-response
|
||||
|
|
@ -277,9 +277,9 @@
|
|||
(response-extras response)
|
||||
(make-writer-body
|
||||
(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
|
||||
"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))
|
||||
(release-lock continuation-table-lock)))))
|
||||
|
||||
(define (set-servlet-data! new-data)
|
||||
(define (set-surflet-data! new-data)
|
||||
(let ((session (session-lookup (instance-session-id))))
|
||||
(if session
|
||||
(begin
|
||||
(set-session-servlet-data! session new-data)
|
||||
(set-session-surflet-data! session new-data)
|
||||
#t)
|
||||
#f)))
|
||||
|
||||
(define (get-servlet-data)
|
||||
(define (get-surflet-data)
|
||||
(let ((session (session-lookup (instance-session-id))))
|
||||
(if session
|
||||
(session-servlet-data session)
|
||||
(session-surflet-data session)
|
||||
(error "Instance no longer alive."))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -401,77 +401,77 @@
|
|||
id)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SERVLETs CACHE
|
||||
(define *servlet-table* (make-string-table)) ; path-string is index
|
||||
(define *servlet-table-lock* (make-lock))
|
||||
;; SURFLETs CACHE
|
||||
(define *surflet-table* (make-string-table)) ; path-string is index
|
||||
(define *surflet-table-lock* (make-lock))
|
||||
|
||||
;; SERVLET-NAME is like "news-dir/latest-news.scm"
|
||||
(define (get-servlet-rt-structure servlet-name directory)
|
||||
(let* ((full-servlet-name (absolute-file-name servlet-name directory))
|
||||
(load-servlet
|
||||
;; SURFLET-NAME is like "news-dir/latest-news.scm"
|
||||
(define (get-surflet-rt-structure surflet-name directory)
|
||||
(let* ((full-surflet-name (absolute-file-name surflet-name directory))
|
||||
(load-surflet
|
||||
(lambda (cached?)
|
||||
(with-fatal-handler*
|
||||
(lambda (condition decline)
|
||||
(if cached? (release-lock *servlet-table-lock*))
|
||||
(if cached? (release-lock *surflet-table-lock*))
|
||||
(decline))
|
||||
(lambda ()
|
||||
;; load-config-file does not care about cwd(?)
|
||||
;; --> absolute file name needed
|
||||
(load-config-file full-servlet-name)
|
||||
;; servlet-structure to load must be named "servlet"
|
||||
(let ((servlet-structure (reify-structure 'servlet)))
|
||||
(load-structure servlet-structure)
|
||||
(load-config-file full-surflet-name)
|
||||
;; surflet-structure to load must be named "surflet"
|
||||
(let ((surflet-structure (reify-structure 'surflet)))
|
||||
(load-structure surflet-structure)
|
||||
(if cached?
|
||||
(begin
|
||||
(table-set! *servlet-table* full-servlet-name
|
||||
(cons servlet-structure
|
||||
(file-last-mod full-servlet-name)))
|
||||
(table-set! *surflet-table* full-surflet-name
|
||||
(cons surflet-structure
|
||||
(file-last-mod full-surflet-name)))
|
||||
;; only now the lock may be released
|
||||
(release-lock *servlet-table-lock*)))
|
||||
servlet-structure))))))
|
||||
(if (options-cache-servlets?)
|
||||
(release-lock *surflet-table-lock*)))
|
||||
surflet-structure))))))
|
||||
(if (options-cache-surflets?)
|
||||
(begin
|
||||
;; The lock is only obtained and released, if servlets are
|
||||
;; cached. LOAD-SERVLET gets the CACHED? parameter, so
|
||||
;; The lock is only obtained and released, if surflets are
|
||||
;; cached. LOAD-SURFLET gets the CACHED? parameter, so
|
||||
;; nothing may happen, if in the meanwhile caching is turned
|
||||
;; off.
|
||||
(obtain-lock *servlet-table-lock*)
|
||||
(let ((servlet (table-ref *servlet-table* full-servlet-name)))
|
||||
(if servlet
|
||||
(if (equal? (file-last-mod full-servlet-name)
|
||||
(cdr servlet))
|
||||
(obtain-lock *surflet-table-lock*)
|
||||
(let ((surflet (table-ref *surflet-table* full-surflet-name)))
|
||||
(if surflet
|
||||
(if (equal? (file-last-mod full-surflet-name)
|
||||
(cdr surflet))
|
||||
(begin
|
||||
(release-lock *servlet-table-lock*)
|
||||
(car servlet))
|
||||
(load-servlet #t))
|
||||
(load-servlet #t))))
|
||||
(load-servlet #f))))
|
||||
(release-lock *surflet-table-lock*)
|
||||
(car surflet))
|
||||
(load-surflet #t))
|
||||
(load-surflet #t))))
|
||||
(load-surflet #f))))
|
||||
|
||||
(define (get-loaded-servlets)
|
||||
(obtain-lock *servlet-table-lock*)
|
||||
(let ((loaded-servlets '()))
|
||||
(define (get-loaded-surflets)
|
||||
(obtain-lock *surflet-table-lock*)
|
||||
(let ((loaded-surflets '()))
|
||||
(table-walk
|
||||
(lambda (servlet-path rt-structure)
|
||||
(set! loaded-servlets (cons servlet-path loaded-servlets)))
|
||||
*servlet-table*)
|
||||
(release-lock *servlet-table-lock*)
|
||||
loaded-servlets))
|
||||
(lambda (surflet-path rt-structure)
|
||||
(set! loaded-surflets (cons surflet-path loaded-surflets)))
|
||||
*surflet-table*)
|
||||
(release-lock *surflet-table-lock*)
|
||||
loaded-surflets))
|
||||
|
||||
(define (unload-servlet servlet-name)
|
||||
(obtain-lock *servlet-table-lock*)
|
||||
(if (table-ref *servlet-table* servlet-name)
|
||||
(table-set! *servlet-table* servlet-name #f))
|
||||
(release-lock *servlet-table-lock*))
|
||||
(define (unload-surflet surflet-name)
|
||||
(obtain-lock *surflet-table-lock*)
|
||||
(if (table-ref *surflet-table* surflet-name)
|
||||
(table-set! *surflet-table* surflet-name #f))
|
||||
(release-lock *surflet-table-lock*))
|
||||
|
||||
(define (reset-servlet-cache!)
|
||||
(define (reset-surflet-cache!)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (condition decline)
|
||||
(release-lock *servlet-table-lock*)
|
||||
(release-lock *surflet-table-lock*)
|
||||
(decline))
|
||||
(lambda ()
|
||||
(obtain-lock *servlet-table-lock*)
|
||||
(set! *servlet-table* (make-string-table))
|
||||
(release-lock *servlet-table-lock*))))
|
||||
(obtain-lock *surflet-table-lock*)
|
||||
(set! *surflet-table* (make-string-table))
|
||||
(release-lock *surflet-table-lock*))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; INSTANCE
|
||||
|
|
@ -522,7 +522,7 @@
|
|||
(string->number (match:substring match 3)))
|
||||
(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)))
|
||||
(if match
|
||||
(match:substring match 1)
|
||||
|
|
@ -562,7 +562,7 @@
|
|||
;;
|
||||
;; Adopted from WITH-FATAL-ERROR-HANDLER, but handles everything that
|
||||
;; 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.)
|
||||
(define (with-fatal-handler* handler thunk)
|
||||
(call-with-current-continuation
|
||||
|
|
@ -585,7 +585,7 @@
|
|||
(define (bad-gateway-error-response req path-string condition)
|
||||
(make-error-response
|
||||
(status-code bad-gateway) req
|
||||
(format #f "Error in servlet ~s." path-string)
|
||||
(format #f "Error in surflet ~s." path-string)
|
||||
condition))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;; utilities for servlet
|
||||
;; utilities for surflet
|
||||
;; Copyright 2002, Andreas Bernauer
|
||||
|
||||
(define (send-html/suspend html-tree-maker)
|
||||
|
|
@ -6,7 +6,7 @@
|
|||
(lambda (new-url)
|
||||
(make-usual-html-response
|
||||
(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)
|
||||
(do-sending send/finish html-tree))
|
||||
|
|
@ -15,7 +15,7 @@
|
|||
(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
|
||||
(lambda (out options)
|
||||
(display html-page out))))))
|
||||
|
|
@ -155,7 +155,7 @@
|
|||
|
||||
;; adapted from Oleg's SXML-to-HTML.scm
|
||||
;; extended by additional port argument
|
||||
(define (servlet-XML->HTML out html-tree)
|
||||
(define (surflet-XML->HTML out html-tree)
|
||||
(formated-reply out
|
||||
(reformat html-tree)))
|
||||
|
||||
|
|
@ -171,20 +171,20 @@
|
|||
. ,(lambda (trigger input-field)
|
||||
(reformat (input-field-HTML-tree input-field))))
|
||||
|
||||
(servlet-form
|
||||
(surflet-form
|
||||
;; Must do something to prevent the callback-function string to
|
||||
;; be HTML escaped.
|
||||
*preorder*
|
||||
. ,(lambda (trigger call-back-function . args)
|
||||
(receive (parameters elems)
|
||||
(typed-optionals (list symbol? XML-attribute?) args)
|
||||
(make-servlet-form call-back-function
|
||||
(make-surflet-form call-back-function
|
||||
(car parameters)
|
||||
(cadr parameters)
|
||||
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
|
||||
((get GET) "GET")
|
||||
((post POST) "POST")
|
||||
|
|
@ -279,7 +279,7 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; input-fields
|
||||
;;; defines input-fields for servlets
|
||||
;;; defines input-fields for surflets
|
||||
|
||||
(define-record-type input-field :input-field
|
||||
(real-make-input-field name transformer HTML-tree get-bindings?)
|
||||
|
|
|
|||
|
|
@ -7,19 +7,19 @@
|
|||
<h2>Main Menu</h2>
|
||||
Following files are available from here:
|
||||
<ul>
|
||||
<li><a href="servlet/news.scm">News</a></li>
|
||||
<li><a href="servlet/add-raw.scm">Adding (raw HTML version)</a></li>
|
||||
<li><a href="servlet/add-html.scm">Adding (servlets version)</a></li>
|
||||
<li><a href="servlet/add-servlet.scm">Adding (input-field
|
||||
<li><a href="surflet/news.scm">News</a></li>
|
||||
<li><a href="surflet/add-raw.scm">Adding (raw HTML version)</a></li>
|
||||
<li><a href="surflet/add-html.scm">Adding (SUrflets version)</a></li>
|
||||
<li><a href="surflet/add-servlet.scm">Adding (input-field
|
||||
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>
|
||||
<li><a href="servlet/calculate.scm">Simple Calculator</a></li>
|
||||
<li><a href="servlet/byte-input.scm">Byte Input Widget</a></li>
|
||||
<li><a href="servlet/simple-servlet.scm">Simple Servlet</a></li>
|
||||
<li><a href="servlet/spaceship.scm">Spaceship builder</a></li>
|
||||
<!-- <li><a href=/servlet/test.scm>A test servlet</a></li> -->
|
||||
<li><a href="servlet/admin.scm">Servlet Administration</a></li>
|
||||
<li><a href="surflet/calculate.scm">Simple Calculator</a></li>
|
||||
<li><a href="surflet/byte-input.scm">Byte Input Widget</a></li>
|
||||
<li><a href="surflet/simple-servlet.scm">Simple SUrflet</a></li>
|
||||
<li><a href="surflet/spaceship.scm">Spaceship builder</a></li>
|
||||
<!-- <li><a href=/surflet/test.scm>A test SUrflet</a></li> -->
|
||||
<li><a href="surflet/admin.scm">SUrflet Administration</a></li>
|
||||
<!-- <li><a href=index.html>This file</a></li>-->
|
||||
</ul>
|
||||
<br>
|
||||
|
|
@ -28,7 +28,7 @@
|
|||
<hr>
|
||||
<!-- Created: Thu Aug 22 16:44:16 CEST 2002 -->
|
||||
<!-- hhmts start -->
|
||||
Last modified: Sun Dec 8 19:45:23 CET 2002
|
||||
Last modified: Sun Jan 19 17:34:31 CET 2003
|
||||
<!-- hhmts end -->
|
||||
</body>
|
||||
</html>
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
httpd-requests
|
||||
httpd-responses
|
||||
url
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open httpd-requests ; REQUEST-URL
|
||||
httpd-responses ; MAKE-RESPONSE
|
||||
parse-html-forms ; PARSE-HTML-FORM-QUERY
|
||||
url ; HTTP-URL-SEARCH
|
||||
srfi-1 ; FILTER
|
||||
servlet-handler/servlet ; SEND/SUSPEND, SEND/FINISH
|
||||
surflet-handler/surflet ; SEND/SUSPEND, SEND/FINISH
|
||||
scheme-with-scsh)
|
||||
(begin
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
httpd-requests
|
||||
url
|
||||
handle-fatal-error
|
||||
|
|
@ -17,7 +17,7 @@
|
|||
(body
|
||||
(h2 ,title)
|
||||
(p
|
||||
(servlet-form ,new-url
|
||||
(surflet-form ,new-url
|
||||
,input-text " "
|
||||
,number-input-field
|
||||
,(make-submit-button)))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
servlets
|
||||
simple-servlet-api
|
||||
surflets
|
||||
simple-surflet-api
|
||||
)
|
||||
(begin
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
handle-fatal-error
|
||||
let-opt
|
||||
servlets
|
||||
servlet-handler/admin
|
||||
surflets
|
||||
surflet-handler/admin
|
||||
httpd-responses
|
||||
)
|
||||
(begin
|
||||
|
|
@ -12,13 +12,13 @@
|
|||
(send-html/suspend
|
||||
(lambda (new-url)
|
||||
`(html
|
||||
(title "Servlet Adminstration - Handler options")
|
||||
(title "SUrflet Adminstration - Handler options")
|
||||
(body
|
||||
(h1 "Servlet Administration")
|
||||
(h1 "SUrflet Administration")
|
||||
(h2 "Handler options")
|
||||
,(and (pair? update-text) update-text)
|
||||
(p "These are the runtime configurable options of the handler:")
|
||||
(servlet-form
|
||||
(surflet-form
|
||||
,new-url
|
||||
POST
|
||||
(table
|
||||
|
|
@ -45,9 +45,9 @@
|
|||
,(:optional maybe-update-text "")))
|
||||
(number-field
|
||||
(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)
|
||||
("Cache servlets?" ,cache-checkbox ,submit-cache)))
|
||||
("Cache SUrflets?" ,cache-checkbox ,submit-cache)))
|
||||
(req (get-option-change return-address update-text options))
|
||||
(bindings (get-bindings req)))
|
||||
(cond
|
||||
|
|
@ -69,7 +69,7 @@
|
|||
(let ((cache-plugins? (if (input-field-binding cache-checkbox bindings)
|
||||
#t
|
||||
#f)))
|
||||
(set-options-cache-servlets? cache-plugins?)
|
||||
(set-options-cache-surflets? cache-plugins?)
|
||||
(handler-options req
|
||||
(format #f "Caching turned ~s."
|
||||
(if cache-plugins? "on" "off")))))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
servlets
|
||||
servlet-handler/admin
|
||||
surflets
|
||||
surflet-handler/admin
|
||||
profiling
|
||||
handle-fatal-error
|
||||
httpd-responses
|
||||
|
|
@ -26,11 +26,11 @@
|
|||
(counter state:counter set-state:counter!))
|
||||
|
||||
(define (state-file-name)
|
||||
(state:file-name (get-servlet-data)))
|
||||
(state:file-name (get-surflet-data)))
|
||||
(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)
|
||||
(state:counter (get-servlet-data)))
|
||||
(state:counter (get-surflet-data)))
|
||||
|
||||
;; Leave this global. Servers are running on a single system.
|
||||
(define gnuplot #f) ;; Set in main.
|
||||
|
|
@ -49,8 +49,8 @@
|
|||
(send-html/suspend
|
||||
(lambda (new-url)
|
||||
`(html
|
||||
(title "Servlet Administration -- Profiling")
|
||||
(body (h1 "Serlvet Administration")
|
||||
(title "SUrflet Administration -- Profiling")
|
||||
(body (h1 "SUrflet Administration")
|
||||
(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.")
|
||||
(font (@ (color "red")) ,update-text)
|
||||
|
|
@ -61,7 +61,7 @@
|
|||
(li (URL ,(result-address new-url)
|
||||
"Show profile results")
|
||||
(br)
|
||||
(servlet-form
|
||||
(surflet-form
|
||||
,new-url
|
||||
POST
|
||||
(p "This uses " (var "gnuplot") " that is searched at "
|
||||
|
|
@ -107,7 +107,7 @@
|
|||
(file-executable? gnuplot-file-name)))
|
||||
|
||||
(define (new-profile req)
|
||||
(let ((state (get-servlet-data)))
|
||||
(let ((state (get-surflet-data)))
|
||||
(format #t "profiling...~%")
|
||||
(obtain-lock lock)
|
||||
(profile-space (state:file-name state))
|
||||
|
|
@ -118,9 +118,9 @@
|
|||
|
||||
(define (result req)
|
||||
(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
|
||||
"../img/servlet-profiling.picture"
|
||||
"../img/surflet-profiling.picture"
|
||||
".pbm"))
|
||||
(get-total-bytes (lambda (space-info)
|
||||
(total-bytes (space-info-total space-info))))
|
||||
|
|
@ -134,7 +134,7 @@
|
|||
(<< ,(format #f "set terminal pbm color
|
||||
set output '~a'
|
||||
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
|
||||
gnuplot-data-file-name
|
||||
(format-date "~c" (date))
|
||||
|
|
@ -168,9 +168,9 @@ plot '~a' title 'Servlet Profiling ~a' with lines"
|
|||
(send-html/suspend
|
||||
(lambda (new-url)
|
||||
`(html
|
||||
(title "Servlet Administration -- Profiling Results")
|
||||
(title "SUrflet Administration -- Profiling Results")
|
||||
(body
|
||||
(h1 "Servlet-Administration")
|
||||
(h1 "SUrflet-Administration")
|
||||
(h2 "Profiling Results")
|
||||
(h3 "Picture")
|
||||
(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."))
|
||||
|
||||
(define (add-file-name-to-delete! file-name)
|
||||
(let ((state (get-servlet-data)))
|
||||
(let ((state (get-surflet-data)))
|
||||
(set-state:file-names-to-delete!
|
||||
state
|
||||
(cons file-name
|
||||
|
|
@ -212,18 +212,18 @@ plot '~a' title 'Servlet Profiling ~a' with lines"
|
|||
(for-each delete-filesys-object file-names-to-delete))))
|
||||
|
||||
(define (reset-profiling-state!)
|
||||
(let ((state (get-servlet-data)))
|
||||
(let ((state (get-surflet-data)))
|
||||
(set-state:counter! state 0)
|
||||
(delete-files 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
|
||||
(list (state:file-name state)))))
|
||||
|
||||
(define (reset-and-return-to-main-page req)
|
||||
;; Overhead included :-|
|
||||
(reset-profiling-state!)
|
||||
(delete-files (get-servlet-data))
|
||||
(delete-files (get-surflet-data))
|
||||
(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)
|
||||
;; We'll fill this out soon.
|
||||
(set! gnuplot (search-gnuplot))
|
||||
(set-servlet-data! (make-state #f #f 0))
|
||||
(set-surflet-data! (make-state #f #f 0))
|
||||
(reset-profiling-state!)
|
||||
;; 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))
|
||||
|
||||
(define (search-gnuplot)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
servlets
|
||||
servlet-handler/admin
|
||||
surflets
|
||||
surflet-handler/admin
|
||||
httpd-responses
|
||||
handle-fatal-error
|
||||
let-opt
|
||||
|
|
@ -10,8 +10,8 @@
|
|||
)
|
||||
(begin
|
||||
|
||||
(define remove-servlet-path
|
||||
(let ((regexp (rx ,(file-name-as-directory (options-servlet-path))
|
||||
(define remove-surflet-path
|
||||
(let ((regexp (rx ,(file-name-as-directory (options-surflet-path))
|
||||
(submatch (* any)))))
|
||||
(lambda (file-name)
|
||||
(let ((match (regexp-search regexp file-name)))
|
||||
|
|
@ -36,7 +36,7 @@
|
|||
(title ,title)
|
||||
(body
|
||||
,header
|
||||
(servlet-form
|
||||
(surflet-form
|
||||
,new-url
|
||||
(table
|
||||
,@(cons '(th) header-row)
|
||||
|
|
@ -63,72 +63,72 @@
|
|||
checkboxes
|
||||
table-elements)))))
|
||||
|
||||
(define (unload-servlets outdated? servlet-names)
|
||||
(define (unload-surflets outdated? surflet-names)
|
||||
(if-outdated outdated?
|
||||
(show-outdated (make-callback servlets))
|
||||
(for-each unload-servlet servlet-names)))
|
||||
(show-outdated (make-callback surflets))
|
||||
(for-each unload-surflet surflet-names)))
|
||||
|
||||
(define (no-servlets)
|
||||
`(p "Currently, there are no servlets loaded "
|
||||
(URL ,(make-callback servlets) "(reload).")))
|
||||
(define (no-surflets)
|
||||
`(p "Currently, there are no SUrflets loaded "
|
||||
(URL ,(make-callback surflets) "(reload).")))
|
||||
|
||||
(define (servlets req . maybe-update-text)
|
||||
(define (surflets req . 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))
|
||||
(title "Servlet-Administration -- Servlets")
|
||||
(header `((h1 "Servlet Administration")
|
||||
(h2 "Servlets")
|
||||
(title "SUrflet-Administration -- SUrflets")
|
||||
(header `((h1 "SUrflet Administration")
|
||||
(h2 "SUrflets")
|
||||
(p (font (@ (color "red")) ,update-text))))
|
||||
(footer `((hr)
|
||||
(URL ,(make-callback return-to-main-page) "Return to main page")))
|
||||
(actions '("unload" "unload all" "view sessions")))
|
||||
(if (null? loaded-servlets)
|
||||
(send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer)))
|
||||
(receive (action selected-servlets)
|
||||
(if (null? loaded-surflets)
|
||||
(send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer)))
|
||||
(receive (action selected-surflets)
|
||||
(select-table title ; title
|
||||
header ; header
|
||||
'((th "Name")) ; table-header
|
||||
loaded-servlets ; list of elements
|
||||
(lambda (servlet) ; selector
|
||||
loaded-surflets ; list of elements
|
||||
(lambda (surflet) ; selector
|
||||
`((td
|
||||
,(remove-servlet-path servlet))))
|
||||
,(remove-surflet-path surflet))))
|
||||
actions ; actions to perform
|
||||
(cons ; footer
|
||||
`(p "Note that unloading the servlets does not imply "
|
||||
"the unloading of sessions of this servlet."
|
||||
`(p "Note that unloading the SUrflet does not imply "
|
||||
"the unloading of sessions of this SUrflet."
|
||||
"This can be done on the "
|
||||
(URL ,(make-callback sessions)
|
||||
"sessions adminstration page."))
|
||||
footer))
|
||||
(if (null? selected-servlets)
|
||||
(servlets 'no-req "You must choose at least one element.")
|
||||
(if (null? selected-surflets)
|
||||
(surflets 'no-req "You must choose at least one element.")
|
||||
(cond
|
||||
((string=? action "unload")
|
||||
(unload-servlets outdated? selected-servlets)
|
||||
(servlets 'no-req "Servlets unloaded."))
|
||||
(unload-surflets outdated? selected-surflets)
|
||||
(surflets 'no-req "SUrflets unloaded."))
|
||||
((string=? action "unload all")
|
||||
(unload-servlets outdated? loaded-servlets)
|
||||
(servlets 'no-req "Servlets unloaded."))
|
||||
(unload-surflets outdated? loaded-surflets)
|
||||
(surflets 'no-req "SUrflets unloaded."))
|
||||
((string=? action "view sessions")
|
||||
(format #t "~s~%" selected-servlets)
|
||||
(let* ((path-stripped-selected-servlets
|
||||
(map remove-servlet-path selected-servlets))
|
||||
(format #t "~s~%" selected-surflets)
|
||||
(let* ((path-stripped-selected-surflets
|
||||
(map remove-surflet-path selected-surflets))
|
||||
(selected-sessions
|
||||
(filter (lambda (session-pair)
|
||||
(member (session-servlet-name (cdr session-pair))
|
||||
path-stripped-selected-servlets))
|
||||
(member (session-surflet-name (cdr session-pair))
|
||||
path-stripped-selected-surflets))
|
||||
(get-sessions))))
|
||||
;; this does not return
|
||||
(real-sessions (sort-list! selected-sessions
|
||||
session-servlet-name<?)
|
||||
session-surflet-name<?)
|
||||
"")))
|
||||
(else
|
||||
(error "unknown action" action))))))))
|
||||
|
||||
(define (session-servlet-name<? entry1 entry2)
|
||||
(let ((name1 (session-servlet-name (cdr entry1)))
|
||||
(name2 (session-servlet-name (cdr entry2))))
|
||||
(define (session-surflet-name<? entry1 entry2)
|
||||
(let ((name1 (session-surflet-name (cdr entry1)))
|
||||
(name2 (session-surflet-name (cdr entry2))))
|
||||
;; handle multiple session names
|
||||
(if (string=? name1 name2)
|
||||
(session-id<? entry1 entry2)
|
||||
|
|
@ -138,26 +138,26 @@
|
|||
(< (car entry1) (car entry2)))
|
||||
(define (session-id>? entry1 entry2)
|
||||
(session-id<? entry2 entry1))
|
||||
(define (session-servlet-name>? entry1 entry2)
|
||||
(session-servlet-name<? entry2 entry1))
|
||||
(define (session-surflet-name>? entry1 entry2)
|
||||
(session-surflet-name<? entry2 entry1))
|
||||
|
||||
(define (no-current-sessions)
|
||||
;; Avoid using send/suspend in this context as there
|
||||
;; are no sessions available any more.
|
||||
'(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.
|
||||
(URL "admin.scm" "Go back to main page.")))
|
||||
|
||||
(define (sessions req . 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)))
|
||||
|
||||
(define (real-sessions current-sessions update-text)
|
||||
(let ((outdated? (make-outdater))
|
||||
(title "Servlet Adminstration - Sessions")
|
||||
(header `((h1 "Servlet Administration")
|
||||
(title "SUrflet Adminstration - Sessions")
|
||||
(header `((h1 "SUrflet Administration")
|
||||
(h2 "Sessions")
|
||||
(p (font (@ (color "red")) ,update-text))))
|
||||
(footer `((hr)
|
||||
|
|
@ -172,12 +172,12 @@
|
|||
(receive (action selected-sessions)
|
||||
(select-table title
|
||||
header
|
||||
`((th "Servlet Name") (th "Session-Id"))
|
||||
`((th "SUrflet Name") (th "Session-Id"))
|
||||
current-sessions
|
||||
(lambda (session-pair)
|
||||
(let ((session-id (car session-pair))
|
||||
(session-entry (cdr session-pair)))
|
||||
`((td ,(session-servlet-name session-entry))
|
||||
`((td ,(session-surflet-name session-entry))
|
||||
(td ,session-id))))
|
||||
actions
|
||||
footer)
|
||||
|
|
@ -219,7 +219,7 @@
|
|||
(define (no-more-than-one-session title header1)
|
||||
(send-html
|
||||
`(html (title ,title)
|
||||
(body (h1 "Servlet Administration")
|
||||
(body (h1 "SUrflet Administration")
|
||||
(p "Currently, you may only view the continuations of "
|
||||
"one session at a time. This will be changed in "
|
||||
"future revisions. Sorry for any inconvenience.")
|
||||
|
|
@ -232,8 +232,8 @@
|
|||
(< (car entry1) (car entry2)))
|
||||
|
||||
(define (continuations sessions . maybe-update-text)
|
||||
(let ((title "Servlet Adminstration - Continuations")
|
||||
(header1 '(h1 "Servlet Administration")))
|
||||
(let ((title "SUrflet Adminstration - Continuations")
|
||||
(header1 '(h1 "SUrflet Administration")))
|
||||
(if (not (= 1 (length sessions)))
|
||||
(no-more-than-one-session title header1)
|
||||
(let* ((session-pair (car sessions))
|
||||
|
|
@ -247,8 +247,8 @@
|
|||
|
||||
(header (cons header1
|
||||
`((h2 "Continuations of " ,session-id)
|
||||
(p "(belongs to the servlet '"
|
||||
,(session-servlet-name session-entry) "')")
|
||||
(p "(belongs to the SUrflet '"
|
||||
,(session-surflet-name session-entry) "')")
|
||||
(p (font (@ (color "red")) ,update-text)))))
|
||||
(footer
|
||||
`((hr)
|
||||
|
|
@ -299,6 +299,6 @@
|
|||
"admin.scm" "admin.scm")))
|
||||
|
||||
(define (main req)
|
||||
(servlets req))
|
||||
(surflets req))
|
||||
|
||||
))
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
servlets
|
||||
servlet-handler/admin
|
||||
surflets
|
||||
surflet-handler/admin
|
||||
httpd-responses
|
||||
httpd-requests
|
||||
url
|
||||
|
|
@ -12,8 +12,8 @@
|
|||
)
|
||||
(begin
|
||||
|
||||
(define remove-servlet-path
|
||||
(let ((regexp (rx ,(file-name-as-directory (options-servlet-path))
|
||||
(define remove-surflet-path
|
||||
(let ((regexp (rx ,(file-name-as-directory (options-surflet-path))
|
||||
(submatch (* any)))))
|
||||
(lambda (file-name)
|
||||
(let ((match (regexp-search regexp file-name)))
|
||||
|
|
@ -38,7 +38,7 @@
|
|||
(title ,title)
|
||||
(body
|
||||
,header
|
||||
(servlet-form
|
||||
(surflet-form
|
||||
,new-url
|
||||
POST
|
||||
(table
|
||||
|
|
@ -66,67 +66,67 @@
|
|||
table-elements)
|
||||
req))))
|
||||
|
||||
(define (unload-servlets outdated? servlet-names)
|
||||
(define (unload-surflets outdated? surflet-names)
|
||||
(if-outdated outdated?
|
||||
(show-outdated (make-callback show-servlets))
|
||||
(for-each unload-servlet servlet-names)))
|
||||
(show-outdated (make-callback show-surflets))
|
||||
(for-each unload-surflet surflet-names)))
|
||||
|
||||
(define (no-servlets)
|
||||
`(p "Currently, there are no servlets loaded "
|
||||
(URL ,(make-callback show-servlets) "(reload)")
|
||||
(define (no-surflets)
|
||||
`(p "Currently, there are no SUrflets loaded "
|
||||
(URL ,(make-callback show-surflets) "(reload)")
|
||||
", but there may be "
|
||||
(URL ,(make-callback show-sessions) "sessions")
|
||||
" 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 ""))
|
||||
(loaded-servlets (sort-list! (get-loaded-servlets) string<?))
|
||||
(loaded-surflets (sort-list! (get-loaded-surflets) string<?))
|
||||
(outdated? (make-outdater))
|
||||
(title "Servlet-Administration -- Servlets")
|
||||
(header `((h1 "Servlet Administration")
|
||||
(h2 "Servlets")
|
||||
(title "SUrflet-Administration -- SUrflets")
|
||||
(header `((h1 "SUrflet Administration")
|
||||
(h2 "SUrflets")
|
||||
(p (font (@ (color "red")) ,update-text))))
|
||||
(footer `((hr)
|
||||
(URL ,(make-callback return-to-main-page) "Return to administration menu.")
|
||||
(br)
|
||||
(URL "/" "Return to main menu.")))
|
||||
(actions '("unload" "unload all")))
|
||||
(if (null? loaded-servlets)
|
||||
(send-html `(html (title ,title) (body ,header ,(no-servlets) ,footer)))
|
||||
(receive (action selected-servlets req)
|
||||
(if (null? loaded-surflets)
|
||||
(send-html `(html (title ,title) (body ,header ,(no-surflets) ,footer)))
|
||||
(receive (action selected-surflets req)
|
||||
(select-table title ; title
|
||||
header ; header
|
||||
'((th "Name")) ; table-header
|
||||
loaded-servlets ; list of elements
|
||||
(lambda (servlet) ; selector
|
||||
loaded-surflets ; list of elements
|
||||
(lambda (surflet) ; selector
|
||||
`((td
|
||||
,(remove-servlet-path servlet))))
|
||||
,(remove-surflet-path surflet))))
|
||||
actions ; actions to perform
|
||||
(cons ; footer
|
||||
`(p "Note that unloading the servlets does not imply "
|
||||
"the unloading of sessions of this servlet. " (br)
|
||||
`(p "Note that unloading the SUrflets does not imply "
|
||||
"the unloading of sessions of this SUrflet. " (br)
|
||||
"This can be done on the "
|
||||
(URL ,(make-callback show-sessions)
|
||||
"sessions adminstration page."))
|
||||
footer))
|
||||
(if (not action)
|
||||
(show-servlets 'no-req "Choose an action.")
|
||||
(if (and (null? selected-servlets)
|
||||
(show-surflets 'no-req "Choose an action.")
|
||||
(if (and (null? selected-surflets)
|
||||
(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
|
||||
((string=? action "unload")
|
||||
(unload-servlets outdated? selected-servlets)
|
||||
(show-servlets 'no-req "Servlets unloaded."))
|
||||
(unload-surflets outdated? selected-surflets)
|
||||
(show-surflets 'no-req "SUrflets unloaded."))
|
||||
((string=? action "unload all")
|
||||
(unload-servlets outdated? loaded-servlets)
|
||||
(show-servlets 'no-req "Servlets unloaded."))
|
||||
(unload-surflets outdated? loaded-surflets)
|
||||
(show-surflets 'no-req "SUrflets unloaded."))
|
||||
(else
|
||||
(error "unknown action" action)))))))))
|
||||
|
||||
(define (session-servlet-name<? entry1 entry2)
|
||||
(let ((name1 (session-servlet-name (cdr entry1)))
|
||||
(name2 (session-servlet-name (cdr entry2))))
|
||||
(define (session-surflet-name<? entry1 entry2)
|
||||
(let ((name1 (session-surflet-name (cdr entry1)))
|
||||
(name2 (session-surflet-name (cdr entry2))))
|
||||
;; handle multiple session names
|
||||
(if (string=? name1 name2)
|
||||
(session-id<? entry1 entry2)
|
||||
|
|
@ -136,28 +136,28 @@
|
|||
(< (car entry1) (car entry2)))
|
||||
(define (session-id>? entry1 entry2)
|
||||
(session-id<? entry2 entry1))
|
||||
(define (session-servlet-name>? entry1 entry2)
|
||||
(session-servlet-name<? entry2 entry1))
|
||||
(define (session-surflet-name>? entry1 entry2)
|
||||
(session-surflet-name<? entry2 entry1))
|
||||
|
||||
(define (no-current-sessions)
|
||||
;; Avoid using send/suspend in this context as there
|
||||
;; are no sessions available any more.
|
||||
'(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.
|
||||
(URL "admin.scm" "Go back to main page.")))
|
||||
|
||||
(define (show-sessions req . 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
|
||||
(resume-url-session-id
|
||||
(last (http-url-path (request-url req)))))))
|
||||
|
||||
(define (real-sessions current-sessions update-text this-session-id)
|
||||
(let ((outdated? (make-outdater))
|
||||
(title "Servlet Adminstration - Sessions")
|
||||
(header `((h1 "Servlet Administration")
|
||||
(title "SUrflet Adminstration - Sessions")
|
||||
(header `((h1 "SUrflet Administration")
|
||||
(h2 "Sessions")
|
||||
(p (font (@ (color "red")) ,update-text))))
|
||||
(footer `(,(if (not (null? current-sessions))
|
||||
|
|
@ -165,7 +165,7 @@
|
|||
"session (id: " ,this-session-id ").")
|
||||
#f)
|
||||
(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.")
|
||||
(br)
|
||||
(URL "/" "Return to main menu.")))
|
||||
|
|
@ -179,12 +179,12 @@
|
|||
(receive (action selected-sessions req)
|
||||
(select-table title
|
||||
header
|
||||
`((th "Servlet Name") (th "Session-Id"))
|
||||
`((th "SUrflet Name") (th "Session-Id"))
|
||||
current-sessions
|
||||
(lambda (session-pair)
|
||||
(let ((session-id (car session-pair))
|
||||
(session-entry (cdr session-pair)))
|
||||
`((td ,(session-servlet-name session-entry))
|
||||
`((td ,(session-surflet-name session-entry))
|
||||
(td (@ (align "right")) ,session-id))))
|
||||
actions
|
||||
footer)
|
||||
|
|
@ -228,7 +228,7 @@
|
|||
(define (no-more-than-one-session title header1 sessions req)
|
||||
(send-html
|
||||
`(html (title ,title)
|
||||
(body (h1 "Servlet Administration")
|
||||
(body (h1 "SUrflet Administration")
|
||||
(p "Currently, you may only view the continuations of "
|
||||
"one session at a time. This will be changed in "
|
||||
"future revisions. Sorry for any inconvenience.")
|
||||
|
|
@ -242,7 +242,7 @@
|
|||
`(li (URL ,(make-callback
|
||||
(lambda (req)
|
||||
(show-continuations (list session) req)))
|
||||
,(session-servlet-name (cdr session))
|
||||
,(session-surflet-name (cdr session))
|
||||
" (" ,(car session) ")")))
|
||||
sessions)))))))
|
||||
|
||||
|
|
@ -250,8 +250,8 @@
|
|||
(< (car entry1) (car entry2)))
|
||||
|
||||
(define (show-continuations sessions req . maybe-update-text)
|
||||
(let ((title "Servlet Adminstration - Continuations")
|
||||
(header1 '(h1 "Servlet Administration")))
|
||||
(let ((title "SUrflet Adminstration - Continuations")
|
||||
(header1 '(h1 "SUrflet Administration")))
|
||||
(if (not (= 1 (length sessions)))
|
||||
(no-more-than-one-session title header1 sessions req)
|
||||
(let* ((session-pair (car sessions))
|
||||
|
|
@ -267,8 +267,8 @@
|
|||
|
||||
(header (cons header1
|
||||
`((h2 "Continuations of " ,session-id)
|
||||
(p "(belongs to the servlet '"
|
||||
,(session-servlet-name session-entry) "')")
|
||||
(p "(belongs to the SUrflet '"
|
||||
,(session-surflet-name session-entry) "')")
|
||||
(p (font (@ (color "red")) ,update-text)))))
|
||||
(footer
|
||||
`(,(if (not (null? current-continuations))
|
||||
|
|
@ -276,7 +276,7 @@
|
|||
"continuation (id: " ,this-continuation-id ").")
|
||||
#f)
|
||||
(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 return-to-main-page) "Return to administration menu.")
|
||||
(br)
|
||||
|
|
@ -332,6 +332,6 @@
|
|||
"admin.scm" "admin.scm")))
|
||||
|
||||
(define (main req)
|
||||
(show-servlets req))
|
||||
(show-surflets req))
|
||||
|
||||
))
|
||||
|
|
@ -1,19 +1,19 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
servlets
|
||||
servlet-handler/admin
|
||||
surflets
|
||||
surflet-handler/admin
|
||||
)
|
||||
(begin
|
||||
|
||||
(define (main-page)
|
||||
`(html (title "Servlet Administration")
|
||||
(body (h1 "Servlet Administration Menu")
|
||||
(p "This servlet allows you to do some adminstration tasks.")
|
||||
`(html (title "SUrflet Administration")
|
||||
(body (h1 "SUrflet Administration Menu")
|
||||
(p "This SUrflet allows you to do some adminstration tasks.")
|
||||
(p "Choose one of the following submenus:")
|
||||
(p
|
||||
(ul
|
||||
(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..."))))
|
||||
(hr)
|
||||
(p (URL "/" "Return to main menu.")))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
httpd-requests
|
||||
handle-fatal-error
|
||||
url
|
||||
|
|
@ -50,7 +50,7 @@
|
|||
(body
|
||||
(h1 "Byte Input Widget")
|
||||
(p "Enter your byte (msb left):")
|
||||
(servlet-form ,new-url
|
||||
(surflet-form ,new-url
|
||||
,byte-input-fields
|
||||
,(make-submit-button))
|
||||
(hr)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
httpd-requests
|
||||
handle-fatal-error
|
||||
let-opt
|
||||
|
|
@ -58,7 +58,7 @@
|
|||
(title "Simple calculator")
|
||||
(body (h1 "Simple calculator")
|
||||
(font (@ (color "red")) ,update-text)
|
||||
(servlet-form
|
||||
(surflet-form
|
||||
,new-url
|
||||
(table
|
||||
(tr (td "Do calculation:"))
|
||||
|
|
@ -69,7 +69,7 @@
|
|||
(td ,(make-submit-button '(@ (value "calculate")))))))
|
||||
(hr)
|
||||
(p "You may choose another operator:")
|
||||
(servlet-form
|
||||
(surflet-form
|
||||
,(change-operator-callback)
|
||||
(table
|
||||
(tr (td ,operator-input-field)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(open servlets
|
||||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
httpd-requests
|
||||
handle-fatal-error
|
||||
let-opt
|
||||
|
|
@ -51,7 +51,7 @@
|
|||
(title "Simple calculator")
|
||||
(body (h1 "Simple calculator")
|
||||
(font (@ (color "red")) ,update-text)
|
||||
(servlet-form
|
||||
(surflet-form
|
||||
,new-url
|
||||
(table
|
||||
(tr (td "Do calculation:"))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
servlets)
|
||||
surflets)
|
||||
(begin
|
||||
(define *news* '())
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
simple-servlet-api)
|
||||
simple-surflet-api)
|
||||
(begin
|
||||
|
||||
(define (main req)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
servlets
|
||||
surflets
|
||||
let-opt
|
||||
receiving
|
||||
define-record-types
|
||||
|
|
@ -306,7 +306,7 @@
|
|||
(p "Here you can build your own space ship.")
|
||||
(h2 "Step 1 -- Selecting components")
|
||||
,(and update-text `(font (@ (color "red")) ,update-text))
|
||||
(servlet-form ,new-url
|
||||
(surflet-form ,new-url
|
||||
GET
|
||||
(table
|
||||
(tr (@ (valign "top"))
|
||||
|
|
@ -331,7 +331,7 @@
|
|||
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")
|
||||
,(print-update update-text)
|
||||
(servlet-form ,new-url
|
||||
(surflet-form ,new-url
|
||||
GET
|
||||
(table
|
||||
(tr (td "My ship is for a crew of ")
|
||||
|
|
@ -361,7 +361,7 @@ specify a positive number.")
|
|||
`(html
|
||||
,(make-title)
|
||||
(body
|
||||
(servlet-form ,new-url
|
||||
(surflet-form ,new-url
|
||||
GET
|
||||
,(if (and checkboxes+text energy-input)
|
||||
`((h2 "Step 3 -- Specify arming")
|
||||
|
|
@ -429,7 +429,7 @@ specify a positive number.")
|
|||
,@(map (lambda (extra-text)
|
||||
`(li ,extra-text))
|
||||
extras))
|
||||
(servlet-form ,new-url
|
||||
(surflet-form ,new-url
|
||||
POST
|
||||
,(make-submit-button "Order now"))
|
||||
,(return-links first-page-return-link main-return-link))))
|
||||
|
|
@ -443,7 +443,7 @@ specify a positive number.")
|
|||
(h2 "Step 5 -- Extras")
|
||||
(p "Select one or more extras that are available for
|
||||
spaceships of class " ,class ":")
|
||||
(servlet-form ,new-url
|
||||
(surflet-form ,new-url
|
||||
GET
|
||||
(table ,@(map (lambda (checkbox+text)
|
||||
`(tr (td ,(car checkbox+text))
|
||||
|
|
@ -474,7 +474,7 @@ spaceships of class " ,class ":")
|
|||
`(URL ,prev "Return to previous page."))
|
||||
|
||||
(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)
|
||||
`(p
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(define-structure servlet servlet-interface
|
||||
(define-structure surflet surflet-interface
|
||||
(open scheme-with-scsh
|
||||
servlets
|
||||
surflets
|
||||
httpd-responses)
|
||||
(begin
|
||||
(define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2))))
|
||||
|
|
@ -8,8 +8,8 @@
|
|||
(define (main req)
|
||||
(let ((req (send-html/suspend
|
||||
(lambda (new-url)
|
||||
`(html (body (h1 "This is from servlet")
|
||||
(servlet-form
|
||||
`(html (body (h1 "This is from SUrflet")
|
||||
(surflet-form
|
||||
,new-url
|
||||
POST
|
||||
,select
|
||||
|
|
|
|||
Loading…
Reference in New Issue