;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate for CHICKEN.
;; Copyright (c) 2011 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

;;; Support for suspended computations (and directly related stuff)

(define max-suspended-resources
  (make-parameter 1024))

(define max-suspended-resources-load
  (make-parameter 0.75))

(define suspended-resource-handler
  (let ((handler
	 (let ((mutex (make-mutex 'suspended-resources)))
	   (mutex-specific-set!
	    mutex (make-hash-table #:test string-ci=? #:hash string-ci-hash))
	   (lambda (resume/uuid)
	     (dynamic-wind
		 (cut mutex-lock! mutex)
		 (lambda ()
		   (let ((table (mutex-specific mutex)))
		     (if (procedure? resume/uuid)
			 (let ((size (hash-table-size table))
			       (max-size (max-suspended-resources)))
			   (when (>= size max-size)
			     (let* ((max-load (max-suspended-resources-load))
				    (num-drop (- size (* max-size max-load))))
			       (for-each
				(cut hash-table-delete! table <>)
				(take
				 (sort! (hash-table-keys table)
					(lambda (a b)
					  (< (uuid-time a) (uuid-time b))))
				 (inexact->exact (ceiling num-drop))))))
			   (let ((uuid (make-uuid 'time)))
			     (hash-table-set! table uuid resume/uuid)
			     uuid))
			 (hash-table-ref/default table resume/uuid #f))))
		 (cut mutex-unlock! mutex))))))
    (case-lambda
     (()
      handler)
     ((proc)
      (set! handler proc)))))

(define-resource (suspended "suspended" uuid parameters)
  (cond
   (((suspended-resource-handler) uuid)
    => (cut <> parameters))
   (else
    (make-error-response
     404 "The requested suspended resource was not found on the server."))))

(define (send/suspend proc)
  (call-with-current-continuation
   (lambda (resume)
     (let ((uuid ((suspended-resource-handler) resume)))
       ((resource-context-return (current-resource-context))
	(proc (resource-uri suspended uuid)))))))