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

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


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

(define-record-type session :session
  (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!))

(define *instance-table* (make-integer-table)) ; instance-id is index
(define *instance-table-lock* (make-lock))
(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....

(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 "POST"))        ; do this at later time
		)
	    (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)))))

(define (launch-new-instance full-path req)
  (if (file-not-exists? full-path)
      (make-http-error-response http-status/not-found req full-path)
      (begin
	(obtain-lock *instance-table-lock*)
	;; no access to instance table until new instance-id is saved
	(let ((instance-id (generate-new-table-id *instance-table*)))
	  (table-set! *instance-table* instance-id
		      (make-instance full-path    ; used to make
						  ; redirections to origin
				     (make-integer-table) ; continuation table
				     (make-lock)          ; continuation table lock
				     (make-thread-safe-counter))) ; continuation counter
	  (release-lock *instance-table-lock*)
	  (let ((plugin (with-fatal-error-handler*
			 (lambda (condition decline)
			   (instance-delete! instance-id)
			   (decline)) 
			 (lambda () 
			   (get-plugin-rt-structure full-path)))))
	    (reset
	     (begin
	       (register-session! instance-id 'no-return)
	       (with-names-from-rt-structure 
		plugin plugin-interface 
		(main req)))))))))

;; try to get continuation-table and then the continuation
(define resume-url
  (let ((bad-request 
	 (lambda (full-path req)
	   (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)))))
	(lookup-continuation-table
	  (lambda (instance continuation-table continuation-id)
	    (let ((continuation-table-lock (instance-continuation-table-lock instance)))
	      (obtain-lock continuation-table-lock)
	      (let ((result (table-ref continuation-table continuation-id)))
		(release-lock continuation-table-lock)
		result)))))

    (lambda (full-path req)
      (receive (instance-id continuation-id)
	  (resume-url-ids full-path)
	(let ((instance (instance-lookup instance-id)))
	  (if instance
	      (let* ((continuation-table (instance-continuation-table instance))
		     (resume (lookup-continuation-table instance continuation-table 
							continuation-id)))
		(if resume
		    (reset
		     (begin
		       (register-session! instance-id 'no-return)
;		       (error "This may never return." ; for debugging
		       (resume req)))
		    (bad-request full-path req)))
	      (bad-request full-path req)))
      ))))
    

(define (send-html/suspend html-tree-maker)
  (shift return
	 (let* ((instance-id (session-instance-id))
		(instance (instance-lookup instance-id))
		(continuations-table (instance-continuation-table instance))
		(continuation-table-lock (instance-continuation-table-lock instance))
		(continuation-counter (instance-next-continuation-counter instance)))
	   (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 (instance-servlet-name instance)
					     instance-id 
					     continuation-counter
					     continuation-id)))
	       (make-usual-html-response
		(lambda (out options)
		  (with-current-output-port*
		   out
		   (lambda () (SXML->HTML (html-tree-maker new-url)))))))))))

(define (send-html/finish html-tree)
  (instance-delete! (session-instance-id))
  (make-usual-html-response
   (lambda (out options)
     (with-current-output-port*		; FIXME: will change in further revision
      out
      (lambda ()  (SXML->HTML html-tree))))))

(define (make-usual-html-response writer-proc)
  (make-response
   http-status/ok
   (status-code->text http-status/ok)
   (time)
   "text/html"
   '()
   (make-writer-body writer-proc)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; access to instance-table
(define (instance-lookup instance-id)
  (obtain-lock *instance-table-lock*)
  (let ((result (table-ref *instance-table* instance-id)))
    (release-lock *instance-table-lock*)
    result))

(define (instance-next-continuation-counter instance)
  (thread-safe-counter-next! 
   (instance-continuation-counter instance)))

(define (instance-delete! instance-id)
  (obtain-lock *instance-table-lock*)
  ;; why can't table entries be deleted correctly?
  (table-set! *instance-table* instance-id #f)
  (release-lock *instance-table-lock*))
 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ID generation  
;; locking must be done by caller
;; FIXME?: this may loop forever, if the table is full (can this happen?)
(define (generate-new-table-id table)
  (let loop ((id (random)))
    (if (table-ref table id)
	(loop (random))
	id)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PLUGINs CACHE
(define *plugin-table* (make-string-table)) ; full-path is index
(define *plugin-table-lock* (make-lock))

;; PLUGIN-NAME is like "news-dir/latest-news.scm"
(define (get-plugin-rt-structure plugin-name)
  (let ((load-plugin 
	 (lambda ()
	   (with-fatal-error-handler*
	    (lambda (condition decline)
	      (release-lock *plugin-table-lock*)
	      (decline))
	    (lambda ()
	      ;; 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 
			    (cons plugin-structure
				  (file-last-mod plugin-name)))
		;; only now the lock may be released
		(release-lock *plugin-table-lock*)
		plugin-structure))))))

  (obtain-lock *plugin-table-lock*)
  (let ((plugin (table-ref *plugin-table* plugin-name)))
    (if plugin
	(if (equal? (file-last-mod plugin-name) 
		    (cdr plugin))
	    (begin
	      (release-lock *plugin-table-lock*)
	      (car plugin))
	    (load-plugin))
	(load-plugin)))))

(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* 
		    (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" (+ digit) "-" (submatch (* digit)))) ; Continuation-ID

(define (make-resume-url full-path instance-id continuation-counter continuation-id)
  (string-append full-path
		 ";k" (number->string (session-instance-id)) 
		 ";c" (number->string continuation-counter)
		 "-" (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))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; thread-safe counter

(define-record-type counter :counter
  (really-make-counter counter lock)
  (counter counter-counter set-counter-counter!)
  (lock counter-lock))

(define (make-thread-safe-counter)
  (really-make-counter 0 (make-lock)))

;;; read current value
(define (thread-safe-counter counter)
  (obtain-lock (counter-lock counter))
  (let ((result (counter-counter counter)))
    (release-lock (counter-lock counter))
    result))

;;; make next value and return it
(define (thread-safe-counter-next! counter)
  (obtain-lock (counter-lock counter))
  (let ((result (+ 1 (counter-counter counter))))
    (set-counter-counter! counter result)
    (release-lock (counter-lock counter))
    result))





; instance-table thread safe
; continuation-table thread safe
; generate-new-instance-id only called if thread safe
; generate-new-continuation-id only called if thread safe
; respect plugin timestamp