;; disfluid, implementation of the Solid specification ;; Copyright (C) 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 access-token) #:use-module (webid-oidc jws) #:use-module (webid-oidc errors) #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-configuration) #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (web client) #:use-module (ice-9 optargs) #:use-module (ice-9 match) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 exceptions) #:declarative? #t #:export ( &invalid-access-token make-invalid-access-token invalid-access-token? the-access-token access-token? access-token-alg access-token-webid access-token-iss access-token-aud access-token-iat access-token-exp access-token-client-id access-token-cnf/jkt access-token-decode issue-access-token )) (define-exception-type &invalid-access-token &external-error make-invalid-access-token invalid-access-token?) ;; The order is meaningful in this module, the-access-token reorders ;; them. (define (the-access-token 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 access token, because it is not even a JWS: ~a") (exception-message error)) (format #f (G_ "this is not an access token, because it is not even a JWS")))) (else (if (exception-with-message? error) (format #f (G_ "this is not an access token: ~a") (exception-message error)) (format #f (G_ "this is not an access token"))))))) (raise-exception (make-exception (make-invalid-access-token) (make-exception-with-message final-message) error)))) (lambda () (match (the-jws x) ((header . payload) (let examine-payload ((payload payload) (webid #f) (iss #f) (aud #f) (iat #f) (exp #f) (cnf #f) (client-id #f) (other-fields '())) (match payload (() (unless (and webid iss aud iat exp cnf client-id) ;; Missing some things (fail (format #f (G_ "the payload is missing ~s") `(,@(if webid '() '("webid")) ,@(if iss '() '("iss")) ,@(if aud '() '("aud")) ,@(if iat '() '("iat")) ,@(if exp '() '("exp")) ,@(if cnf '() '("cnf")) ,@(if client-id '() '("client_id")))))) `(,header . ((webid . ,(uri->string webid)) (iss . ,(uri->string iss)) (aud . "solid") (iat . ,(time-second (date->time-utc iat))) (exp . ,(time-second (date->time-utc exp))) (client_id . ,(uri->string client-id)) (cnf . ,cnf) ,@(reverse other-fields)))) ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...) (examine-payload payload (or webid webid-given) iss aud iat exp cnf client-id other-fields)) ((('webid . infringing) payload ...) (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given") infringing))) ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...) (examine-payload payload webid (or iss iss-given) aud iat exp cnf client-id other-fields)) ((('iss . infringing) payload ...) (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given") infringing))) ((('aud . "solid") payload ...) (examine-payload payload webid iss #t iat exp cnf client-id other-fields)) ((('aud . infringing) payload ...) (fail (format #f (G_ "the \"aud\" field should be set to \"solid\", ~s is given") infringing))) ((('iat . (? (cute >= <> 0) (? integer? iat-given))) payload ...) (examine-payload payload webid iss aud (or iat (time-utc->date (make-time time-utc 0 iat-given))) exp cnf client-id other-fields)) ((('iat . infringing) payload ...) (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given") infringing))) ((('exp . (? (cute >= <> 0) (? integer? exp-given))) payload ...) (examine-payload payload webid iss aud iat (or exp (time-utc->date (make-time time-utc 0 exp-given))) cnf client-id other-fields)) ((('exp . infringing) payload ...) (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given") infringing))) ((('cnf . cnf) payload ...) (let examine-cnf ((data cnf) (jkt #f) (other-cnf-fields '())) (match data (() (unless jkt (fail (format #f (G_ "the \"cnf\" / \"jkt\" field is missing")))) (examine-payload payload webid iss aud iat exp `((jkt . ,jkt) ,@(reverse other-cnf-fields)) client-id other-fields)) ((('jkt . (? string? jkt-given)) data ...) (examine-cnf data (or jkt jkt-given other-cnf-fields) other-cnf-fields)) ((('jkt . infringing) _ ...) (fail (format #f (G_ "the \"cnf\" / \"jkt\" field should be a string, ~s is given") infringing))) ((field data ...) (examine-cnf data jkt `(,field ,@other-cnf-fields))) (data (fail (format #f (G_ "the \"cnf\" field should be an object, ~s is given") data)))))) ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...) (examine-payload payload webid iss aud iat exp cnf (or client-id client-id-given) other-fields)) ((('client_id . infringing) payload ...) (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given") infringing))) ((field payload ...) (examine-payload payload webid iss aud iat exp cnf client-id `(,field ,@other-fields)))))) (else (scm-error 'wrong-type-arg "the-access-token" "expected a pair of lists" '() (list x))))))) (define (access-token? x) (false-if-exception (the-access-token x))) (define (access-token-alg code) (match (the-access-token code) ((header . _) (string->symbol (assq-ref header 'alg))))) (define (access-token-webid code) (match (the-access-token code) ((_ . payload) (string->uri (assq-ref payload 'webid))))) (define (access-token-iss code) (match (the-access-token code) ((_ . payload) (string->uri (assq-ref payload 'iss))))) (define (access-token-aud code) (match (the-access-token code) ((_ . payload) (assq-ref payload 'aud)))) (define (access-token-iat code) (match (the-access-token code) ((_ . payload) (time-utc->date (make-time time-utc 0 (assq-ref payload 'iat)))))) (define (access-token-exp code) (match (the-access-token code) ((_ . payload) (time-utc->date (make-time time-utc 0 (assq-ref payload 'exp)))))) (define (access-token-client-id code) (match (the-access-token code) ((_ . payload) (string->uri (assq-ref payload 'client-id))))) (define (access-token-cnf/jkt code) (match (the-access-token code) ((_ . payload) (assq-ref (assq-ref payload 'cnf) 'jkt)))) (define* (access-token-decode str #:key (http-get http-get)) (with-exception-handler (lambda (error) (let ((final-message (if (exception-with-message? error) (format #f (G_ "the access token is invalid: ~a") (exception-message error)) (format #f (G_ "the access token is invalid"))))) (raise-exception (make-exception (make-invalid-access-token) (make-exception-with-message final-message) error)))) (lambda () (jws-decode str (lambda (token) (let* ((iss (access-token-iss token)) (cfg (with-exception-handler (lambda (error) (let ((final-message (if (exception-with-message? error) (format #f (G_ "I cannot query the identity provider configuration: ~a") (exception-message error)) (format #f (G_ "I cannot query the identity provider configuratioon"))))) (raise-exception (make-exception (make-cannot-query-identity-provider iss) (make-exception-with-message final-message) error)))) (lambda () (get-oidc-configuration (uri-host iss) #:userinfo (uri-userinfo iss) #:port (uri-port iss) #:http-get http-get)))) (jwks (with-exception-handler (lambda (error) (let ((final-message (if (exception-with-message? error) (format #f (G_ "I cannot query the identity provider public keys: ~a") (exception-message error)) (format #f (G_ "I cannot query the identity provider public keys"))))) (raise-exception (make-exception (make-cannot-query-identity-provider iss) (make-exception-with-message final-message) error)))) (lambda () (oidc-configuration-jwks cfg #:http-get http-get))))) (let ((iat (access-token-iat token)) (exp (access-token-exp token)) (current-date ((p:current-date)))) (let ((iat-s (time-second (date->time-utc iat))) (exp-s (time-second (date->time-utc exp))) (current-s (time-second (date->time-utc current-date)))) (when (>= iat-s (+ current-s 5)) (let ((final-message (format #f (G_ "the access token is signed in the future, ~a, relative to current ~a") (date->string iat) (date->string current-date)))) (raise-exception (make-exception (make-signed-in-future iat current-date) (make-exception-with-message final-message))))) (when (>= current-s exp-s) (let ((final-message (format #f (G_ "the access token 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))))))) jwks)))))) (define (access-token-encode access-token key) (with-exception-handler (lambda (error) (let ((final-message (if (exception-with-message? error) (format #f (G_ "cannot encode the access token: ~a") (exception-message error)) (format #f (G_ "cannot encode the access token"))))) (raise-exception (make-exception-with-message final-message)))) (lambda () (jws-encode access-token key)))) (define* (issue-access-token issuer-key #:key (alg #f) (webid #f) (iss #f) (validity 3600) (client-key #f) (cnf/jkt #f) (client-id #f)) (when client-key (set! cnf/jkt (jkt client-key))) (let* ((iat (time-second (date->time-utc ((p:current-date))))) (exp (+ iat validity))) (jws-encode (the-access-token `(((alg . ,(symbol->string alg))) . ((webid . ,(uri->string webid)) (iss . ,(uri->string iss)) (aud . "solid") (iat . ,iat) (exp . ,exp) (cnf . ((jkt . ,cnf/jkt))) (client_id . ,(uri->string client-id))))) issuer-key)))