(module resume-unit mzscheme
  (require (lib "unitsig.ss")
           (lib "servlet-sig.ss" "web-server")
           (lib "etc.ss"))

  (provide resume@ resume^ (struct session (continuation time-stamp)))
  
  (define-signature resume^ (with-user-logged-in     ; user (-> response) -> response
                             set-resume-point!       ; user -> (union #f tst)
                             log-in!                 ; user -> void
                             log-out!                ; user -> void
                             clear-resume-table!     ; -> void
                             resume-table            ; -> (alistof user session)
                             
                             send/suspend-to-user    ; (string -> response), user -> request
                             send/finish-to-user     ; response, user -> void
                             send/forward-to-user    ; (string -> response), user -> request
                             send/back-to-user       ; response, user -> void
                             resume                  ; user [tst] -> #f
                             ))

  ;; ------------------------------------------------------------
  ;; THE RESUME TABLE
  ;; It must be outside the unit because the unit gets instantiated
  ;; once per servlet instance (in the case of unit servlets) but
  ;; the table must be instantiated only once per instantiation of
  ;; the servlet itself
  
  ;; *R* : USER -o> continuation
  ;; Maps user names to the continuation representing the farthest
  ;; point the user has reached in this web interaction
  (define *R* (make-hash-table 'equal))
  
  ;; using a mutex lock here rather than channels because it seems
  ;; slightly simpler for this minimal amount of synchronization
  (define *R-lock* (make-semaphore 1))
  
  ;; ------------------------------------------------------------
  ;; CUSTODIANS
  ;; More subtle than the continuation strategy is that servlet
  ;; instances are run with a fresh custodian that gets shut down
  ;; when the servlet-instance expires. The resume
  ;; depends on throwing back into the dynamic scope of an expired
  ;; servlet-instance, which won't work if the current-custodian
  ;; at that point has been shut down. So, when you log in, you
  ;; get a new custodian that won't get shut down until you log
  ;; out.
  (define current-user (make-parameter #f))
  (define current-servlet-custodian (make-parameter #f))
  (define previous-servlet-custodian (make-parameter #f))
  
  (define *top-level-custodian* (current-custodian))
  
  (define-struct session (continuation time-stamp))

  ;; ------------------------------------------------------------
  ;; THE RESUME@ UNIT
  ;; Defines the resume primitives.
  (define resume@ 
    (unit/sig resume^
      (import servlet^)
      
      ;; resume-table : -> (alistof user session)
      ;; returns a snapshot of the current session table
      (define (resume-table)
        (call-with-semaphore *R-lock*
          (lambda () (hash-table-map *R* cons))))
      
      ;; set-resume-point! : [USER] -> tst
      ;; sets the given resume point and returns #f. When this point is resumed to,
      ;; returns #t by default or anything the program provides as an extra optional
      ;; argument to resume.
      (define set-resume-point!
        (opt-lambda ([user (current-user)])
          (let ([vals (current-preserved-thread-cell-values)])
            (let/cc k
              (call-with-semaphore *R-lock*
                (lambda ()
                  (hash-table-get *R* user
                    (lambda ()
                      (error 'set-resume-point!
                             (string->immutable-string
                               (format "no active session for user ~a" user)))))
                  (hash-table-put! *R* user (make-session k (current-seconds))))))
            ;; Restore the parameters in the captured context. When the reified
            ;; continuation is invoked, these parameters will be restored to their
            ;; values from just before the continuation was captured.
            (current-preserved-thread-cell-values vals)
            #f)))
      
      ;; TODO: we should be able to remove log-in! from the interface and just do all
      ;;       this on the first set-resume-point!
      
      ;; log-in! : user -> void
      (define (log-in! user)
        ;; Register the user in the continuation table, but with a closure that simply
        ;; returns false instead of causing a non-local jump.
        (call-with-semaphore *R-lock*
          (lambda ()
            (hash-table-put! *R* user
              (make-session (lambda args #f) (current-seconds)))))
        (let ((session-custodian (make-custodian *top-level-custodian*)))
          (current-user user)
          (previous-servlet-custodian (current-custodian))
          (current-servlet-custodian session-custodian)
          (current-custodian session-custodian)
          (void)))
      
      ;; log-out! : [user] -> void
      ;; get rid of a user's entry in the user table
      (define log-out!
        (opt-lambda ([user (current-user)])
          (call-with-semaphore *R-lock* (lambda () (hash-table-remove! *R* user)))
          (custodian-shutdown-all (current-servlet-custodian))
          (current-custodian (previous-servlet-custodian))
          (void)))
      
      ;; with-user-logged-in : USER (-> X) -> X
      ;; runs thunk with the given user logged in
      (define (with-user-logged-in user thunk)
        (let ((session-custodian (make-custodian *top-level-custodian*)))
          (parameterize ((current-user      user)
                         (current-servlet-custodian session-custodian)
                         (current-custodian session-custodian))
            (begin0
              (thunk)
              (log-out! user)))))
      
      ;; clear-user-table! : -> void
      ;; clear the entire user table
      (define (clear-resume-table!)
        (call-with-semaphore *R-lock* (lambda () (set! *R* (make-hash-table 'equal))))
        (void))
      
      ;; send-to-user : (X -> Y) -> X [user] -> Y
      ;; abstraction over the pattern found in all the send/*-to-user functions below
      (define (send-to-user sender)
        (let ([sender* (lambda (proc)
                         (let ([vals (current-preserved-thread-cell-values)])
                           (begin0
                             (sender proc)
                             (current-preserved-thread-cell-values vals))))])
          (opt-lambda (response [user (current-user)])
            (set-resume-point! user)
            (sender* response))))

      ;; implementations of the "-to-user" versions of the web primitives
      (define send/suspend-to-user (send-to-user send/suspend))
      (define send/finish-to-user  (send-to-user send/finish))
      (define send/forward-to-user (send-to-user send/forward))
      (define send/back-to-user    (send-to-user send/back))
      
      ;; resume : user [tst] -> #f
      ;; if the user has a current session, this function
      ;; does not return and instead throws to the continuation
      ;; representing that session. Otherwise returns false.
      (define resume
        (opt-lambda (user [resume-value #t])
          (let ((session (call-with-semaphore *R-lock* (lambda () (hash-table-get *R* user (lambda () #f))))))
            (if session
                ((session-continuation session) resume-value)
                #f)))))))