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

;; the servlet handler
;; Copyright Andreas Bernauer, 2002


;(define-record-type continuation-table-entry :continuation-table-entry
;  (make-continuation-table-entry continuation)
;  continuation-table-entry?
;  (id continuation-table-entry-id set-continuation-table-entry-id!)
;  (continuation continuation-table-entry-continuation
;		set-continuation-table-entry-continuation!))


;;; instance-table: entry for every new request on a servlet page
(define-record-type instance :instance
  (make-instance servlet-name continuation-table)
  instance?
  (servlet-name really-instance-servlet-name
		set-instance-servlet-name!)
  (continuation-table really-instance-continuation-table 
		      set-instance-continuation-table!))

(define-record-type session :session
  (really-make-session instance-id return-continuation)
  session?
  (instance-id really-session-instance-id 
	       set-session-instance-id!)
  (return-continuation really-session-return-continuation 
		       set-session-return-continuation!))

;; FIXME: Make this thread-safe
(define *instance-table* (make-integer-table)) ; instance-id is index
(define random (make-random (modulo (time)268435455))) ; not really random
						       ; generator

(define (servlet-handler servlet-path)
  (lambda (path req)
    (if (pair? path)			; need at least one element
	(let ((request-method (request:method req))
	      (full-path (uri-path-list->path path)))
	  (cond
	   ((string=? full-path "profile") ; triggers profiling
	    (http-syslog (syslog-level debug)
			 "profiling: triggered in servlet-handler [~a]"
			 (profile-space)) ; PROFILE
	    (make-http-error-response http-status/accepted req "profiled"))
	   ((string=? full-path "reset")	; triggers cache clearing
	    (http-syslog (syslog-level debug)
			 "servlet-handler: clearing plugin cache")
	    (reset-plugin-cache!)
	    (make-http-error-response http-status/accepted req "plugin cache cleared"))
	   ((or (string=? request-method "GET")
		(string=? request-method "PUT"))
	    (with-cwd
	     servlet-path
	     (if (resume-url? full-path)
		 (resume-url full-path req)
		 (launch-new-instance full-path req))))
	   (else
	    (make-http-error-response http-status/method-not-allowed req 
				      request-method))))
	(make-http-error-response http-status/bad-request req 
				  (format #f "Bad path: ~s" path)))))

;; FIXME: test for file existance
(define (launch-new-instance full-path req)
  (let ((instance-id (generate-new-instance-id))
	(plugin (get-plugin-rt-structure full-path)))
    (reset
     (begin
       (save-instance! full-path instance-id)	; make entry in instance-table
       (register-session! instance-id 'no-return)
       (with-names-from-rt-structure 
	plugin plugin-interface 
	;; MAIN may return in another thread, so we have to lookup 
	;; return continuation explicitly
	(main req))))))

;; try to get continuation-table and then the continuation
(define (resume-url full-path req)
  (call-with-current-continuation
   (lambda (return)
     (with-fatal-error-handler*
      (lambda (condition decline)
	(return (make-http-error-response
		 http-status/bad-request req
		 (format #f "The servlet does not accept any requests any more or your URL is illformed.<BR>
You can try starting at the <A HREF=~a>beginning</a>."
			 (resume-url-servlet-name full-path)))))
      (lambda ()
	(receive (instance-id continuation-id)
	    (resume-url-ids full-path)

	  (let* ((continuation-table (instance-continuation-table instance-id))
		 (resume (table-ref continuation-table continuation-id)))
	    (if resume
		(reset
		 (begin
		   (register-session! instance-id 'no-return)
;		   (error "This may never return." ; for debugging
			  (resume req)))))))))))
  
	
(define (send/suspend response-maker)
  (shift return
	 (let* ((instance-id (session-instance-id))
		(continuations-table (instance-continuation-table instance-id))
		(continuation-id (generate-new-continuation-id instance-id)))
	   (table-set! continuations-table continuation-id return)
	   (let ((new-url (make-resume-url (instance-servlet-name instance-id)
					   instance-id 
					   continuation-id)))
	     (response-maker new-url)))))

(define (send/finish response)
  (instance-delete (session-instance-id))
  response)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; access to instance-table
(define (save-instance! servlet-name instance-id)
  (table-set! *instance-table* instance-id
	      (make-instance servlet-name (make-integer-table))))
;; FIXME: make continuation-table thread-safe

(define (instance instance-id)
  (table-ref *instance-table* instance-id))

(define (instance-servlet-name instance-id)
  (really-instance-servlet-name (instance instance-id)))

(define (instance-continuation-table instance-id)
  (really-instance-continuation-table (instance instance-id)))

(define (instance-delete instance-id)
  (table-set! *instance-table* instance-id #f))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ID generation  
;; FIXME: make this thread safe
;; FIXME: this may loop forever, if the table is full
;;(max. 2**28-1 instances)
(define (generate-new-instance-id)
  (let loop ((instance-id (random)))
    (if (instance instance-id)
	(loop (random))
	instance-id)))


;; FIXME make this thread-safe (locks)
;; FIXME this may loop forever, if the table is full 
;; (max. 2**28-1 continuations)
(define (generate-new-continuation-id instance-id)
  (let ((continuation-table (instance-continuation-table instance-id)))
    (let loop ((continuation-id (random)))
      (if (table-ref continuation-table continuation-id)
	  (loop (random))
	  continuation-id))))
				    

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PLUGINs CACHE
;; FIXME: make this thread-safe
(define *plugin-table* (make-string-table)) ; full-path is index
(define plugin-table-lock (make-lock))

;; FIXME: reload  plugin if timestamp has changed
;; PLUGIN-NAME is like "news-dir/latest-news.scm"
(define (get-plugin-rt-structure plugin-name)
  (let ((plugin (table-ref *plugin-table* plugin-name)))
    (if plugin
	plugin
	(with-fatal-error-handler*
	 (lambda (condition decline)
	   (release-lock plugin-table-lock)
	   (decline))
	 (lambda ()
	   (obtain-lock plugin-table-lock)
	   ;; load-config-file does not care about cwd(?)
	   ;; --> absolute file name needed
	   (load-config-file (absolute-file-name plugin-name))
	   ;; plugin-structure to load must be named "plugin"
	   (let ((plugin-structure (reify-structure 'plugin)))
	     (load-structure plugin-structure)
	     (table-set! *plugin-table* plugin-name plugin-structure)
	     (release-lock plugin-table-lock)
	     plugin-structure))))))

(define (reset-plugin-cache!)
  (with-fatal-error-handler*
   (lambda (condition decline)
     (release-lock plugin-table-lock)
     (decline))
   (lambda ()
     (obtain-lock plugin-table-lock)
     (set! *plugin-table* (make-string-table))
     (release-lock plugin-table-lock))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SESSION
(define *session* (make-thread-cell #f))

(define (register-session! instance-id return-continuation)
  (thread-cell-set! *session* 
		    (really-make-session instance-id return-continuation)))


;(define (save-session-return-continuation! return-continuation)
;  (set-session-instance-id! (thread-cell-ref *session*)
;			    return-continuation))

(define (session-instance-id)
  (really-session-instance-id (thread-cell-ref *session*)))

(define (session-return-continuation)
  (really-session-return-continuation (thread-cell-ref *session*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RESUME-URL
(define *resume-url-regexp* (rx (submatch (* (- printing ";"))) 
				";k" (submatch (* digit)) ; Instance-ID
				";c" (submatch (* digit)))) ; Continuation-ID

(define (make-resume-url full-path instance-id continuation-id)
  (string-append full-path
		 ";k" (number->string instance-id)
		 ";c" (number->string continuation-id)))

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

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

(define (resume-url-ids id-url)
  (let ((match (regexp-search *resume-url-regexp* id-url)))
    (if match
	(values (string->number (match:substring match 2))
		(string->number (match:substring match 3)))
	(error "resume-url-ids: no instance/continuation id" id-url))))

(define (resume-url-servlet-name id-url)
  (let ((match (regexp-search *resume-url-regexp* id-url)))
    (if match
	(match:substring match 1)
	(error "resume-url-servlet-name: no servlet-name found"))))

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