;; 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 jwk)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc web-i18n)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 hash-table)
#:use-module (ice-9 match)
#:use-module (srfi srfi-19)
#:use-module (web response)
#:use-module (web client)
#:use-module (rnrs bytevectors)
#:use-module (oop goops)
#:declarative? #t
#:export
(
alg
public-key private-key
rsa-d rsa-p rsa-q rsa-dp rsa-dq rsa-qi
rsa-n rsa-e
ec-crv ec-x ec-y
ec-z
keys
check-key
key->jwk
jwk->key
kty
jkt
generate-key
serve
get-jwks
¬-a-jwk
make-not-a-jwk
not-a-jwk?
¬-a-jwks
make-not-a-jwks
not-a-jwks?
))
(define-exception-type
¬-a-jwk
&external-error
make-not-a-jwk
not-a-jwk?)
(define-exception-type
¬-a-jwks
&external-error
make-not-a-jwks
not-a-jwks?)
(define-class ()
(alg #:init-keyword #:alg #:accessor alg))
(define-class ())
(define-class ()
(public-key #:init-keyword #:public-key #:accessor public-key)
(private-key #:init-keyword #:private-key #:accessor private-key))
(define-class ())
(define-class ()
(crv #:init-keyword #:crv #:accessor ec-crv))
(define-class ()
(d #:init-keyword #:d #:accessor rsa-d)
(p #:init-keyword #:p #:accessor rsa-p)
(q #:init-keyword #:q #:accessor rsa-q)
(dp #:init-keyword #:dp #:accessor rsa-dp)
(dq #:init-keyword #:dq #:accessor rsa-dq)
(qi #:init-keyword #:qi #:accessor rsa-qi))
(define-class ()
(n #:init-keyword #:n #:accessor rsa-n)
(e #:init-keyword #:e #:accessor rsa-e))
(define-class ()
(crv #:init-keyword #:crv #:accessor ec-crv)
(z #:init-keyword #:z #:accessor ec-z))
(define-class ()
(crv #:init-keyword #:crv #:accessor ec-crv)
(x #:init-keyword #:x #:accessor ec-x)
(y #:init-keyword #:y #:accessor ec-y))
(define-method (initialize-key-pair (key ) (public ) (private ))
(set! (public-key key) public)
(set! (private-key key) private))
(define-method (initialize-key-pair (key ) (public ) (private ))
(set! (public-key key) public)
(set! (private-key key) private))
(define-method (initialize (key ) initargs)
(next-method)
(let-keywords
initargs #t
((public-key #f)
(private-key #f))
(initialize-key-pair key public-key private-key))
(check-key key))
(define-method (initialize-rsa-key-pair (key ) (public ) (private ))
#t)
(define-method (initialize (key ) initargs)
(next-method)
(let-keywords
initargs #t
((public-key #f)
(private-key #f))
(initialize-rsa-key-pair key public-key private-key))
(check-key key))
(define-method (initialize-ec-key-pair (key ) (public ) (private ))
(unless (eq? (ec-crv public) (ec-crv private))
(raise-exception
(make-exception
(make-not-a-jwk)
(make-exception-with-message (G_ "the point and scalar are not on the same curve")))))
(set! (ec-crv key) (ec-crv public)))
(define-method (initialize (key ) initargs)
(next-method)
(let-keywords
initargs #t
((public-key #f)
(private-key #f))
(initialize-ec-key-pair key public-key private-key)
(check-key key)))
(define-method (initialize (key ) initargs)
(next-method)
(let-keywords
initargs #t
((alg #f))
(when (string? alg)
(set! alg (string->symbol alg)))
(slot-set! key 'alg (or alg 'RS256)))
(check-key key))
(define-method (initialize (key ) initargs)
(next-method)
(check-key key))
(define-method (initialize (key ) initargs)
(next-method)
(check-key key))
(define-method (initialize (key ) initargs)
(next-method)
(let-keywords
initargs #t
((alg #f))
(when (string? alg)
(set! alg (string->symbol alg)))
(slot-set! key 'alg (or alg 'ES256)))
(check-key key))
(define-method (alg (key ))
(alg (private-key key)))
(define-method (rsa-d (key ))
(rsa-d (private-key key)))
(define-method (rsa-p (key ))
(rsa-p (private-key key)))
(define-method (rsa-q (key ))
(rsa-q (private-key key)))
(define-method (rsa-dp (key ))
(rsa-dp (private-key key)))
(define-method (rsa-dq (key ))
(rsa-dq (private-key key)))
(define-method (rsa-qi (key ))
(rsa-qi (private-key key)))
(define-method (rsa-n (key ))
(rsa-n (public-key key)))
(define-method (rsa-e (key ))
(rsa-e (public-key key)))
(define-method (ec-x (key ))
(ec-x (public-key key)))
(define-method (ec-y (key ))
(ec-y (public-key key)))
(define-method (ec-z (key ))
(ec-z (private-key key)))
(define-method (equal? (x ) (y ))
(and (equal? (public-key x) (public-key y))
(equal? (private-key x) (private-key y))))
(define-method (equal? (x ) (y ))
#f)
(define-method (equal? (x ) (y ))
#f)
(define-method (equal? (x ) (y ))
(and (equal? (rsa-n x) (rsa-n y))
(equal? (rsa-e x) (rsa-e y))))
(define-method (equal? (x ) (y ))
(and (equal? (alg x) (alg y))
(equal? (rsa-d x) (rsa-d y))
(equal? (rsa-p x) (rsa-p y))
(equal? (rsa-q x) (rsa-q y))
(equal? (rsa-dp x) (rsa-dp y))
(equal? (rsa-dq x) (rsa-dq y))
(equal? (rsa-qi x) (rsa-qi y))))
(define-method (equal? (x ) (y ))
(and (equal? (ec-x x) (ec-x y))
(equal? (ec-y x) (ec-y y))))
(define-method (equal? (x ) (y ))
(and (equal? (alg x) (alg y))
(equal? (ec-z x) (ec-z y))))
(define (check-and-kty key)
(with-exception-handler
(lambda (error)
(let ((final-message
(if (exception-with-message? error)
(format #f (G_ "the JWK is invalid: ~a")
(exception-message error))
(format #f (G_ "the JWK is invalid")))))
(raise-exception
(make-exception
(make-not-a-jwk)
(make-exception-with-message final-message)
error))))
(lambda ()
(let ((kty (stubs:kty (key->jwk key))))
(unless kty
(fail (G_ "cannot compute the key type")))
kty))))
(define-method (key->jwk (key ))
;; kty and crv fields are present in both the public and private
;; key, but they must not be duplicated, and we want to keep all
;; fields in order.
(let ((with-duplicates
(append (key->jwk (public-key key))
(key->jwk (private-key key)))))
(let ((lookup
(alist->hash-table with-duplicates)))
(let keep-unique-in-order ((order (map car with-duplicates))
(constructed '()))
(match order
(()
(reverse constructed))
((hd tl ...)
(let ((found (hash-ref lookup hd)))
(when found
(hash-remove! lookup hd))
(if found
(keep-unique-in-order tl `((,hd . ,found) ,@constructed))
(keep-unique-in-order tl constructed)))))))))
(define-method (key->jwk (key ))
`((kty . ,(symbol->string (kty key)))
(alg . ,(symbol->string (alg key)))
(d . ,(rsa-d key))
(p . ,(rsa-p key))
(q . ,(rsa-q key))
(dp . ,(rsa-dp key))
(dq . ,(rsa-dq key))
(qi . ,(rsa-qi key))))
(define-method (key->jwk (key ))
`((kty . ,(symbol->string (kty key)))
(n . ,(rsa-n key))
(e . ,(rsa-e key))))
(define-method (key->jwk (key ))
`((crv . ,(symbol->string (ec-crv key)))
(kty . ,(symbol->string (kty key)))
(x . ,(ec-x key))
(y . ,(ec-y key))))
(define-method (key->jwk (key ))
`((crv . ,(symbol->string (ec-crv key)))
(kty . ,(symbol->string (kty key)))
(alg . ,(symbol->string (alg key)))
(z . ,(ec-z key))))
(define-method (check-key key)
(check-and-kty (key->jwk key)))
(define (check-rsa-key key)
(unless (eq? (check-and-kty key) 'RSA)
(raise-exception
(make-exception
(make-not-a-jwk)
(make-exception-with-message
(format #f (G_ "it is built as an RSA key or key pair, but it is not")))))))
(define (check-ec-key key)
(unless (eq? (check-and-kty key) 'EC)
(raise-exception
(make-exception
(make-not-a-jwk)
(make-exception-with-message
(format #f (G_ "it is built as an elliptic curve key or key pair, but it is not")))))))
(define-method (check-key (key ))
(check-rsa-key key))
(define-method (check-key (key ))
(check-rsa-key key))
(define-method (check-key (key ))
(check-rsa-key key))
(define-method (check-key (key ))
(check-ec-key key))
(define-method (check-key (key ))
(check-ec-key key))
(define-method (check-key (key ))
(check-ec-key key))
(define-method (kty (key )) 'RSA)
(define-method (kty (key )) 'RSA)
(define-method (kty (key )) 'RSA)
(define-method (kty (key )) 'EC)
(define-method (kty (key )) 'EC)
(define-method (kty (key )) 'EC)
(define-method (public-key (key ))
key)
(define-method (private-key (key ))
key)
(define (jwk->key fields)
(let ((kty (stubs:kty fields))
(alg (assq-ref fields 'alg)))
(let ((explicit-kty (assq-ref fields 'kty)))
(when (and kty explicit-kty (not (eq? kty (string->symbol explicit-kty))))
(raise-exception
(make-exception
(make-not-a-jwk)
(make-exception-with-message (format #f (G_ "the key advertises a key type of ~s, but actually it is ~s")
explicit-kty kty))))))
(case kty
((RSA)
(let ((d (assq-ref fields 'd))
(p (assq-ref fields 'p))
(q (assq-ref fields 'q))
(dp (assq-ref fields 'dp))
(dq (assq-ref fields 'dq))
(qi (assq-ref fields 'qi))
(n (assq-ref fields 'n))
(e (assq-ref fields 'e)))
(let ((public
(and n e
(make #:n n #:e e)))
(private
(and d p q dp dq qi
(make
#:alg (and alg (string->symbol alg))
#:d d
#:p p
#:q q
#:dp dp
#:dq dq
#:qi qi))))
(if (and public private)
(make #:public-key public #:private-key private)
(or public private)))))
((EC)
(let ((crv (string->symbol (assq-ref fields 'crv)))
(x (assq-ref fields 'x))
(y (assq-ref fields 'y))
(z (assq-ref fields 'z)))
(let ((public
(and x y
(make #:crv crv #:x x #:y y)))
(private
(and z
(make
#:alg (and alg (string->symbol alg))
#:crv crv
#:z z))))
(if (and public private)
(make #:public-key public #:private-key private)
(or public private)))))
(else
(raise-exception
(make-exception
(make-not-a-jwk)
(make-exception-with-message (G_ "this is neither a RSA key nor an elliptic curve key"))))))))
(define (jkt x)
(stubs:jkt (key->jwk x)))
(define (generate-key . args)
(jwk->key (apply stubs:generate-key args)))
(define-class ()
(keys #:init-keyword #:keys #:accessor keys))
(define-method (initialize (jwks ) initargs)
(next-method)
(let-keywords
initargs #t
((keys '()))
(slot-set! jwks 'keys (map public-key keys))))
(define-method (serve (jwks ) expiration-date)
(values
(build-response
#:headers `((content-type . (application/json))
(expires . ,expiration-date)))
(stubs:scm->json-string
`((keys
. ,(list->vector
(map key->jwk (keys jwks))))))))
(define* (get-jwks uri #:key (http-request http-request))
(receive (response response-body) (http-request uri)
(with-exception-handler
(lambda (error)
(raise-exception
(make-exception
(make-not-a-jwks)
(make-exception-with-message
(if (exception-with-message? error)
(format #f (G_ "cannot fetch a JWKS: ~a")
(exception-message error))
(format #f (G_ "cannot fetch a JWKS"))))
error)))
(lambda ()
(unless (eqv? (response-code response) 200)
(fail (format #f (G_ "the request failed with ~s ~s")
(response-code response)
(response-reason-phrase response))))
(let ((content-type (response-content-type response)))
(unless content-type
(fail (format #f (G_ "missing content-type"))))
(unless (and (eq? (car content-type) 'application/json)
(or (equal? (assoc-ref (cdr content-type) 'charset)
"utf-8")
(not (assoc-ref (cdr content-type) 'charset))))
(fail (format #f (G_ "invalid content-type: ~s") content-type)))
(unless (string? response-body)
(set! response-body (utf8->string response-body)))
(let ((data (stubs:json-string->scm response-body)))
(let ((keys (vector->list (assq-ref data 'keys))))
(make #:keys (map jwk->key keys)))))))))