;; 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 authorization-code) #:use-module (webid-oidc errors) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc jws) #:use-module (webid-oidc jti) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (srfi srfi-19) #:use-module (webid-oidc web-i18n) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) #:declarative? #t #:export ( &invalid-authorization-code make-invalid-authorization-code invalid-authorization-code? the-authorization-code authorization-code? authorization-code-alg authorization-code-webid authorization-code-client-id authorization-code-jti authorization-code-exp authorization-code-decode issue-authorization-code )) (define-exception-type &invalid-authorization-code &external-error make-invalid-authorization-code invalid-authorization-code?) (define (the-authorization-code x) (with-exception-handler (lambda (error) (let ((final-message (cond ((invalid-jws? error) (if (exception-with-message? error) (format #f (G_ "this is not an authorization code, because it is not even a JWS: ~a") (exception-message error)) (format #f (G_ "this is not an authorization code, because it is not even a JWS")))) (else (if (exception-with-message? error) (format #f (G_ "this is not an authorization code: ~a") (exception-message error)) (format #f (G_ "this is not an authorization code"))))))) (raise-exception (make-exception (make-invalid-authorization-code) (make-exception-with-message final-message) error)))) (lambda () (match (the-jws x) ((header . payload) (let examine-payload ((payload payload) (webid #f) (client-id #f) (jti #f) (exp #f) (other-fields '())) (match payload (() (unless (and webid client-id jti exp) (fail (format #f (G_ "the payload is missing ~s") `(,@(if webid '() '("webid")) ,@(if client-id '() '("client_id")) ,@(if jti '() '("jti")) ,@(if exp '() '("exp")))))) `(,header . ((webid . ,(uri->string webid)) (client_id . ,(uri->string client-id)) (jti . ,jti) (exp . ,(time-second (date->time-utc exp))) ,@(reverse other-fields)))) ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...) (examine-payload payload (or webid webid-given) client-id jti exp other-fields)) ((('webid . infringing) payload ...) (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given") infringing))) ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...) (examine-payload payload webid (or client-id client-id-given) jti exp other-fields)) ((('client_id . infringing) payload ...) (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given") infringing))) ((('jti . (? string? jti-given)) payload ...) (examine-payload payload webid client-id (or jti jti-given) exp other-fields)) ((('jti . invalid) payload ...) (fail (format #f (G_ "the \"jti\" field should be a string, ~s is given") invalid))) ((('exp . (? (lambda (x) (and (integer? x) (>= x 0))) exp-given)) payload ...) (examine-payload payload webid client-id jti (or exp (time-utc->date (make-time time-utc 0 exp-given))) other-fields)) ((('exp . infringing) payload ...) (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given") infringing))) ((field payload ...) (examine-payload payload webid client-id jti exp `(,field ,@other-fields)))))) (else (scm-error 'wrong-type-arg "the-authorization-code" "expected a pair of lists" (list x))))))) (define (authorization-code? x) (false-if-exception (the-authorization-code x))) (define (authorization-code-alg x) (match (the-authorization-code x) ((header . _) (string->symbol (assq-ref header 'alg))))) (define (authorization-code-webid x) (match (the-authorization-code x) ((_ . payload) (string->uri (assq-ref payload 'webid))))) (define (authorization-code-client-id x) (match (the-authorization-code x) ((_ . payload) (string->uri (assq-ref payload 'client_id))))) (define (authorization-code-jti x) (match (the-authorization-code x) ((_ . payload) (assq-ref payload 'jti)))) (define (authorization-code-exp x) (match (the-authorization-code x) ((_ . payload) (time-utc->date (make-time time-utc 0 (assq-ref payload 'exp)))))) (define (authorization-code-decode str jwk) (parameterize ((p:current-date (time-second (date->time-utc ((p:current-date)))))) (with-exception-handler (lambda (error) (let ((final-message (if (exception-with-message? error) (format #f (G_ "the authorization code is invalid: ~a") (exception-message error)) (format #f (G_ "the authorization code is invalid"))))) (raise-exception (make-exception (make-invalid-authorization-code) (make-exception-with-message final-message) error)))) (lambda () (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk))))) (let ((exp (authorization-code-exp code)) (current-date ((p:current-date)))) (let ((exp-s (time-second (date->time-utc exp))) (current-s (time-second (date->time-utc current-date)))) (when (>= current-s exp-s) (let ((final-message (format #f (G_ "the authorization expired ~a, which is in the past (from ~a)") (date->string exp) (date->string current-date)))) (raise-exception (make-exception (make-expired exp current-date) (make-exception-with-message final-message))))) (jti-check (authorization-code-jti code) (- exp-s current-s)) code))))))) (define (authorization-code-encode authorization-code key) (with-exception-handler (lambda (error) (let ((final-message (if (exception-with-message? error) (format #f (G_ "cannot encode the authorization code: ~a") (exception-message error)) (format #f (G_ "cannot encode the authorization code"))))) (raise-exception (make-exception-with-message final-message)))) (lambda () (jws-encode authorization-code key)))) (define* (issue-authorization-code issuer-key #:key alg (validity 120) webid client-id) (let* ((iat (time-second (date->time-utc ((p:current-date))))) (exp (+ iat validity))) (authorization-code-encode `(((alg . ,(symbol->string alg))) . ((webid . ,(uri->string webid)) (client_id . ,(uri->string client-id)) (exp . ,exp) (jti . ,(stubs:random 12)))) issuer-key)))