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

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


(define *debug* #t)

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

(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))

(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-record-type options :options
  (make-options servlet-path servlet-prefix cache-servlets? instance-lifetime)
  options?
  (servlet-path options:servlet-path set-options:servlet-path)
  (servlet-prefix options:servlet-prefix set-options:servlet-prefix)
  (cache-servlets? options:cache-servlets? set-options:cache-servlets?)
  ;; instance lifetime is in seconds
  (instance-lifetime options:instance-lifetime set-options:instance-lifetime))

(define (make-default-options servlet-path servlet-prefix)
  (make-options servlet-path servlet-prefix #t 600))

(define *options* (make-preserved-thread-fluid #f))
;; preserved thread fluid because between different calls to
;; servlet-handler the options shall remain the same.

(define (make-fluid-selector selector)
  (lambda () (selector (thread-fluid *options*))))
(define (make-fluid-setter setter)
  (lambda (value)
    (setter (thread-fluid *options*) value)))
(define options-servlet-path (make-fluid-selector options:servlet-path))
(define options-servlet-prefix (make-fluid-selector options:servlet-prefix))
(define options-cache-servlets? (make-fluid-selector options:cache-servlets?))
(define options-instance-lifetime (make-fluid-selector options:instance-lifetime))
(define set-options-cache-servlets? (make-fluid-setter set-options:cache-servlets?))
(define set-options-instance-lifetime (make-fluid-setter set-options:instance-lifetime))

(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....

;; Servlet-prefix gives virtual prefixed path to servlets. Currently,
;; it is ignored.
(define (servlet-handler servlet-path . servlet-prefix)
  (set-thread-fluid! *options* (make-default-options servlet-path servlet-prefix))
  (lambda (path req)
    (if (pair? path)			; need at least one element
	(let ((request-method (request:method req))
	      (path-string (uri-path-list->path path)))
	  (if (or (string=? request-method "GET")
		  (string=? request-method "POST"))
	      (let ((response 
		     (if (resume-url? path-string)
			 (resume-url path-string servlet-path req)
			 (launch-new-instance path-string servlet-path req))))
;		(if (redirect-body? (response-body response))
;		    (let ((target (redirect-body-location (response-body response))))
;		      (if (relative? target)
;			  ;; Pefix it with servlet-prefix.
;			  (make-redirect-response 
;			   (path-list->file-name
;			    (list (directory-as-file-name servlet-prefix)
;				  target)))
;			  response))
		response)
	      (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 path-string servlet-path req)
  (cond 
   ((file-not-exists? (absolute-file-name path-string servlet-path))
    (make-http-error-response http-status/not-found req path-string))
   ((string=? (file-name-extension path-string) ".scm")
    (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*))
	  (memo (make-default-memo)))
      (table-set! *instance-table* instance-id
		  (make-instance 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))	              ; servlet-data
      (release-lock *instance-table-lock*)
      (register-session! instance-id 'no-return)
      (let ((servlet 
	     (with-fatal-error-handler
	      (lambda (condition decline)
		(delete-instance! instance-id)
		(decline)) 
	      (get-servlet-rt-structure path-string servlet-path))))
	(fork-thread (instance-surveillance instance-id
					    (+ (time)
					       (options-instance-lifetime))
					    memo))
	(reset
	 (call-with-current-continuation
	  (lambda (exit)
	    (with-handler
	     (lambda (condition more)
	       (exit
		(make-http-error-response 
		 http-status/bad-gateway req
		 (format #f "Internal error while executing servlet ~s." path-string)
		 condition)))
	     (lambda ()
	       (with-cwd
		   servlet-path
		   (with-names-from-rt-structure 
		    servlet servlet-interface 
		    (main req)))))))))))
   (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 servlet-path)))
;      (send-file-response full-file-name
;			  (file-info full-file-name)
;			  req))
    (make-http-error-response http-status/forbidden req
			      "Can't serve other than Scheme files."
			      path-string))
   ))

(define (instance-surveillance instance-id time-to-die memo)
  (lambda ()
    (let loop ((time-to-die time-to-die)
	       (memo memo))
      (debug "instance-surveillance[~s]: going to sleep until ~a"
	     instance-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 "instance-surveillance[~s]: instance already killed, dieing"
		 instance-id)
	 )
	((adjust-timeout)		; new timeout
	 (debug "instance-surveillance[~s]: adjusting timeout" instance-id)
	 (loop (memo:value memo) 
	       (memo:new-memo memo)))
	((kill)				; kill instance
	 (debug "instance-surveillance[~s]: killing" 
		 instance-id)
	 (obtain-lock *instance-table-lock*)
	 (table-set! *instance-table* instance-id #f)
	 (release-lock *instance-table-lock*))
	(else
	 (format (current-error-port) 
		 "instance-surveillance[~s]: unknown message ~s; dieing"
		 instance-id (memo:message memo)))))))
      

;; try to get continuation-table and then the continuation
(define resume-url
  (let ((bad-request 
	 (lambda (path-string req)
	   (make-http-error-response
	    http-status/bad-request req
	    (format #f 
		    "<br>
<p>There may be several reasons, why your request for a servlet was denied:
<ul>
<li>The servlet does not accept any requests any more.</li>
<li>The servlet URL has timed out.</li>
<li>You URL is illformed.</li>
</ul>
</p>
<p>In any case, you may try to restart the servlet from the <a href=\"~a\">beginning</a>. Your browser may also have cached an old instance of this servlet. In this case, try to reload the page.</p>"
		    (resume-url-servlet-name path-string)))))
	(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 (path-string servlet-path req)
      (receive (instance-id continuation-id)
	  (resume-url-ids path-string)
	(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
		    (with-cwd
		     servlet-path
		     (reset
		      (begin
			(register-session! instance-id 'no-return)
			(resume req))))
		    (bad-request path-string req)))
	      (bad-request path-string req)))
	))))


(define (send/suspend response-maker)
  (shift return
	 (let* ((instance-id (session-instance-id))
		(instance (instance-lookup instance-id)))
	   ;;  the session might be deleted in the meanwhile
	   (if instance
	       (begin
		 (instance-adjust-timeout! instance-id)
		 (let ((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)))
		       (response-maker new-url)))))
	       (make-http-error-response http-status/not-found #f
					 "The URL refers to a servlet, whose instance is no longer alive.")))))

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

