286 lines
7.2 KiB
Scheme
286 lines
7.2 KiB
Scheme
;; Structures and interfaces for servlets.
|
|
;; 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))
|
|
|
|
(define-interface rt-module-language-interface
|
|
(export ((lambda-interface
|
|
with-names-from-rt-structure)
|
|
:syntax)
|
|
reify-structure
|
|
load-structure
|
|
load-config-file
|
|
rt-structure-binding))
|
|
|
|
(define-interface rt-modules-interface
|
|
(export interface-value-names
|
|
reify-structure
|
|
load-config-file
|
|
rt-structure-binding
|
|
load-structure))
|
|
|
|
(define-structure rt-module-language rt-module-language-interface
|
|
(open scheme
|
|
rt-modules)
|
|
(for-syntax (open scheme
|
|
rt-modules))
|
|
(begin
|
|
(define-syntax lambda-interface
|
|
(lambda (expr rename compare)
|
|
(let ((%lambda (rename 'lambda))
|
|
(interface-name (cadr expr))
|
|
(body (cddr expr)))
|
|
`(,%lambda ,(interface-value-names interface-name) ,@body))))
|
|
|
|
;(with-names-from-rt-structure servlet servlet-interface (main))
|
|
(define-syntax with-names-from-rt-structure
|
|
(lambda (expr rename compare)
|
|
(let ((%lambda (rename 'lambda))
|
|
(%let (rename 'let))
|
|
(%rt-structure-value (rename 'rt-structure-value))
|
|
(%rt-structure-binding (rename 'rt-structure-binding))
|
|
(rt-structure (cadr expr))
|
|
(interface-name (caddr expr))
|
|
(body (cdddr expr)))
|
|
(let ((ivn (interface-value-names interface-name)))
|
|
`(,%let ((,%rt-structure-value ,rt-structure))
|
|
((,%lambda ,ivn ,@body)
|
|
,@(map (lambda (name)
|
|
`(,%rt-structure-binding ,%rt-structure-value ',name))
|
|
ivn)))))))))
|
|
|
|
(define-structure rt-modules rt-modules-interface
|
|
(open scheme
|
|
meta-types ; syntax-type
|
|
interfaces ; for-each-declaration
|
|
define-record-types
|
|
records
|
|
signals
|
|
bindings
|
|
packages
|
|
packages-internal
|
|
locations
|
|
environments
|
|
ensures-loaded
|
|
package-commands-internal)
|
|
(files rt-module))
|
|
|
|
(define-interface servlet-handler-interface
|
|
(export servlet-handler))
|
|
|
|
(define-interface servlet-handler/servlet-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
|
|
adjust-timeout ;adjusts timeout of current instance
|
|
;Without `!' because PLT
|
|
;doesn't have it.
|
|
))
|
|
|
|
(define-interface servlet-handler/admin-interface
|
|
(export get-loaded-servlets
|
|
unload-servlet
|
|
set-options-instance-lifetime
|
|
options-instance-lifetime
|
|
set-options-cache-servlets?
|
|
options-cache-servlets?
|
|
options-servlet-path
|
|
options-servlet-prefix
|
|
get-instances
|
|
instance-servlet-name
|
|
instance-memo
|
|
instance-continuation-table
|
|
instance-continuation-table-lock
|
|
instance-continuation-counter
|
|
delete-instance!
|
|
instance-adjust-timeout!
|
|
adjust-timeout
|
|
get-continuations
|
|
delete-continuation!
|
|
session-instance-id))
|
|
|
|
(define-structures
|
|
((servlet-handler servlet-handler-interface)
|
|
(servlet-handler/servlet servlet-handler/servlet-interface)
|
|
(servlet-handler/admin servlet-handler/admin-interface))
|
|
(open httpd-responses
|
|
httpd-request
|
|
httpd-error
|
|
uri ;URI-PATH-LIST->PATH
|
|
tables ;HASH-TABLES
|
|
define-record-types ;DEFINE-RECORD-TYPE
|
|
rt-module-language ;get structures dynamically
|
|
; srfi-13 ;string
|
|
srfi-14 ;CHAR-SET:DIGIT
|
|
handle-fatal-error ;WITH-FATAL-ERROR-HANDLER* et al.
|
|
srfi-27 ;random numbers
|
|
locks ;MAKE-LOCK et al.
|
|
thread-cells ;THREAD-CELL et al.
|
|
profiling ;PROFILE-SPACE
|
|
httpd-logging ;HTTP-SYSLOG
|
|
shift-reset ;SHIFT and RESET
|
|
conditions ;exception
|
|
threads ;SLEEP
|
|
thread-fluids ;FORK-THREAD
|
|
sxml-to-html ;SXML->HTML
|
|
scsh ;regexp et al.
|
|
; httpd-file-directory-handlers ;send-file-response
|
|
handle
|
|
scheme
|
|
)
|
|
(files servlet-handler))
|
|
|
|
|
|
(define-interface servlets-interface
|
|
(export send/suspend
|
|
send/finish
|
|
send
|
|
send-html/suspend
|
|
send-html/finish
|
|
send-html
|
|
form-query
|
|
get-bindings
|
|
extract-bindings
|
|
extract-single-binding
|
|
|
|
adjust-timeout
|
|
|
|
make-outdater
|
|
(if-outdated :syntax)
|
|
show-outdated
|
|
|
|
generate-input-field-name
|
|
make-input-field
|
|
make-higher-input-field
|
|
make-text-input-field
|
|
make-hidden-input-field
|
|
make-password-input-field
|
|
make-number-input-field
|
|
make-textarea-input-field
|
|
make-select-input-field
|
|
make-checkbox-input-field
|
|
make-radio-input-fields
|
|
|
|
make-submit-button
|
|
make-reset-button
|
|
make-image-button
|
|
input-field-value
|
|
raw-input-field-value
|
|
input-field-binding
|
|
|
|
make-address
|
|
returned-via?
|
|
make-callback
|
|
|
|
set-servlet-data!
|
|
get-servlet-data))
|
|
|
|
(define-structure servlets servlets-interface
|
|
(open servlet-handler/servlet
|
|
httpd-responses
|
|
httpd-request ; HTTP-URL:SEARCH
|
|
url ; REQUEST:URL
|
|
parse-html-forms
|
|
sxml-to-html ; SXML->HTML
|
|
srfi-1 ; FILTER
|
|
(subset rfc822 (get-header))
|
|
(subset srfi-13 (string-index))
|
|
sxml-tree-trans
|
|
url
|
|
httpd-request
|
|
define-record-types
|
|
weak ;MAKE-WEAK-POINTER
|
|
locks
|
|
let-opt ;:OPTIONAL
|
|
handle-fatal-error
|
|
scsh
|
|
scheme)
|
|
(files servlets))
|
|
|
|
(define-interface servlet-interface
|
|
(export main)) ; MAIN gets one parameter, the REQUEST
|
|
|
|
(define-interface shift-reset-interface
|
|
(export (reset :syntax)
|
|
(shift :syntax)))
|
|
|
|
(define-structure shift-reset shift-reset-interface
|
|
(open scheme
|
|
signals
|
|
escapes
|
|
thread-cells)
|
|
(files shift-reset))
|
|
|
|
(define-interface profiling-interface
|
|
(export profile-space
|
|
profile-result
|
|
profile-results
|
|
write-gnuplot-data-file
|
|
|
|
space-info-pair space-info-symbol
|
|
space-info-vector space-info-closure
|
|
space-info-location space-info-cell
|
|
space-info-channel space-info-port
|
|
space-info-ratnum space-info-record
|
|
space-info-continuation space-info-extended-number
|
|
space-info-template space-info-weak-pointer
|
|
space-info-shared-binding space-info-unused-d-header1
|
|
space-info-unused-d-header2 space-info-string
|
|
space-info-byte-vector space-info-double
|
|
space-info-bignum space-info-total
|
|
|
|
set-space-info-pair! set-space-info-symbol!
|
|
set-space-info-vector! set-space-info-closure!
|
|
set-space-info-location! set-space-info-cell!
|
|
set-space-info-channel! set-space-info-port!
|
|
set-space-info-ratnum! set-space-info-record!
|
|
set-space-info-continuation! set-space-info-extended-number!
|
|
set-space-info-template! set-space-info-weak-pointer!
|
|
set-space-info-shared-binding! set-space-info-unused-d-header1!
|
|
set-space-info-unused-d-header2! set-space-info-string!
|
|
set-space-info-byte-vector! set-space-info-double!
|
|
set-space-info-bignum! set-space-info-total!
|
|
|
|
pure-count pure-bytes
|
|
impure-count impure-bytes
|
|
total-count total-bytes
|
|
))
|
|
|
|
(define-structure profiling profiling-interface
|
|
(open let-opt
|
|
define-record-types
|
|
spatial
|
|
srfi-13
|
|
srfi-1
|
|
locks
|
|
scsh
|
|
scheme)
|
|
(files profile))
|
|
|
|
(define-interface simple-servlet-api-interface
|
|
(export single-query
|
|
queries
|
|
form-query
|
|
inform
|
|
final-page
|
|
make-password
|
|
make-number
|
|
make-boolean
|
|
make-radio
|
|
make-yes-no
|
|
extract/single
|
|
extract))
|
|
|
|
(define-structure simple-servlet-api simple-servlet-api-interface
|
|
(open scsh
|
|
scheme
|
|
define-record-types
|
|
let-opt
|
|
servlets
|
|
(subset srfi-1 (zip filter find make-list))
|
|
handle-fatal-error
|
|
)
|
|
(files simple-servlet-api))
|