sunet/scheme/lib/rate-limit.scm

64 lines
2.3 KiB
Scheme
Raw Normal View History

2002-06-08 11:07:01 -04:00
;;; Rate limiting -*- Scheme -*-
2002-08-27 05:03:22 -04:00
;;; This file is part of the Scheme Untergrund Networking package.
2002-06-08 11:07:01 -04:00
;;; Copyright (c) 2002 by Mike Sperber.
2002-08-27 05:03:22 -04:00
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
2002-06-08 11:07:01 -04:00
(define-record-type rate-limiter :rate-limiter
(really-make-rate-limiter simultaneous-requests
access-lock
block-lock
current-requests)
rate-limiter?
(simultaneous-requests rate-limiter-simultaneous-requests)
(access-lock rate-limiter-access-lock)
(block-lock rate-limiter-block-lock)
(current-requests rate-limiter-current-requests-unsafe
set-rate-limiter-current-requests!))
(define (make-rate-limiter simultaneous-requests)
(really-make-rate-limiter simultaneous-requests
(make-lock)
(make-lock)
0))
(define (rate-limit-block rate-limiter)
(obtain-lock (rate-limiter-block-lock rate-limiter)))
(define (rate-limit-open rate-limiter)
(obtain-lock (rate-limiter-access-lock rate-limiter))
(let ((current-requests
(+ 1 (rate-limiter-current-requests-unsafe rate-limiter))))
(set-rate-limiter-current-requests! rate-limiter
current-requests)
(if (>= current-requests
(rate-limiter-simultaneous-requests rate-limiter))
(maybe-obtain-lock (rate-limiter-block-lock rate-limiter))
(release-lock (rate-limiter-block-lock rate-limiter))))
(release-lock (rate-limiter-access-lock rate-limiter)))
(define (rate-limit-close rate-limiter)
(obtain-lock (rate-limiter-access-lock rate-limiter))
(let ((current-requests
(- (rate-limiter-current-requests-unsafe rate-limiter) 1)))
(if (negative? current-requests)
(error "rate-limiter: too many close operations"
rate-limiter))
(set-rate-limiter-current-requests! rate-limiter
current-requests)
(if (= current-requests
(- (rate-limiter-simultaneous-requests rate-limiter)
1))
;; we just came back into range
(release-lock (rate-limiter-block-lock rate-limiter))))
(release-lock (rate-limiter-access-lock rate-limiter)))
(define (rate-limiter-current-requests rate-limiter)
(obtain-lock (rate-limiter-access-lock rate-limiter))
(let ((current-requests
(rate-limiter-current-requests-unsafe rate-limiter)))
(release-lock (rate-limiter-access-lock rate-limiter))
current-requests))