(define (send response)
  (shift unsused response))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 (delete-instance! instance-id)
  (obtain-lock *instance-table-lock*)
  ;; notify surveillance of instance being alread killed (prevents
  ;; surveillance of killing new instance that has the same number by
  ;; accident)
  (let ((instance (table-ref *instance-table* instance-id)))
    (memo-killed! (instance-memo instance)))
  ;; why can't table entries be deleted correctly?
  (table-set! *instance-table* instance-id #f)
  (release-lock *instance-table-lock*))
 
(define (instance-adjust-timeout! instance-id)
  (obtain-lock *instance-table-lock*)
  (let* ((instance (table-ref *instance-table* instance-id))
	 (memo (instance-memo instance))
	 (new-memo (make-default-memo)))
    ;; Do it this way: new values and then new message
    (set-memo:value memo 
		    (+ (time) 
		       (options-instance-lifetime)))
    (set-memo:new-memo memo new-memo)
    ;; I don't think we need locking here. Do you agree?
    (set-instance-memo! instance new-memo)
    (set-memo:message memo 'adjust-timeout))
  (release-lock *instance-table-lock*))

;; adjusts the timeout of the current instance
(define (adjust-timeout)
  (instance-adjust-timeout! (session-instance-id)))

(define (reset-instance-table!)
  (with-fatal-error-handler
   (lambda (condtion decline)
     (release-lock *instance-table-lock*)
     (decline))
   (lambda ()
     (obtain-lock *instance-table-lock*)
     ;; notify instance killing
     (table-walk 
      (lambda (instance-id instance)
	(memo-killed! (instance-memo instance)))
      *instance-table*)
     (set! *instance-table* (make-integer-table))
     (release-lock *instance-table*))))

(define (get-instances)
  (obtain-lock *instance-table-lock*)
  (let ((instances '()))
    (table-walk
     (lambda (instance-id instance-entry)
       (set! instances (cons (cons instance-id instance-entry) instances)))
     *instance-table*)
    (release-lock *instance-table-lock*)
    instances))

(define (get-continuations instance-id)
  (let ((instance (instance-lookup instance-id)))
    (if instance
	(let ((continuation-table-lock (instance-continuation-table-lock instance))
	      (continuation-table (instance-continuation-table instance))
	      (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)
	'())))

(define (delete-continuation! instance-id continuation-id)
  (let ((instance (instance-lookup instance-id)))
    (if instance
	(let ((continuation-table-lock (instance-continuation-table-lock instance))
	      (continuation-table (instance-continuation-table instance))
	      (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)))))
	
(define (set-servlet-data! new-data)
  (let ((instance (instance-lookup (session-instance-id))))
    (if instance
	(begin
	  (set-instance-servlet-data! instance new-data)
	  #t)
	#f)))

(define (get-servlet-data)
  (let ((instance (instance-lookup (session-instance-id))))
    (if instance
	(instance-servlet-data instance)
	(error "Instance no longer alive."))))
	
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SERVLETs CACHE
(define *servlet-table* (make-string-table)) ; path-string is index
(define *servlet-table-lock* (make-lock))

;; SERVLET-NAME is like "news-dir/latest-news.scm"
(define (get-servlet-rt-structure servlet-name directory)
  (let* ((full-servlet-name (absolute-file-name servlet-name directory))
	 (load-servlet 
	  (lambda (cached?)
	    (with-fatal-error-handler*
	     (lambda (condition decline)
	       (if cached? (release-lock *servlet-table-lock*))
	       (decline))
	     (lambda ()
	       ;; load-config-file does not care about cwd(?)
	       ;; --> absolute file name needed
	       (load-config-file full-servlet-name)
	       ;; servlet-structure to load must be named "servlet"
	       (let ((servlet-structure (reify-structure 'servlet)))
		 (load-structure servlet-structure)
		 (if cached?
		     (begin
		       (table-set! *servlet-table* full-servlet-name 
				   (cons servlet-structure
					 (file-last-mod full-servlet-name)))
		       ;; only now the lock may be released
		       (release-lock *servlet-table-lock*)))
		 servlet-structure))))))
    (if (options-cache-servlets?)
	(begin
	  ;; The lock is only obtained and released, if servlets are
	  ;; cached. LOAD-SERVLET gets the CACHED? parameter, so
	  ;; nothing may happen, if in the meanwhile caching is turned
	  ;; off.
	  (obtain-lock *servlet-table-lock*)
	  (let ((servlet (table-ref *servlet-table* full-servlet-name)))
	    (if servlet
		(if (equal? (file-last-mod full-servlet-name) 
			    (cdr servlet))
		    (begin
		      (release-lock *servlet-table-lock*)
		      (car servlet))
		    (load-servlet #t))
		(load-servlet #t))))
	(load-servlet #f))))

(define (get-loaded-servlets)
  (obtain-lock *servlet-table-lock*)
  (let ((loaded-servlets '()))
    (table-walk
     (lambda (servlet-path rt-structure)
       (set! loaded-servlets (cons servlet-path loaded-servlets)))
     *servlet-table*)
    (release-lock *servlet-table-lock*)
    loaded-servlets))

(define (unload-servlet servlet-name)
  (obtain-lock *servlet-table-lock*)
  (if (table-ref *servlet-table* servlet-name)
      (table-set! *servlet-table* servlet-name #f))
  (release-lock *servlet-table-lock*))

(define (reset-servlet-cache!)
  (with-fatal-error-handler*
   (lambda (condition decline)
     (release-lock *servlet-table-lock*)
     (decline))
   (lambda ()
     (obtain-lock *servlet-table-lock*)
     (set! *servlet-table* (make-string-table))
     (release-lock *servlet-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 path-string instance-id continuation-counter continuation-id)
  (string-append path-string
		 ";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))


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