sunet/scheme/httpd/surflets/packages.scm

;; 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 session
					;Without `!' because PLT
					;doesn't have it.
	  ))

(define-interface servlet-handler/admin-interface
  (export get-loaded-servlets
	  unload-servlet
	  set-options-session-lifetime
	  options-session-lifetime
	  set-options-cache-servlets?
	  options-cache-servlets?
	  options-servlet-path
	  options-servlet-prefix
	  get-sessions
	  session-servlet-name
	  session-memo
	  session-continuation-table
	  session-continuation-table-lock
	  session-continuation-counter
	  delete-session!
	  session-adjust-timeout!
	  adjust-timeout
	  get-continuations
	  delete-continuation!
	  instance-session-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-requests
	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
	srfi-6				;string-ports
	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-requests			; 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
	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))