;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see .
(define-module (webid-oidc refresh-token)
#:use-module (webid-oidc errors)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (webid-oidc jwk)
#:use-module (webid-oidc web-i18n)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module (web uri)
#:use-module (ice-9 optargs)
#:use-module (ice-9 threads)
#:use-module (ice-9 match)
#:use-module (ice-9 exceptions)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (sxml simple)
#:use-module (sxml match)
#:declarative? #t
#:export
(
make-refresh-token
refresh-token?
refresh-token-sub
refresh-token-aud
refresh-token-jkt
refresh-token-refresh-token
&invalid-refresh-token
make-invalid-refresh-token
invalid-refresh-token?
list-refresh-tokens
update-refresh-token-list
issue-refresh-token
with-refresh-token
remove-refresh-token
))
(define-exception-type
&invalid-refresh-token
&external-error
make-invalid-refresh-token
invalid-refresh-token?)
(define-record-type
(make-refresh-token sub aud jkt refresh-token)
refresh-token?
(sub refresh-token-sub)
(aud refresh-token-aud)
(jkt refresh-token-jkt)
(refresh-token refresh-token-refresh-token))
(define (list-refresh-tokens)
(let generate-list
((content
(catch #t
(lambda ()
(call-with-input-file (format #f "~a/refresh-tokens.xml" (p:data-home))
(cute xml->sxml <>
#:namespaces '((disfluid
. "https://disfluid.planete-kraus.eu/refresh-token/v1")))))
(lambda error
'(*TOP* (disfluid:refresh-tokens)))))
(parsed-refresh-tokens '()))
(sxml-match
content
((*TOP* (disfluid:refresh-tokens))
(reverse parsed-refresh-tokens))
((*TOP* (disfluid:refresh-tokens
(disfluid:refresh-token
(@ (sub ,subject)
(aud ,audience)
(jkt ,jkt)
(refresh-token ,refresh-token)))
,other-refresh-tokens ...))
(let ((content
`(*TOP*
(disfluid:refresh-tokens
,@other-refresh-tokens)))
(next-refresh-token
(make-refresh-token (string->uri subject)
(string->uri audience)
jkt
refresh-token)))
(generate-list content
`(,next-refresh-token
,@parsed-refresh-tokens)))))))
(define (update-refresh-token-list transformer)
(stubs:atomically-update-file
(format #f "~a/refresh-tokens.xml" (p:data-home))
(format #f "~a/refresh-tokens.xml.lock" (p:data-home))
(lambda (port)
(let* ((old-refresh-tokens (list-refresh-tokens))
(new-refresh-tokens (transformer old-refresh-tokens)))
(chmod port #o600)
(sxml->xml
`(*TOP*
(refresh-tokens
(@ (xmlns "https://disfluid.planete-kraus.eu/refresh-token/v1"))
,@(map
(match-lambda
(($
(= uri->string subject)
(= uri->string audience)
jkt
refresh-token)
`(refresh-token
(@ (sub ,subject)
(aud ,audience)
(jkt ,jkt)
(refresh-token ,refresh-token)))))
new-refresh-tokens)))
port)))))
(define (remove sub aud)
(cute filter
(match-lambda
(($
(? (cute equal? <> sub) _)
(? (cute equal? <> aud) _)
_ _)
#f)
(else #t))
<>))
(define (keep-n n)
(lambda (old)
(let start-at ((i 0) (data old) (kept '()))
(match data
(() (reverse kept))
((saved data ...)
(if (>= i n)
(reverse kept)
(start-at (1+ i) data `(,saved ,@kept))))))))
(define (insert sub aud jkt jti)
(define remover (remove sub aud))
(define truncator (keep-n 20))
(lambda (old)
(truncator
`(,(make-refresh-token sub aud jkt jti)
,@(remover old)))))
(define (issue-refresh-token sub aud jkt)
(let ((jti (stubs:random 12)))
(update-refresh-token-list (insert sub aud jkt jti))
jti))
(define (with-refresh-token refresh-token key f)
(let search ((tokens (list-refresh-tokens)))
(match tokens
(()
(let ((final-message
(format #f (G_ "the refresh token does not exist"))))
(raise-exception
(make-exception
(make-invalid-refresh-token)
(make-exception-with-message final-message)))))
((($ (? uri? sub) (? uri? aud) (? string? the-jkt) (? string? the-rft))
tokens ...)
(if (equal? refresh-token the-rft)
(begin
(unless (equal? (jkt key) the-jkt)
(let ((final-message
(format #f (G_ "the refresh token is bound to key ~s, which is not that one")
the-jkt)))
(raise-exception
(make-exception
(make-invalid-refresh-token)
(make-exception-with-message final-message)))))
(f sub aud))
(search tokens))))))
(define (remove-refresh-token sub aud)
(update-refresh-token-list (remove sub aud)))