diff options
Diffstat (limited to 'src/scm/webid-oidc/jti.scm')
-rw-r--r-- | src/scm/webid-oidc/jti.scm | 58 |
1 files changed, 32 insertions, 26 deletions
diff --git a/src/scm/webid-oidc/jti.scm b/src/scm/webid-oidc/jti.scm index 4713d7d..cf05bbb 100644 --- a/src/scm/webid-oidc/jti.scm +++ b/src/scm/webid-oidc/jti.scm @@ -15,36 +15,42 @@ ;; along with this program. If not, see <https://www.gnu.org/licenses/>. (define-module (webid-oidc jti) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (ice-9 atomic) #:use-module (ice-9 threads) - #:use-module (srfi srfi-19)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:export (jti-check)) -(define-public (make-jti-list) +(define jti-list (make-atomic-box '())) -(define-public (lookup list jti) - (if (null? list) - #f - (or (string=? (assq-ref (car list) 'jti) jti) - (lookup (cdr list) jti)))) - -(define-public (jti-check current-time jti list valid-time) - (when (date? current-time) - (set! current-time (date->time-utc current-time))) - (when (time? current-time) - (set! current-time (time-second current-time))) - (let* ((old (atomic-box-ref list)) - (new-entry `((exp . ,(+ current-time valid-time)) - (jti . ,jti))) +(define-record-type <jti-item> + (make-jti-item exp jti) + jti-item? + (exp jti-item-exp) + (jti jti-item-jti)) + +(define lookup + (match-lambda* + ((() item) #f) + (((($ <jti-item> exp jti) other ...) item) + (or (string=? jti item) + (lookup other item))))) + +(define (jti-check jti valid-time) + (let* ((current-time + (time-second (date->time-utc ((p:current-date))))) + (old (atomic-box-ref jti-list)) + (new-entry (make-jti-item (+ current-time valid-time) jti)) (new (filter - (lambda (entry) - (let ((exp (assq-ref entry 'exp))) - (>= exp current-time))) + (match-lambda + (($ <jti-item> exp other-jti) + (>= exp current-time))) (cons new-entry old)))) - (let ((present? (lookup old jti))) - (if present? - #f - (let ((discarded (atomic-box-compare-and-swap! list old new))) - (if (eq? discarded old) - #t - (jti-check current-time jti list valid-time))))))) + (and (not (lookup old jti)) + (let ((discarded (atomic-box-compare-and-swap! jti-list old new))) + (if (eq? discarded old) + #t + (jti-check jti valid-time)))))) |