sunet/scheme/httpd/surflets/surflet-handler.scm

;; The SUrflet handler
;; Copyright Andreas Bernauer, 2002

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GLOBALS

;;; DEBUGging
(define *debug* #t)

;;; OPTIONS for the SUrflet handler.
;; Preserved thread fluid because between different calls to
;; surflet-handler the options shall remain the same. SURFLET-HANDLER
;; sets the value (an option record, see end of file)
(define *options* (make-preserved-thread-fluid #f))

;;; SURFLET-TABLE cache
(define *surflet-table* (make-string-table)) ; path-string is index
(define *surflet-table-lock* (make-lock))

;;; SESSION-TABLE
;; Every session gets an entry in the hash table. Entries are session
;; records.
(define *session-table* (make-integer-table)) ; session-id is index
(define *session-table-lock* (make-lock))

;; INSTANCE is the session that is handled currently.
(define *instance* (make-thread-cell #f))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SURFLET-HANDLER

;;; SURFLET-HANDLER
;; Loads a new or resumes a suspended SUrflet; returns a
;; (HTTP-)RESPONSE. SURFLET-PATH is a string pointing to the real
;; directory where the SUrflets are searched.
(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))
	      (path-string (uri-path->uri path)))
	  (if (or (string=? request-method "GET")
		  (string=? request-method "POST"))
	      (if (resume-url? path-string)
		  (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)))))

;;; LAUNCH-NEW-SESSION
;; Loads and runs a new session of a SUrflet installing the RESET
;; boundary; returns a (HTTP-)RESPONSE. PATH-STRING is the virtual
;; path of the request, SURFLET-PATH is a string pointing to the real
;; directory of the SUrflets, and REQ the request of the browser.
(define (launch-new-session path-string surflet-path req)

  (cond 

   ((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*)
    ;; no access to session table until new session-id is saved
    (let ((session-id (generate-new-table-id *session-table*))
	  (memo (make-default-memo)))
      (table-set! *session-table* session-id
		  (make-session path-string    ; used to make
						; redirections to origin
				 memo
				 (make-integer-table) ; continuation table
				 (make-lock)          ; continuation table lock
				 (make-thread-safe-counter) ; continuation counter
				 #f))	              ; surflet-data
      (release-lock *session-table-lock*)
      (register-instance! session-id 'no-return)
      
      (with-fatal-handler
       ;; Catch conditions from get-surflet-rt-structure.
       (lambda (condition decline)
	 (delete-session! session-id)
	 (bad-gateway-error-response req path-string condition))
       (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 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 surflet-path
	     (with-names-from-rt-structure 
	      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 surflet-path)))
;      (send-file-response full-file-name
;			  (file-info full-file-name)
;			  req))
    (make-error-response (status-code forbidden) req
			      "Can't serve other than Scheme files."
			      path-string))
   ))


;;; SESSION-SURVEILLANCE
;; Returns surveillance procedure to be fork-threaded, that kills a
;; session after TIME-TO-DIE (seconds) has expired. MEMO contains
;; current status of session.
(define (session-surveillance session-id time-to-die memo)
  (lambda ()
    (let loop ((time-to-die time-to-die)
	       (memo memo))
      (debug "session-surveillance[~s]: going to sleep until ~a"
	     session-id (format-date "~c" (date time-to-die)))
      (let ((seconds-to-sleep (- time-to-die (time))))
	(if (positive? seconds-to-sleep)
	    (sleep (* 1000 seconds-to-sleep))))
      ;; check state of the world
      (case (memo:message memo)
	((killed)			; too late
	 (debug "session-surveillance[~s]: session already killed, dieing"
		 session-id)
	 )
	((adjust-timeout)		; new timeout
	 (debug "session-surveillance[~s]: adjusting timeout" session-id)
	 (loop (memo:value memo) 
	       (memo:new-memo memo)))
	((kill)				; kill session
	 (debug "session-surveillance[~s]: killing" 
		 session-id)
	 (obtain-lock *session-table-lock*)
	 (table-set! *session-table* session-id #f)
	 (release-lock *session-table-lock*))
	(else
	 (format (current-error-port) 
		 "session-surveillance[~s]: unknown message ~s; dieing"
		 session-id (memo:message memo)))))))
      
;;; RESUME-URL
;; Resumes a suspended URL and returns a (HTTP-)RESPONSE. PATH-STRING
;; is the virtual path, SURFLET-PATH a string pointing to the real
;; directory of the SUrflets and REQ the request of the browser.
(define resume-url
  (let ((bad-request 
	 (lambda (path-string req)
	   (make-error-response
	    (status-code bad-request) req
	    (format #f 
		    "<br>
<p>There may be several reasons, why your request for a surflet was denied:
<ul>
<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 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)))
	      (obtain-lock continuation-table-lock)
	      (let ((result (table-ref continuation-table continuation-id)))
		(release-lock continuation-table-lock)
		result)))))

    (lambda (path-string surflet-path req)
      (receive (session-id continuation-id)
	  (resume-url-ids path-string)
	;; try to get continuation-table and then the continuation
	(let ((session (session-lookup session-id)))
	  (if session
	      (let* ((continuation-table (session-continuation-table session))
		     (resume (lookup-continuation-table session continuation-table 
							continuation-id)))
		(if resume
		    (with-cwd surflet-path
		      (reset
		       (begin
			 (register-instance! session-id 'no-return)
			 (resume req))))
		    (bad-request path-string req)))
	      (bad-request path-string req)))
	))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SURFLET-INTERFACE

;;; SEND/SUSPEND
;; Suspends current computation, saves current continuation, and
;; leaves current continuation via SHIFT with a (HTTP-)RESPONSE.
;; RESPONSE-MAKER is a procedure returnig a SURFLET-RESPONSE (that is,
;; eventually converted to a HTTP-RESPONSE).
(define (send/suspend response-maker)
  (shift return
	 (let* ((session-id (instance-session-id))
		(session (session-lookup session-id)))
	   ;;  the instance might be deleted in the meanwhile
	   (if session
	       (begin
		 (session-adjust-timeout! session-id)
		 (let ((continuations-table (session-continuation-table session))
		       (continuation-table-lock (session-continuation-table-lock session))
		       (continuation-counter (session-next-continuation-counter session)))
		   (obtain-lock continuation-table-lock)
		   (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-surflet-name session)
						     session-id 
						     continuation-counter
						     continuation-id)))
		       (make-http-response (response-maker new-url))))))
	       (make-error-response (status-code not-found) #f
					 "The URL refers to a SUrflet, whose session is no longer alive.")))))

;;; SEND/FINISH
;; Kills current session, and leaves current continuation returning
;; via SHIFT with a (HTTP-)RESPONSE. RESPONSE is a SURFLET-RESPONSE.
(define (send/finish response)
  (delete-session! (instance-session-id))
  (shift unused (make-http-response response)))


;;; SEND
;; Leaves current continuation via SHIFT with a
;; (HTTP-)RESPONSE. RESPONSE is a SURFLET-RESPONSE.
(define (send response)
  (shift unused (make-http-response response)))

;;; SEND-ERROR
;; Stops current computation, and leaves current continuation via
;; SHIFT with a (HTTP-)(ERROR-)RESPONSE. STATUS-CODE is a status code
;; from HTTP-RESPONSES, REQ a request (may be #f) and MESSAGES
;; contains further informations (arbitrary types).
(define (send-error status-code req . messages)
  (shift unused (apply make-error-response 
		       (cons status-code 
			     (cons #f messages)))))

;;; MAKE-HTTP-RESPONSE
;; Converts a SURFLET-RESPONSE to a (HTTP-)RESPONSE. Returns a
;; (HTTP-)RESPONSE.
(define (make-http-response response)
  (cond
   ((surflet-response? response)
    (let ((data (surflet-response-data response)))
      (if (valid-surflet-response-data? data)
	  (make-response
	   (surflet-response-status response)
	   #f
	   (time)
	   (surflet-response-content-type response)
	   (surflet-response-headers response)
	   (make-writer-body 
	    (lambda (out options)
	      (cond
	       ((string? data) (display data out))
	       ((list? data)   (for-each (lambda (data) (display data out)) data))
	       (else  ;; We lose. 
		(display "Error in SUrflet output.\n" out))
	       ))))
	  (make-error-response (status-code bad-gateway) #f 
			       "The SUrflet returned an invalid response object (no surflet-response)."))))
   ((and (response? response)		;; RESPONSE? refers to a HTTP-RESPONSE.
	 (redirect-body? (response-body response)))
    response)
   (else
    (make-error-response (status-code bad-gateway) #f
			 "The SUrflet returned an invalid response object (no surflet-response)."))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SESSIONS

;;; SESSION-LOOKUP
;; Looks up SESSION-ID in the *SESSION-TABLE* (locking) and returns
;; the SESSION record, if anby (#f otherwise).
(define (session-lookup session-id)
  (obtain-lock *session-table-lock*)
  (let ((result (table-ref *session-table* session-id)))
    (release-lock *session-table-lock*)
    result))

;;; SESSION-NEXT-CONTINUATION-COUNTER
;; Increases the SESSION-CONTINUATION-COUNTER in the SESSION record by
;; one.
(define (session-next-continuation-counter session)
  (thread-safe-counter-next! 
   (session-continuation-counter session)))

;;; DELETE-SESSION!
;; Deletes the session indicated by its number SESSION-ID from the
;; *SESSION-TABLE* (locking).
(define (delete-session! session-id)
  (obtain-lock *session-table-lock*)
  ;; notify surveillance of session being alread killed (prevents
  ;; surveillance of killing new session that has the same number by
  ;; accident)
  (let ((session (table-ref *session-table* session-id)))
    (memo-killed! (session-memo session)))
  ;; why can't table entries be deleted correctly?
  (table-set! *session-table* session-id #f)
  (release-lock *session-table-lock*))
 
;;; SESSION-ADJUST-TIMEOUT!
;; Resets time-to-die of session indicated by its SESSION-ID number.
(define (session-adjust-timeout! session-id)
  (obtain-lock *session-table-lock*)
  (let* ((session (table-ref *session-table* session-id))
	 (memo (session-memo session))
	 (new-memo (make-default-memo)))
    ;; Do it this way: new values and then new message
    (set-memo:value memo 
		    (+ (time) 
		       (options-session-lifetime)))
    (set-memo:new-memo memo new-memo)
    ;; I don't think we need locking here. Do you agree?
    (set-session-memo! session new-memo)
    (set-memo:message memo 'adjust-timeout))
  (release-lock *session-table-lock*))

;;; ADJUST-TIMEOUT
;; Resets time-to-die of current session.
(define (adjust-timeout)
  (session-adjust-timeout! (instance-session-id)))

;;; RESET-SESSION-TABLE!
;; Clears the *SESSION-TABLE* (locking)
(define (reset-session-table!)
  (with-fatal-handler
   (lambda (condtion decline)
     (release-lock *session-table-lock*)
     (decline))
   (obtain-lock *session-table-lock*)
   ;; notify session killing
   (table-walk 
    (lambda (session-id session)
      (memo-killed! (session-memo session)))
    *session-table*)
   (set! *session-table* (make-integer-table))
   (release-lock *session-table*)))

;;; GET-SESSIONS
;; Returns a list of all active sessions in *SESSION-TABLE*
;; (locking). The list elements are pairs of session-id and session
;; record.
(define (get-sessions)
  (obtain-lock *session-table-lock*)
  (let ((sessions '()))
    (table-walk
     (lambda (session-id session-entry)
       (set! sessions (cons (cons session-id session-entry) sessions)))
     *session-table*)
    (release-lock *session-table-lock*)
    sessions))

;;; GET-CONTINUATIONS
;; Returns a list of all continuations of the session indicated by the
;; SESSION-ID number (locking). The list elements are pairs of
;; continuation id and continuation.
(define (get-continuations session-id)
  (let ((session (session-lookup session-id)))
    (if session
	(let ((continuation-table-lock (session-continuation-table-lock session))
	      (continuation-table (session-continuation-table session))
	      (continuations '()))
	  (obtain-lock continuation-table-lock)
	  (table-walk
	   (lambda (continuation-id continuation-entry)
	     (set! continuations (cons (cons continuation-id continuation-entry)
				       continuations)))
	   continuation-table)
	  (release-lock continuation-table-lock)
	  continuations)
	'())))

;;; DELETE-CONTINUATION
;; Deletes continuation SESSION-ID, CONTINUATION-ID (locking).
(define (delete-continuation! session-id continuation-id)
  (let ((session (session-lookup session-id)))
    (if session
	(let ((continuation-table-lock (session-continuation-table-lock session))
	      (continuation-table (session-continuation-table session))
	      (continuations '()))
	  (obtain-lock continuation-table-lock)
	  (if (table-ref continuation-table continuation-id)
	      (table-set! continuation-table continuation-id #f))
	  (release-lock continuation-table-lock)))))

;;; SET-SURFLET-DATA!, GET-SURFLET-DATA
;; Access to arbitrary data stored along with current session (no
;; locking!).
(define (set-surflet-data! new-data)
  (let ((session (session-lookup (instance-session-id))))
    (if session
	(begin
	  (set-session-surflet-data! session new-data)
	  #t)
	#f)))

(define (get-surflet-data)
  (let ((session (session-lookup (instance-session-id))))
    (if session
	(session-surflet-data session)
	(error "Instance no longer alive."))))
	
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ID generation  

;;; GENERATE-NEW-TABLE-ID
;; Returns a random integer not used in the hash TABLE (no
;; locking!). The locking has to happe elsewhere. 
(define (generate-new-table-id table)
  (let loop ((id (random)))
    (if (table-ref table id)
	;; FIXME?: this may loop forever, if the table is full (can
	;; this ever happen?)
	(loop (random))
	id)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SURFLETs CACHE

;;; GET-SURFLET-RT-STRUCTURE
;; Returns SUrflet's RT-STRUCTURE indicated by SURFLET-NAME (a virtual
;; path string) while managing the SUrflet cache *SURFLET-TABLE*
;; (locking).
(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 *surflet-table-lock*))
	       (decline))
	     (lambda ()
	       ;; load-config-file does not care about cwd(?)
	       ;; --> absolute file name needed
	       (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! *surflet-table* full-surflet-name 
				   (cons surflet-structure
					 (file-last-mod full-surflet-name)))
		       ;; only now the lock may be released
		       (release-lock *surflet-table-lock*)))
		 surflet-structure))))))
    (if (options-cache-surflets?)
	(begin
	  ;; 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 *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 *surflet-table-lock*)
		      (car surflet))
		    (load-surflet #t))
		(load-surflet #t))))
	(load-surflet #f))))

;;; GET-LOADED-SURFLETS
;; Returns list of all loaded surflets (real path strings).
(define (get-loaded-surflets)
  (obtain-lock *surflet-table-lock*)
  (let ((loaded-surflets '()))
    (table-walk
     (lambda (surflet-path rt-structure)
       (set! loaded-surflets (cons surflet-path loaded-surflets)))
     *surflet-table*)
    (release-lock *surflet-table-lock*)
    loaded-surflets))

;;; UNLOAD-SURFLET
;; Removes SURFLET-NAME from the *SURFLET-TABLE* cache (locking).
(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*))

;;; RESET-SURFLET-CACHE!
;; Clears *SURFLET-TABLE* (locking).
(define (reset-surflet-cache!)
  (with-fatal-handler
   (lambda (condition decline)
     (release-lock *surflet-table-lock*)
     (decline))
   (obtain-lock *surflet-table-lock*)
   (set! *surflet-table* (make-string-table))
   (release-lock *surflet-table-lock*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; INSTANCE

;;; REGISTER-INSTANCE!
;; Saves values for current session (in a record).
(define (register-instance! session-id return-continuation)
  (thread-cell-set! *instance* 
		    (make-instance session-id return-continuation)))


;;; INSTANCE-SESSION-ID
;; Returns session-id of current *INSTANCE*.
(define (instance-session-id)
  (really-instance-session-id (thread-cell-ref *instance*)))

;; unused
(define (instance-return-continuation)
  (really-instance-return-continuation (thread-cell-ref *instance*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RESUME-URL

;; Functions and constants for generating and parsing Continuation
;; URLs (= resume URLs). Resume URLs look like
;; http://localhost:8088/surflet/admin-handler.scm;k757033335;c1-684902143?return54=
(define *resume-url-regexp* (rx (submatch (* (- printing ";"))) 
				";k" (submatch (* digit)) ; Instance-ID
				";c" (+ digit)            ; Continuation Counter
				"-" (submatch (* digit)))) ; Continuation-ID

;; All arguments are numbers except PATH-STRING, which is a string.
(define (make-resume-url path-string session-id continuation-counter continuation-id)
  (string-append path-string
		 ";k" (number->string (instance-session-id)) 
		 ";c" (number->string continuation-counter)
		 "-" (number->string continuation-id)))

;; Return various parts of RESUME-URL
(define (resume-url-session-id resume-url)
  (receive (session-id continuation-id)
      (resume-url-ids resume-url)
    session-id))

(define (resume-url-continuation-id resume-url)
  (receive (session-id continuation-id)
      (resume-url-ids resume-url)
    continuation-id))

(define (resume-url-ids resume-url)
  (let ((match (regexp-search *resume-url-regexp* resume-url)))
    (if match
	(values (string->number (match:substring match 2))
		(string->number (match:substring match 3)))
	(values #f #f))))

(define (resume-url-surflet-name resume-url)
  (let ((match (regexp-search *resume-url-regexp* resume-url)))
    (if match
	(match:substring match 1)
	(values #f #f))))

(define (resume-url? resume-url)
  (regexp-search? *resume-url-regexp* resume-url))

(define (bad-gateway-error-response req path-string condition)
  (make-error-response 
   (status-code bad-gateway) req
   (format #f "Error in surflet ~s." path-string)
   condition))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Record types

;;; SESSION: session-table entry for every new request on a surflet page
(define-record-type session :session
  (make-session surflet-name memo 
		 continuation-table continuation-table-lock
		 continuation-counter
		 surflet-data)
  session?
  (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)
  (surflet-data session-surflet-data set-session-surflet-data!))

;;; MEMO: Information for session surveiller about session status
(define-record-type memo :memo
  (make-memo message value new-memo)
  memo?
  (message memo:message set-memo:message) ;kill, killed, adjust-timeout
  (value memo:value set-memo:value)
  (new-memo memo:new-memo set-memo:new-memo))

(define (make-default-memo)
  (make-memo 'kill #f #f))

;; caller must do locking stuff
(define (memo-killed! memo)
  (set-memo:message memo 'killed))


;;; INSTANCE: Every request corresponds to an instance.
(define-record-type instance :instance
  (make-instance session-id return-continuation)
  instance?
  (session-id really-instance-session-id 
	       set-instance-session-id!)
  (return-continuation really-instance-return-continuation 
		       set-instance-return-continuation!))


;;; OPTIONS: options for the surflet-handler
(define-record-type options :options
  (make-options surflet-path cache-surflets? session-lifetime)
  options?
  (surflet-path options:surflet-path set-options:surflet-path)
  (cache-surflets? options:cache-surflets? set-options:cache-surflets?)
  ;; session lifetime is in seconds
  (session-lifetime options:session-lifetime set-options:session-lifetime))

;; Constructor with defaults.
(define (make-default-options surflet-path)
  (make-options surflet-path #t 600))

;; Selectors for *options* (preserved-thread-fluid)
(define (make-fluid-selector selector)
  (lambda () (selector (thread-fluid *options*))))
(define (make-fluid-setter setter)
  (lambda (value)
    (setter (thread-fluid *options*) value)))
(define options-surflet-path (make-fluid-selector options:surflet-path))
(define options-cache-surflets? (make-fluid-selector options:cache-surflets?))
(define options-session-lifetime (make-fluid-selector options:session-lifetime))
(define set-options-cache-surflets? (make-fluid-setter set-options:cache-surflets?))
(define set-options-session-lifetime (make-fluid-setter set-options:session-lifetime))


;;; SURFLET-RESPONSE: Surflets are expected to return this object type.
;;; STATUS is the status code, an exact integer. See httpd/response.scm
;;;  e.g. (status-code ok)
;;; CONTENT-TYPE is a string, most probably "text/html".
;;; HEADERS is a (maybe empty) list of pairs of (string or symbol);
;;;   Additional headers to send, e.g. '(("Cache-Control" . "no-cache")) or
;;;   '((Cache-Control . "no-cache")) etc.
;;; DATA is either
;;; * a string
;;; * a list of strings
;;; This list maybe extended to vectors later.
(define-record-type surflet-response :surflet-response
  (make-surflet-response status content-type headers data)
  surflet-response?
  (status surflet-response-status)
  (content-type surflet-response-content-type)
  (headers surflet-response-headers)
  (data surflet-response-data))

;; Allowed type for the data field.
(define (valid-surflet-response-data? data)
  (or (string? data) (list? data)))

;; For debug purposes
(define (surflet-response->string surflet-response)
  (format #f "#{Surflet-response Status: ~a Content-Type: ~s Headers: ~s~%~s~%"
	  (surflet-response-status surflet-response)
	  (surflet-response-content-type surflet-response)
	  (surflet-response-headers surflet-response)
	  (surflet-response-data surflet-response)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RANDOM SOURCE

(define random
  (let* ((source  (make-random-source))
	 (random-integer (begin
			   (random-source-randomize! source)
			   (random-source-make-integers source))))
    (lambda ()
      (random-integer 1073741824))))	; I hope, 1+ billion is enough....

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEBUGGING

(define (debug fmt . args)
  (if *debug*
      (format #t "DEBUG: ~?~%" fmt args)
      (force-output)))