scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

use with-lock instead of obtain-lock/release-lock

This commit is contained in:
interp 2003-04-13 18:27:43 +00:00
parent 956fd7bbf1
commit 4b08eac262
1 changed files with 83 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

195
scheme/httpd/surflets/surflet-handler.scm
View File

@ -72,19 +72,19 @@
(surflet-request-request s-req) path-string)) (surflet-request-request s-req) path-string))
((string=? (file-name-extension path-string) ".scm") ((string=? (file-name-extension path-string) ".scm")
(obtain-lock *session-table-lock*) (receive (session-id lifetime)
;; no access to session table until new session-id is saved (with-lock *session-table-lock*
(let ((session-id (generate-new-table-id *session-table*)) (let ((session-id (generate-new-table-id *session-table*))
(lifetime (options-session-lifetime))) (lifetime (options-session-lifetime)))
(table-set! *session-table* session-id (table-set! *session-table* session-id
(make-session path-string ; used to make (make-session path-string ; used for redirections
; redirections to origin (make-integer-table) ; continuation table
(make-integer-table) ; continuation table (make-lock) ; continuation table lock
(make-lock) ; continuation table lock (make-thread-safe-counter) ; continuation counter
(make-thread-safe-counter) ; continuation counter #f ; session-data
#f ; session-data lifetime))
lifetime)) (values session-id lifetime)))
(release-lock *session-table-lock*) ;; no access to session table until new session-id is saved
(register-instance! session-id) (register-instance! session-id)
(with-fatal-error-handler (with-fatal-error-handler
@ -93,7 +93,7 @@
(delete-session! session-id) (delete-session! session-id)
(bad-gateway-error-response s-req path-string condition)) (bad-gateway-error-response s-req path-string condition))
(let ((surflet (get-surflet-rt-structure path-string surflet-path))) (let ((surflet (get-surflet-rt-structure path-string surflet-path)))
(timeout-queue-register-session! session-id (+ (time) lifetime)) (timeout-queue-register-session! session-id (+ (time) lifetime))
(reset (reset
(with-fatal-error-handler (with-fatal-error-handler
@ -163,10 +163,8 @@
(lookup-continuation-table (lookup-continuation-table
(lambda (session continuation-table continuation-id) (lambda (session continuation-table continuation-id)
(let ((continuation-table-lock (session-continuation-table-lock session))) (let ((continuation-table-lock (session-continuation-table-lock session)))
(obtain-lock continuation-table-lock) (with-lock continuation-table-lock
(let ((result (table-ref continuation-table continuation-id))) (table-ref continuation-table continuation-id))))))
(release-lock continuation-table-lock)
result)))))
(lambda (path-string surflet-path s-req) (lambda (path-string surflet-path s-req)
(receive (session-id continuation-id) (receive (session-id continuation-id)
@ -208,10 +206,11 @@
(let ((continuations-table (session-continuation-table session)) (let ((continuations-table (session-continuation-table session))
(continuation-table-lock (session-continuation-table-lock session)) (continuation-table-lock (session-continuation-table-lock session))
(continuation-counter (session-next-continuation-counter session))) (continuation-counter (session-next-continuation-counter session)))
(obtain-lock continuation-table-lock) (let ((continuation-id
(let ((continuation-id (generate-new-table-id continuations-table))) (with-lock continuation-table-lock
(table-set! continuations-table continuation-id return) (let ((c-id (generate-new-table-id continuations-table)))
(release-lock continuation-table-lock) (table-set! continuations-table c-id return)
c-id))))
(let ((new-url (make-resume-url (session-surflet-name session) (let ((new-url (make-resume-url (session-surflet-name session)
session-id session-id
continuation-counter continuation-counter
@ -284,10 +283,8 @@
;; Looks up SESSION-ID in the *SESSION-TABLE* (locking) and returns ;; Looks up SESSION-ID in the *SESSION-TABLE* (locking) and returns
;; the SESSION record, if anby (#f otherwise). ;; the SESSION record, if anby (#f otherwise).
(define (session-lookup session-id) (define (session-lookup session-id)
(obtain-lock *session-table-lock*) (with-lock *session-table-lock*
(let ((result (table-ref *session-table* session-id))) (table-ref *session-table* session-id)))
(release-lock *session-table-lock*)
result))
;;; SESSION-NEXT-CONTINUATION-COUNTER ;;; SESSION-NEXT-CONTINUATION-COUNTER
;; Increases the SESSION-CONTINUATION-COUNTER in the SESSION record by ;; Increases the SESSION-CONTINUATION-COUNTER in the SESSION record by
@ -300,17 +297,19 @@
;; Deletes the session indicated by its number SESSION-ID from the ;; Deletes the session indicated by its number SESSION-ID from the
;; *SESSION-TABLE* (locking). ;; *SESSION-TABLE* (locking).
(define (delete-session! session-id) (define (delete-session! session-id)
(obtain-lock *session-table-lock*) (with-lock *session-table-lock*
;; notify surveillance of session being alread killed (prevents ;; notify surveillance of session being alread killed (prevents
;; surveillance of killing new session that has the same number by ;; surveillance of killing new session that has the same number by
;; accident) ;; accident)
(let ((session (table-ref *session-table* session-id))) (let ((session (table-ref *session-table* session-id)))
(if session (if session
(begin (begin
(timeout-queue-remove-session! session-id) (timeout-queue-remove-session! session-id)
(table-set! *session-table* session-id #f)))) (table-set! *session-table* session-id #f))
;; else: somebody was faster than we ;; else: somebody was faster than we
(release-lock *session-table-lock*)) ))))
;;; SESSION-ADJUST-TIMEOUT! ;;; SESSION-ADJUST-TIMEOUT!
;; Resets time-to-die of session indicated by its SESSION-ID number. ;; Resets time-to-die of session indicated by its SESSION-ID number.
@ -358,28 +357,26 @@
(lambda (condtion decline) (lambda (condtion decline)
(release-lock *session-table-lock*) (release-lock *session-table-lock*)
(decline)) (decline))
(obtain-lock *session-table-lock*) (with-lock *session-table-lock*
;; notify session killing ;; notify session killing
(table-walk (table-walk
(lambda (session-id session) (lambda (session-id session)
(timeout-queue-remove-session! session-id)) (timeout-queue-remove-session! session-id))
*session-table*) *session-table*)
(set! *session-table* (make-integer-table)) (set! *session-table* (make-integer-table)))))
(release-lock *session-table*)))
;;; GET-SESSIONS ;;; GET-SESSIONS
;; Returns a list of all active sessions in *SESSION-TABLE* ;; Returns a list of all active sessions in *SESSION-TABLE*
;; (locking). The list elements are pairs of session-id and session ;; (locking). The list elements are pairs of session-id and session
;; record. ;; record.
(define (get-sessions) (define (get-sessions)
(obtain-lock *session-table-lock*) (with-lock *session-table-lock*
(let ((sessions '())) (let ((sessions '()))
(table-walk (table-walk
(lambda (session-id session-entry) (lambda (session-id session-entry)
(set! sessions (cons (cons session-id session-entry) sessions))) (set! sessions (cons (cons session-id session-entry) sessions)))
*session-table*) *session-table*)
(release-lock *session-table-lock*) sessions)))
sessions))
(define get-session session-lookup) (define get-session session-lookup)
@ -398,14 +395,13 @@
(let ((continuation-table-lock (session-continuation-table-lock session)) (let ((continuation-table-lock (session-continuation-table-lock session))
(continuation-table (session-continuation-table session)) (continuation-table (session-continuation-table session))
(continuations '())) (continuations '()))
(obtain-lock continuation-table-lock) (with-lock continuation-table-lock
(table-walk (table-walk
(lambda (continuation-id continuation-entry) (lambda (continuation-id continuation-entry)
(set! continuations (cons (cons continuation-id continuation-entry) (set! continuations (cons (cons continuation-id continuation-entry)
continuations))) continuations)))
continuation-table) continuation-table)
(release-lock continuation-table-lock) continuations))
continuations)
'()))) '())))
;;; DELETE-CONTINUATION ;;; DELETE-CONTINUATION
@ -414,12 +410,11 @@
(let ((session (session-lookup session-id))) (let ((session (session-lookup session-id)))
(if session (if session
(let ((continuation-table-lock (session-continuation-table-lock session))) (let ((continuation-table-lock (session-continuation-table-lock session)))
(obtain-lock continuation-table-lock) (with-lock continuation-table-lock
(let ((continuation-table (session-continuation-table session)) (let ((continuation-table (session-continuation-table session))
(continuations '())) (continuations '()))
(if (table-ref continuation-table continuation-id) (if (table-ref continuation-table continuation-id)
(table-set! continuation-table continuation-id #f))) (table-set! continuation-table continuation-id #f))))))))
(release-lock continuation-table-lock)))))
;;; SET-SESSION-DATA!, GET-SESSION-DATA ;;; SET-SESSION-DATA!, GET-SESSION-DATA
;; Access to arbitrary data stored along with current session (no ;; Access to arbitrary data stored along with current session (no
@ -462,46 +457,29 @@
(define get-surflet-rt-structure (define get-surflet-rt-structure
(let ((load-surflet (let ((load-surflet
(lambda (full-surflet-name cached?) (lambda (full-surflet-name cached?)
;; Want to get warnings also. ;; load-config-file does not care about cwd(?)
(with-fatal-handler* ;; --> absolute file name needed
(lambda (condition decline) (load-config-file full-surflet-name)
(if cached? (release-lock *surflet-table-lock*)) ;; surflet-structure to load must be named "surflet"
;; Let the others do the job. (let ((surflet-structure (reify-structure 'surflet)))
(error condition)) (load-structure surflet-structure)
(lambda () (if cached?
;; load-config-file does not care about cwd(?) (table-set! *surflet-table* full-surflet-name
;; --> absolute file name needed (cons surflet-structure
(load-config-file full-surflet-name) (file-last-mod full-surflet-name))))
;; surflet-structure to load must be named "surflet" surflet-structure))))
(let ((surflet-structure (reify-structure 'surflet)))
(load-structure surflet-structure)
(if cached?
(begin
(table-set! *surflet-table* full-surflet-name
(cons surflet-structure
(file-last-mod full-surflet-name)))
;; only now the lock may be released
(release-lock *surflet-table-lock*)))
surflet-structure))))))
(lambda (surflet-name directory) (lambda (surflet-name directory)
(let ((full-surflet-name (absolute-file-name surflet-name directory))) (let ((full-surflet-name (absolute-file-name surflet-name directory)))
(if (options-cache-surflets?) (if (options-cache-surflets?)
(begin (with-lock *surflet-table-lock*
;; The lock is only obtained and released, if surflets
;; are cached. LOAD-SURFLET gets the CACHED? parameter,
;; so nothing will happen, if in the meanwhile caching
;; is turned off.
(obtain-lock *surflet-table-lock*)
(cond (cond
((table-ref *surflet-table* full-surflet-name) => ((table-ref *surflet-table* full-surflet-name) =>
(lambda (surflet) (lambda (surflet)
(if (equal? (file-last-mod full-surflet-name) (if (equal? (file-last-mod full-surflet-name)
(cdr surflet)) (cdr surflet))
(begin (car surflet)
(release-lock *surflet-table-lock*) (load-surflet full-surflet-name #t))))
(car surflet))
(load-surflet full-surflet-name #t))))
(else (else
(load-surflet full-surflet-name #t)))) (load-surflet full-surflet-name #t))))
(load-surflet full-surflet-name #f)))))) (load-surflet full-surflet-name #f))))))
@ -509,33 +487,26 @@
;;; GET-LOADED-SURFLETS ;;; GET-LOADED-SURFLETS
;; Returns list of all loaded surflets (real path strings). ;; Returns list of all loaded surflets (real path strings).
(define (get-loaded-surflets) (define (get-loaded-surflets)
(obtain-lock *surflet-table-lock*) (with-lock *surflet-table-lock*
(let ((loaded-surflets '())) (let ((loaded-surflets '()))
(table-walk (table-walk
(lambda (surflet-path rt-structure) (lambda (surflet-path rt-structure)
(set! loaded-surflets (cons surflet-path loaded-surflets))) (set! loaded-surflets (cons surflet-path loaded-surflets)))
*surflet-table*) *surflet-table*)
(release-lock *surflet-table-lock*) loaded-surflets)))
loaded-surflets))
;;; UNLOAD-SURFLET ;;; UNLOAD-SURFLET
;; Removes SURFLET-NAME from the *SURFLET-TABLE* cache (locking). ;; Removes SURFLET-NAME from the *SURFLET-TABLE* cache (locking).
(define (unload-surflet surflet-name) (define (unload-surflet surflet-name)
(obtain-lock *surflet-table-lock*) (with-lock *surflet-table-lock*
(if (table-ref *surflet-table* surflet-name) (if (table-ref *surflet-table* surflet-name)
(table-set! *surflet-table* surflet-name #f)) (table-set! *surflet-table* surflet-name #f))))
(release-lock *surflet-table-lock*))
;;; RESET-SURFLET-CACHE! ;;; RESET-SURFLET-CACHE!
;; Clears *SURFLET-TABLE* (locking). ;; Clears *SURFLET-TABLE* (locking).
(define (reset-surflet-cache!) (define (reset-surflet-cache!)
; (with-fatal-handler (with-lock *surflet-table-lock*
; (lambda (condition decline) (set! *surflet-table* (make-string-table))))
; (release-lock *surflet-table-lock*)
; (decline))
(obtain-lock *surflet-table-lock*)
(set! *surflet-table* (make-string-table))
(release-lock *surflet-table-lock*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; INSTANCE ;;; INSTANCE