;;;; timed-resource.scm
;;;; Kon Lovett, Oct '09

;; Issues
;;
;; - Uses thread-terminate!

; Chicken Generic Arithmetic!

(module timed-resource

  (;export
    timed-resource-timeout
    make-timed-resource
    timed-resource?
    timed-resource-name
    with-timed-resource)

  (import
    scheme
    chicken
    (only data-structures ->string)
    (only srfi-1
      delete!)
    (only srfi-18
      make-thread
      thread-start! thread-join!
      thread-sleep! thread-terminate! thread-signal!
      make-mutex mutex-name
      terminated-thread-exception? uncaught-exception?)
    (only synch
      make-object/synch object?/synch
      synch-with set!/synch record/synch
      %synch-with %set!/synch %record/synch)
    (only type-checks
      check-procedure check-number check-positive-number
      define-check+error-type)
    (only thread-utils
      print-exception-error
      thread-unblock!)
    (only thread-reaper
      thread-reaper-shutdown? thread-reap!)
    (only record-variants
      define-record-type-variant))

  (require-library
    data-structures
    srfi-1 srfi-18
    record-variants
    synch
    thread-utils thread-reaper
    type-checks)

;;

(define-record-type-variant timed-resource
  (unsafe unchecked inline)
  (%make-timed-resource op cl to mtx th it)
  %timed-resource?
  (op @timed-resource-open)
  (cl @timed-resource-close)
  (to timed-resource-timeout)
  (mtx timed-resource-mutex)
  (th timed-resource-thread timed-resource-thread-set!)
  (it timed-resource-item timed-resource-item-set!) )

(define-check+error-type timed-resource %timed-resource?)

(define (timed-resource? obj) (%timed-resource? obj))

(define (timed-resource-name tr)
  ;Not completely happy with this
  (mutex-name (timed-resource-mutex tr)) )

;; Open & close a Resource

(define (timed-resource-close tr)
  (let ((res (timed-resource-item tr)))
    ;Drop the ref just in case the closer blows up
    (timed-resource-item-set! tr #f)
    ((@timed-resource-close tr) res) ) )

(define (timed-resource-open! tr)
  (timed-resource-item-set! tr ((@timed-resource-open tr))) )

;catchs & returns exception conditions
(define (checked-timed-resource-close tr succflag)
  (call-with-current-continuation
    (lambda (return)
      (with-exception-handler
        (lambda (exn) (return exn))
        (lambda () (timed-resource-close tr) succflag)))) )

;; Set of timed resources

(define-constant DEFAULT-SHUTDOWN-TIMEOUT #f)

(define +timed-resources+ #f) ;The set of timed resource objects
(define +shutdown?+ #f)       ;Program shutdown?
(define +timeout+ DEFAULT-SHUTDOWN-TIMEOUT)

;Cleanly shutdown remaining timed-resources.
;Cannot use the reaper since it can shutdown before we do!

(define UNBLOCKED-TAG '#(timed-resource-unblocked))
(define CLOSED-TAG '#(timed-resource-closed))

;Note that the set of timed resource objects is kept only for shutdown
;processing.
(define (shutdown-timed-resources!)
  (set! +shutdown?+ #t)
  (when +timed-resources+
    (%synch-with +timed-resources+ trs
      ;Release every blocked timed-resource and "manually" reap. Note that if
      ;the tr is still in the list then it is not queued by the reaper!
      (for-each
        (lambda (tr)
          (let ((th (timed-resource-thread tr)))
            (thread-unblock! th)
            (thread-signal! th UNBLOCKED-TAG)
            (thread-join! th +timeout+) ) )
        trs) ) ) )

#; ;UNUSED
(define (timed-resource-terminate! tr)
  (let ((th (timed-resource-thread tr)))
    (thread-terminate! th)
    (when (timed-resource-item tr)
      (let ((res (checked-timed-resource-close tr CLOSED-TAG)))
        (unless (eq? CLOSED-TAG res) (print-exception-error res)) ) )
    (handle-exceptions exn
        (cond
          ((and (uncaught-exception? exn)
                (terminated-thread-exception? (uncaught-exception-reason exn)))
            ) ;Expecting so ignore
          (else
            (print-exception-error exn) ) )
      (thread-join! th) ) ) )

(define (setup-timed-resource)
  (set! +timed-resources+ (make-object/synch '() 'timed-resources))
  (on-exit shutdown-timed-resources!) )

(define (add-timed-resource! tr)
  (unless +timed-resources+ (setup-timed-resource)) ;Only done once
  (%set!/synch (trs +timed-resources+) (cons tr trs)) )

(define (remove-timed-resource! tr)
  (%set!/synch (trs +timed-resources+) (delete! tr trs eq?)) )

;; The timer thread

;returns CLOSED-TAG for success, otherwise an exception object
(define (release-timed-resource! tr)
  (let ((th (timed-resource-thread tr)))
    #;(assert (eq? (current-thread) th)) ;used only by a tr!
    ;(can use weaker synch since close catchs exceptions)
    (%record/synch timed-resource tr
      ;(returns any exception conditions or CLOSED-TAG for success)
      (let ((res (checked-timed-resource-close tr CLOSED-TAG)))
        (cond
          ;When teminating anyway no exceptions but make a note of any problem
          ((or +shutdown?+ (thread-reaper-shutdown?))
            (unless (eq? CLOSED-TAG res) (print-exception-error res th))
            CLOSED-TAG )
          (else
            (remove-timed-resource! tr)
            (thread-reap! th)
            res ) ) ) ) ) )

(define (make-timed-resource-timer-thunk tr)
  (lambda ()
    ;We're active
    (add-timed-resource! tr)
    ;Allow "timeout" seconds of access
    (handle-exceptions exn
        ;Early unblock only "handled exception"
        (unless (eq? UNBLOCKED-TAG exn) (abort exn))
      (thread-sleep! (timed-resource-timeout tr)) )
    ;Release the resource but propagate any exceptions
    (let ((res (release-timed-resource! tr)))
      (unless (eq? CLOSED-TAG res) (abort res)) ) ) )

(define (start-timed-resource-timer! tr)
  (let ((th (make-thread
              (make-timed-resource-timer-thunk tr)
              (timed-resource-name tr))))
    (timed-resource-thread-set! tr th)
    (thread-start! th) ) )

;; Get a timed resource

(define (timed-resource-start! tr)
  ;Open resource before starting the timer thread so the overhead doesn't count
  ;(and any exceptions can propagate in caller's thread)
  (timed-resource-open! tr)
  (start-timed-resource-timer! tr)
  (timed-resource-item tr) )

;; Get a resource object

(define (timed-resource-aquire tr)
  ;Just return resource if already open, otherwise begin a timed open of the
  ;resource
  (or (timed-resource-item tr)
      (timed-resource-start! tr) ) )

(define (make-timed-resource-name name)
  (gensym (string-append (->string name) "-")) )

;;;

(define (timed-resource-timeout . args)
  (if (null? args) +timeout+
    (let ((to (car args)))
      (set! +timeout+
        (and to (check-positive-number 'timed-resource-timeout to))) ) ) )

(define (make-timed-resource opener closer timeout #!optional (name 'timed-resource))
  (unless (or +shutdown?+ (thread-reaper-shutdown?)) ;Shouldn't be necessary
    (check-procedure 'make-timed-resource opener 'open-procedure)
    (check-procedure 'make-timed-resource closer 'close-procedure)
    (check-number 'make-timed-resource timeout 'timeout)
    (%make-timed-resource
      opener closer timeout
      (make-mutex (make-timed-resource-name name))
      #f #f) ) )

(define (with-timed-resource tr proc)
  (unless (or +shutdown?+ (thread-reaper-shutdown?)) ;Shouldn't be necessary
    (check-timed-resource 'with-timed-resource tr)
    (check-procedure 'with-timed-resource proc)
    (record/synch timed-resource tr (proc (timed-resource-aquire tr))) ) )

) ;module timed-resource