diff options
| author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-09 18:46:48 +0200 |
|---|---|---|
| committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-13 01:06:38 +0200 |
| commit | ded10e28782f289ad3db15320bcf619ab4336876 (patch) | |
| tree | 32609fd9f1eb0d2f8a23105e09f193827d16a275 /src/scm | |
| parent | 7b62790238902e10edb83c07286cf0643b097997 (diff) | |
Switch to a more sensible error reporting system
Diffstat (limited to 'src/scm')
45 files changed, 3574 insertions, 3342 deletions
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 57c3930..5ffac04 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -48,7 +48,8 @@ dist_webidoidcmod_DATA += \ %reldir%/offloading.scm \ %reldir%/catalog.scm \ %reldir%/parameters.scm \ - %reldir%/simulation.scm + %reldir%/simulation.scm \ + %reldir%/web-i18n.scm webidoidcgo_DATA += \ %reldir%/errors.go \ @@ -84,7 +85,8 @@ webidoidcgo_DATA += \ %reldir%/offloading.go \ %reldir%/catalog.go \ %reldir%/parameters.go \ - %reldir%/simulation.go + %reldir%/simulation.go \ + %reldir%/web-i18n.go EXTRA_DIST += %reldir%/ChangeLog diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm index acdc56f..6023108 100644 --- a/src/scm/webid-oidc/access-token.scm +++ b/src/scm/webid-oidc/access-token.scm @@ -1,5 +1,5 @@ -;; webid-oidc, implementation of the Solid specification -;; Copyright (C) 2020, 2021 Vivien Kraus +;; 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 @@ -19,204 +19,330 @@ #: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 (srfi srfi-19)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (ice-9 exceptions) + #:declarative? #t + #:export + ( -(define-public (the-access-token-header x) - (with-exception-handler - (lambda (error) - (raise-not-an-access-token-header x error)) - (lambda () - (the-jws-header x)))) + &invalid-access-token + make-invalid-access-token + invalid-access-token? + + the-access-token + access-token? + + access-token-alg -(define-public (access-token-header? x) - (false-if-exception - (and (the-access-token-header x) #t))) + access-token-webid + access-token-iss + access-token-aud + access-token-iat + access-token-exp + access-token-client-id + access-token-cnf/jkt -(define-public (the-access-token-payload x) + 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) - (raise-not-an-access-token-payload x 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 () - (let ((x (the-jws-payload x))) - (let ((webid (assq-ref x 'webid)) - (iss (assq-ref x 'iss)) - (aud (assq-ref x 'aud)) - (iat (assq-ref x 'iat)) - (exp (assq-ref x 'exp)) - (cnf (assq-ref x 'cnf)) - (client-id (assq-ref x 'client_id))) - (unless (and webid (string? webid) (string->uri webid)) - (raise-incorrect-webid-field webid)) - (unless (and iss (string? iss) (string->uri iss)) - (raise-incorrect-iss-field iss)) - (unless (equal? aud "solid") - (raise-incorrect-aud-field aud)) - (unless (integer? iat) - (raise-incorrect-iat-field iat)) - (unless (and (integer? exp) (>= exp iat)) - (raise-incorrect-exp-field exp)) - (unless (and client-id (string? client-id) (string->uri client-id)) - (raise-incorrect-client-id-field client-id)) - (unless (and cnf (assq-ref cnf 'jkt) (string? (assq-ref cnf 'jkt))) - (raise-incorrect-cnf/jkt-field (and cnf (assq-ref cnf 'jkt)))) - x))))) - -(define-public (access-token-payload? x) - (false-if-exception - (and (the-access-token-header x) #t))) - -(define-public (the-access-token x) - (with-exception-handler - (lambda (cause) - (raise-not-an-access-token x cause)) - (lambda () - (cons (the-access-token-header (car x)) - (the-access-token-payload (cdr x)))))) - -(define-public (access-token? x) - (false-if-exception - (and (the-access-token x) #t))) - -(define-public (make-access-token header payload) - (the-access-token - (cons header payload))) - -(define-public (make-access-token-payload webid iss iat exp cnf/jkt client-id) - (when (date? exp) - (set! exp (date->time-utc exp))) - (when (time? exp) - (set! exp (time-second exp))) - (when (date? iat) - (set! iat (date->time-utc iat))) - (when (time? iat) - (set! iat (time-second iat))) - (when (uri? webid) - (set! webid (uri->string webid))) - (when (uri? iss) - (set! iss (uri->string iss))) - (when (uri? client-id) - (set! client-id (uri->string client-id))) - (the-access-token-payload - `((webid . ,webid) - (iss . ,iss) - (aud . "solid") - (iat . ,iat) - (exp . ,exp) - (cnf . ((jkt . ,cnf/jkt))) - (client_id . ,client-id)))) - -(define-public (access-token-header code) - (car (the-access-token code))) - -(define-public (access-token-payload code) - (cdr (the-access-token code))) - -(define-public (access-token-alg code) - (when (access-token? code) - (set! code (access-token-header code))) - (jws-alg (the-access-token-header code))) - -(define-public (access-token-webid code) - (when (access-token? code) - (set! code (access-token-payload code))) - (string->uri - (assq-ref (the-access-token-payload code) 'webid))) - -(define-public (access-token-iss code) - (when (access-token? code) - (set! code (access-token-payload code))) - (string->uri - (assq-ref (the-access-token-payload code) 'iss))) - -(define-public (access-token-aud code) - (when (access-token? code) - (set! code (access-token-payload code))) - (assq-ref (the-access-token-payload code) 'aud)) - -(define-public (access-token-exp code) - (when (access-token? code) - (set! code (access-token-payload code))) - (time-utc->date - (make-time time-utc 0 (assq-ref - (the-access-token-payload code) - 'exp)))) - -(define-public (access-token-iat code) - (when (access-token? code) - (set! code (access-token-payload code))) - (time-utc->date - (make-time time-utc 0 (assq-ref - (the-access-token-payload code) - 'iat)))) - -(define-public (access-token-cnf/jkt code) - (when (access-token? code) - (set! code (access-token-payload code))) - (assq-ref - (assq-ref (the-access-token-payload code) 'cnf) - 'jkt)) - -(define-public (access-token-client-id code) - (when (access-token? code) - (set! code (access-token-payload code))) - (string->uri - (assq-ref (the-access-token-payload code) 'client_id))) - -(define*-public (access-token-decode str #:key (http-get http-get)) + (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) - (raise-cannot-decode-access-token str 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))) - (let ((cfg - (with-exception-handler - (lambda (error) - (raise-cannot-fetch-issuer-configuration iss error)) - (lambda () - (get-oidc-configuration - (uri-host iss) - #:userinfo (uri-userinfo iss) - #:port (uri-port iss) - #:http-get http-get))))) - (with-exception-handler - (lambda (error) - (raise-cannot-fetch-jwks iss - (oidc-configuration-jwks-uri cfg) - error)) - (lambda () - (oidc-configuration-jwks cfg #:http-get http-get)))))))))) - -(define-public (access-token-encode access-token key) + (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) - (raise-cannot-encode-access-token access-token key 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*-public (issue-access-token - issuer-key - #:key - (alg #f) - (webid #f) - (iss #f) - (validity 3600) - (client-key #f) - (cnf/jkt #f) - (client-id #f)) +(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))) - (access-token-encode - (make-access-token - `((alg . ,(if (symbol? alg) (symbol->string alg) alg))) - (let ((iat (time-second (date->time-utc ((p:current-date)))))) - (make-access-token-payload - webid iss iat (+ iat validity) cnf/jkt client-id))) - issuer-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))) diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm index 267d67a..95dcc4a 100644 --- a/src/scm/webid-oidc/authorization-code.scm +++ b/src/scm/webid-oidc/authorization-code.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -21,146 +21,203 @@ #:use-module (webid-oidc jti) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (srfi srfi-19)) - -(define-public (the-authorization-code-header x) - (with-exception-handler - (lambda (error) - (raise-not-an-authorization-code-header x error)) - (lambda () - (the-jws-header x)))) - -(define-public (authorization-code-header? x) - (false-if-exception - (and (the-authorization-code-header x) #t))) - -(define-public (the-authorization-code-payload x) - (with-exception-handler - (lambda (error) - (raise-not-an-authorization-code-payload x error)) - (lambda () - (let ((x (the-jws-payload x))) - (let ((exp (assq-ref x 'exp)) - (jti (assq-ref x 'jti)) - (webid (assq-ref x 'webid)) - (client-id (assq-ref x 'client_id))) - (unless (integer? exp) - (raise-incorrect-exp-field exp)) - (unless (string? jti) - (raise-incorrect-jti-field jti)) - (unless (and (string? webid) (string->uri webid)) - (raise-incorrect-webid-field webid)) - (unless (and (string? client-id) (string->uri client-id)) - (raise-incorrect-client-id-field client-id)) - x))))) - -(define-public (authorization-code-payload? x) - (false-if-exception - (and (the-authorization-code-payload x) #t))) - -(define-public (the-authorization-code x) + #: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) - (raise-not-an-authorization-code x 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 () - (cons (the-authorization-code-header (car x)) - (the-authorization-code-payload (cdr x)))))) - -(define-public (authorization-code? x) - (false-if-exception - (and (the-authorization-code x) #t))) - -(define-public (make-authorization-code header payload) - (the-authorization-code (cons header payload))) - -(define-public (make-authorization-code-header alg) - (when (symbol? alg) - (set! alg (symbol->string alg))) - (the-authorization-code-header - `((alg . ,alg)))) - -(define-public (make-authorization-code-payload exp jti sub aud) - (when (date? exp) - (set! exp (date->time-utc exp))) - (when (time? exp) - (set! exp (time-second exp))) - (when (uri? sub) - (set! sub (uri->string sub))) - (when (uri? aud) - (set! aud (uri->string aud))) - (the-authorization-code-payload - `((exp . ,exp) - (jti . ,jti) - (webid . ,sub) - (client_id . ,aud)))) - -(define-public (authorization-code-header code) - (car (the-authorization-code code))) - -(define-public (authorization-code-payload code) - (cdr (the-authorization-code code))) - -(define-public (authorization-code-alg code) - (when (authorization-code? code) - (set! code (authorization-code-header code))) - (jws-alg (the-authorization-code-header code))) - -(define-public (authorization-code-exp code) - (when (authorization-code? code) - (set! code (authorization-code-payload code))) - (time-utc->date - (make-time time-utc 0 (assq-ref - (the-authorization-code-payload code) - 'exp)))) - -(define-public (authorization-code-jti code) - (when (authorization-code? code) - (set! code (authorization-code-payload code))) - (assq-ref (the-authorization-code-payload code) 'jti)) - -(define-public (authorization-code-webid code) - (when (authorization-code? code) - (set! code (authorization-code-payload code))) - (string->uri - (assq-ref (the-authorization-code-payload code) 'webid))) - -(define-public (authorization-code-client-id code) - (when (authorization-code? code) - (set! code (authorization-code-payload code))) - (string->uri - (assq-ref (the-authorization-code-payload code) 'client_id))) - -(define-public (authorization-code-decode str jwk) + (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) - (raise-cannot-decode-authorization-code str 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 (time-second (date->time-utc (authorization-code-exp code)))) - (current-time (time-second (date->time-utc ((p:current-date)))))) - (unless (<= current-time exp) - (raise-authorization-code-expired exp current-time)) - (unless (jti-check (authorization-code-jti code) - (- exp current-time)) - (with-exception-handler - (lambda (error) - (raise-jti-found (authorization-code-jti code) error)) - (lambda () - (error "the jti-check function returned #f")))) - code)))))) - -(define-public (authorization-code-encode authorization-code key) + (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) - (raise-cannot-encode-authorization-code authorization-code key 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-public (issue-authorization-code alg jwk exp sub aud) - (authorization-code-encode - (make-authorization-code - (make-authorization-code-header alg) - (make-authorization-code-payload exp (stubs:random 12) sub aud)) - jwk)) +(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))) diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm index 4786a7a..86a8a4d 100644 --- a/src/scm/webid-oidc/authorization-endpoint.scm +++ b/src/scm/webid-oidc/authorization-endpoint.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -27,16 +27,25 @@ #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (ice-9 receive) - #:use-module (ice-9 optargs)) + #:use-module (ice-9 optargs) + #:use-module (ice-9 match) + #:declarative? #t + #:export + ( + + make-authorization-endpoint + + )) (define (verify-password encrypted-password password) (let ((c (crypt password encrypted-password))) (string=? c encrypted-password))) -(define*-public (make-authorization-endpoint subject encrypted-password alg jwk validity - #:key - (http-get http-get)) +(define* (make-authorization-endpoint subject encrypted-password alg jwk validity + #:key + (http-get http-get)) (define (parse-arg x decode-plus-to-space?) (map (lambda (x) (uri-decode x @@ -51,35 +60,40 @@ (query-parts (if query (string-split query #\&) '())) - (get-args (map (lambda (x) (parse-arg x #f)) query-parts)) + (get-args (map (cute parse-arg <> #f) query-parts)) (form-args - (if (and - (request-content-type request) - (eq? (car (request-content-type request)) - 'application/x-www-form-urlencoded)) - (let ((parts (string-split request-body #\&))) - (map (lambda (x) (parse-arg x #t)) parts)) - '())) + (match (request-content-type request) + ((application/x-www-form-urlencoded . _) + (map (cute parse-arg <> #t) + (string-split request-body #\&))) + (else '()))) (accept-language (sort (request-accept-language request) (lambda (x y) (>= (car x) (car y))))) - (locale (if (null? accept-language) - "C" - (cdar accept-language)))) - (let ((client-id (assoc-ref get-args "client_id")) - (redirect-uri (assoc-ref get-args "redirect_uri")) - (password (assoc-ref form-args "password")) - (state (assoc-ref get-args "state"))) - (when client-id - (set! client-id - (string->uri (car client-id)))) - (when redirect-uri - (set! redirect-uri - (string->uri (car redirect-uri)))) - (when password - (set! password (car password))) - (when state - (set! state (car state))) + (locale + (match accept-language + (((_ . lng) _ ...) lng) + (else "C")))) + (let ((client-id + (match (assoc-ref get-args "client_id") + (((? string->uri client-id) . _) + (string->uri client-id)) + (else #f))) + (redirect-uri + (match (assoc-ref get-args "redirect_uri") + (((? string->uri redirect-uri) . _) + (string->uri redirect-uri)) + (else #f))) + (password + (match (assoc-ref form-args "password") + ((password . _) + password) + (else #f))) + (state + (match (assoc-ref get-args "state") + ((state . _) + state) + (else #f)))) (cond ((not client-id) (error-no-client-id locale)) @@ -92,30 +106,29 @@ (lambda (error) (error-application locale error)) (lambda () - (let* ((current-time ((p:current-date))) ;; current-date is a thunk parameter - (current-sec - (time-second (date->time-utc current-time))) - (exp-sec (+ current-sec validity)) - (exp (time-utc->date (make-time time-utc 0 exp-sec))) - (code (issue-authorization-code alg jwk exp subject client-id))) - (let ((mf (get-client-manifest client-id - #:http-get http-get))) - (client-manifest-check-redirect-uri mf redirect-uri) - (let ((query - (if state - (format #f "code=~a&state=~a" - (uri-encode code) - (uri-encode state)) - (format #f "code=~a" - (uri-encode code))))) - (let ((uri - (build-uri 'https - #:userinfo (uri-userinfo redirect-uri) - #:host (uri-host redirect-uri) - #:port (uri-port redirect-uri) - #:path (uri-path redirect-uri) - #:query query))) - (redirection locale client-id uri)))))) + (let ((code (issue-authorization-code + jwk + #:alg alg + #:webid subject + #:client-id client-id)) + (mf (get-client-manifest client-id + #:http-get http-get))) + (client-manifest-check-redirect-uri mf redirect-uri) + (let ((query + (if state + (format #f "code=~a&state=~a" + (uri-encode code) + (uri-encode state)) + (format #f "code=~a" + (uri-encode code))))) + (let ((uri + (build-uri 'https + #:userinfo (uri-userinfo redirect-uri) + #:host (uri-host redirect-uri) + #:port (uri-port redirect-uri) + #:path (uri-path redirect-uri) + #:query query))) + (redirection locale client-id uri))))) #:unwind? #t)) (else (authorization-page locale diff --git a/src/scm/webid-oidc/authorization-page-unsafe.scm b/src/scm/webid-oidc/authorization-page-unsafe.scm index 1ab235e..a6f5c3b 100644 --- a/src/scm/webid-oidc/authorization-page-unsafe.scm +++ b/src/scm/webid-oidc/authorization-page-unsafe.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -19,21 +19,28 @@ #:use-module (sxml simple) #:use-module (web uri) #:use-module (web response) - #:use-module (ice-9 i18n) + #:use-module (webid-oidc web-i18n) #:use-module (ice-9 exceptions) - #:use-module (ice-9 string-fun)) - -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) + #:use-module (ice-9 string-fun) + #:use-module (ice-9 match) + #:use-module (sxml simple) + #:use-module (sxml match) + #:declarative? #t + #:export + ( + authorization-page + error-no-client-id + error-no-redirect-uri + error-application + redirection + )) (define (str->sxml str) - (cdadr + (sxml-match (xml->sxml - (string-append "<protect>" str "</protect>")))) + (string-append "<protect>" str "</protect>")) + ((*TOP* (protect ,element ...)) + (list element ...)))) (define (make-page title . body) (with-output-to-string @@ -42,31 +49,30 @@ `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang ,(G_ "xml-lang|en"))) + (xml:lang ,(W_ "xml-lang|en"))) (head (title ,title)) (body ,@body))))))) -(define-public (authorization-page credential-invalid? - client-id post-uri) +(define (authorization-page credential-invalid? + client-id post-uri) (when (uri? client-id) (set! client-id (uri->string client-id))) (when (string? post-uri) (set! post-uri (string->uri post-uri))) (values (build-response #:headers `((content-type application/xhtml+xml))) - (make-page - (G_ "page-title|Authorization") + (W_ "page-title|Authorization") (if (equal? (string->uri client-id) (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient")) - `(h1 ,@(str->sxml (G_ "Authorize this anonymous application?"))) - `(h1 ,@(str->sxml (format #f (G_ "Authorize <a href=~s>~a</a>?") + `(h1 ,@(str->sxml (W_ "Authorize this anonymous application?"))) + `(h1 ,@(str->sxml (format #f (W_ "Authorize <a href=~s>~a</a>?") client-id client-id)))) - `(p ,@(str->sxml (G_ "Do you want to authorize this application to represent you?"))) + `(p ,@(str->sxml (W_ "Do you want to authorize this application to represent you?"))) `(form (@ (action ,(uri->string post-uri)) (method "POST")) (div @@ -76,126 +82,56 @@ '())) ,@(str->sxml (if credential-invalid? - (G_ "Please retry your password:") - (G_ "Please enter your password:")))) + (W_ "Please retry your password:") + (W_ "Please enter your password:")))) (input (@ (type "password") (name "password") (id "password")))) (input (@ (type "submit") - (value ,(G_ "Allow")))))))) + (value ,(W_ "Allow")))))))) (define (bad-request . body) (values (build-response #:code 400 #:reason-phrase "Bad Request" #:headers '((content-type application/xhtml+xml))) - (apply make-page (G_ "Bad request") body))) + (apply make-page (W_ "Bad request") body))) -(define-public (error-no-client-id) +(define (error-no-client-id) (bad-request `(p ,@(str->sxml - (G_ "The application did not set the <emph>client_id</emph> parameter."))))) + (W_ "The application did not set the <emph>client_id</emph> parameter."))))) -(define-public (error-no-redirect-uri) +(define (error-no-redirect-uri) (bad-request `(p ,@(str->sxml - (G_ "The application did not set the <emph>redirect_uri</emph> parameter."))))) + (W_ "The application did not set the <emph>redirect_uri</emph> parameter."))))) (define (wrap-error err) - (if (record? err) - (let* ((type (record-type-descriptor err)) - (get - (lambda (slot) - ((record-accessor type slot) err))) - (recurse - (lambda (err) - (wrap-error err)))) - (case (record-type-name type) - ((¬-base64) - `((li ,(format #f (G_ "the value ~s is not a base64 string.") - (get 'value))))) - ((¬-json) - `((li ,(format #f (G_ "the following value is not JSON:")) - (pre ,(get 'value))))) - ((¬-turtle) - `((li ,(format #f (G_ "the following value is not Turtle:")) - (pre ,(get 'value))))) - ((&response-failed-unexpectedly) - `((li ,(format #f (G_ "the server request unexpectedly failed with code ~a and reason phrase ~s.") - (get 'response-code) (get 'response-reason-phrase))))) - ((&unexpected-header-value) - `((li ,(let ((value (get 'value))) - (if value - (format #f (G_ "the header ~a should not have the value ~s.\n") - (get 'header) value) - (format #f (G_ "the header ~a should be present.") - (get 'header))))))) - ((&unexpected-response) - (cons - `(li ,(format #f (G_ "the server response wasn’t expected:")) - (pre ,(call-with-output-string - (lambda (port) - (write-response (get 'response) port))))) - (recurse (get 'cause)))) - ((&incorrect-client-id-field) - (let ((value (get 'value))) - `((li - ,(if value - (format #f (G_ "the client_id field is incorrect: ~s") value) - (G_ "the client_id field is missing")))))) - ((&incorrect-redirect-uris-field) - (let ((value (get 'value))) - `((li - ,(if value - (format #f (G_ "the redirect_uris field is incorrect: ~s") value) - (G_ "the redirect_uris field is missing")))))) - ((&cannot-fetch-linked-data) - (cons - `(li ,(format #f (G_ "I could not fetch a RDF graph at ~a;") (uri->string (get 'uri)))) - (recurse (get 'cause)))) - ((¬-a-client-manifest) - (cons - `(li ,(format #f (G_ "this is not a client manifest:")) - (pre ,(format #f "~s" (get 'value)))) - (recurse (get 'cause)))) - ((&unauthorized-redirection-uri) - (cons - `(li ,(format #f (G_ "the manifest does not authorize redirection URI ~a:") - (uri->string (get 'uri))) - (pre ,(format #f "~s" (get 'manifest)))) - (recurse (get 'cause)))) - ((&inconsistent-client-manifest-id) - `((li ,(format #f (G_ "the client manifest at ~a is advertised for ~a;") - (uri->string (get 'id)) - (uri->string (get 'advertised-id)))))) - ((&cannot-fetch-client-manifest) - (cons - `(li ,(format #f (G_ "I could not fetch the client manifest of ~a;") - (uri->string (get 'id)))) - (recurse (get 'cause)))) - ((¬-an-authorization-code-payload) - (cons - `(li ,(format #f (G_ "I could not issue an authorization code for you;"))) - (recurse (get 'cause)))) - (else - (raise-exception err)))) - (throw err))) + (if (message-for-the-user? err) + (user-message err) + `(p (W_ "Sorry, no more information is available.")))) -(define-public (error-application error) +(define (error-application error) (bad-request - `(p ,(G_ "The application you are trying to authorize behaved unexpectedly. Here is the explanation of the error:") - (ol ,@(wrap-error error))))) + `(div + (p ,(W_ "The application you are trying to authorize behaved unexpectedly.")) + ,@(sxml-match + (wrap-error error) + ((div ,element ...) + `(,element ...)) + (,else `(,else)))))) -(define-public (redirection client-id uri) +(define (redirection client-id uri) (values (build-response #:code 302 #:headers `((location . ,uri) (content-type application/xhtml+xml))) (make-page - (G_ "Redirecting...") + (W_ "Redirecting...") `(h1 "Authorization granted, you are being redirected") `(p ,@(str->sxml (format #f - (G_ "<a href=~s>~a</a> can now log in on your behalf. You still need to adjust permissions.") + (W_ "<p><a href=~s>~a</a> can now log in on your behalf. You still need to adjust permissions.</p>") (uri->string client-id) (uri->string client-id))))))) diff --git a/src/scm/webid-oidc/authorization-page.scm b/src/scm/webid-oidc/authorization-page.scm index 453275b..536137e 100644 --- a/src/scm/webid-oidc/authorization-page.scm +++ b/src/scm/webid-oidc/authorization-page.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -16,60 +16,41 @@ (define-module (webid-oidc authorization-page) #:use-module (webid-oidc errors) + #:use-module ((webid-oidc web-i18n) #:prefix i18n:) #:use-module ((webid-oidc authorization-page-unsafe) #:prefix unsafe:) - #:use-module (ice-9 i18n) #:use-module (ice-9 string-fun) #:use-module (ice-9 receive) - #:use-module (ice-9 threads)) - -(define locale-mutex - (make-mutex)) - -(define-syntax with-locale - (syntax-rules () - ((with-locale web-locale . job) - (let ((locale-with-underscore - (if (equal? web-locale "C") - ;; For the unit tests - "C" - (string-append - (string-replace-substring web-locale "-" "_") - ".UTF-8"))) - (previous-locale (setlocale LC_ALL))) - (dynamic-wind - (lambda () - (lock-mutex locale-mutex)) - (lambda () - (dynamic-wind - (lambda () - (with-exception-handler - (lambda (error) - (raise-unknown-client-locale web-locale locale-with-underscore) - (setlocale LC_ALL "C")) - (lambda () - (setlocale LC_ALL locale-with-underscore)) - #:unwind? #t)) - (lambda () . job) - (lambda () - (setlocale LC_ALL previous-locale)))) - (lambda () - (unlock-mutex locale-mutex))))))) - -(define-public (authorization-page - locale credential-invalid? client-id post-uri) - (with-locale - locale - (unsafe:authorization-page credential-invalid? - client-id post-uri))) - -(define-public (error-no-client-id locale) - (with-locale locale (unsafe:error-no-client-id))) - -(define-public (error-no-redirect-uri locale) - (with-locale locale (unsafe:error-no-redirect-uri))) - -(define-public (error-application locale error) - (with-locale locale (unsafe:error-application error))) - -(define-public (redirection locale client-id uri) - (with-locale locale (unsafe:redirection client-id uri))) + #:use-module (ice-9 threads) + #:declarative? #t + #:export + ( + + authorization-page + error-no-client-id + error-no-redirect-uri + error-application + redirection + + )) + +(define (authorization-page + locale credential-invalid? client-id post-uri) + (parameterize ((i18n:web-locale locale)) + (unsafe:authorization-page credential-invalid? + client-id post-uri))) + +(define (error-no-client-id locale) + (parameterize ((i18n:web-locale locale)) + (unsafe:error-no-client-id))) + +(define (error-no-redirect-uri locale) + (parameterize ((i18n:web-locale locale)) + (unsafe:error-no-redirect-uri))) + +(define (error-application locale error) + (parameterize ((i18n:web-locale locale)) + (unsafe:error-application error))) + +(define (redirection locale client-id uri) + (parameterize ((i18n:web-locale locale)) + (unsafe:redirection client-id uri))) diff --git a/src/scm/webid-oidc/cache.scm b/src/scm/webid-oidc/cache.scm index e98f87f..c9d7b26 100644 --- a/src/scm/webid-oidc/cache.scm +++ b/src/scm/webid-oidc/cache.scm @@ -17,6 +17,7 @@ (define-module (webid-oidc cache) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module (webid-oidc web-i18n) #:use-module (web client) #:use-module (web request) #:use-module (web response) @@ -26,6 +27,7 @@ #:use-module (ice-9 optargs) #:use-module (srfi srfi-19) #:use-module (rnrs bytevectors) + #:declarative? #t #:export ( clean-cache @@ -89,19 +91,19 @@ (unless (false-if-exception (begin - (format (current-error-port) "Dropping cache item ~a.~%" name) + (format (current-error-port) (G_ "Dropping cache item ~a.~%") name) (stubs:atomically-update-file name lock-file (lambda (whatever) #f)))) - (format (current-error-port) "Could not clean file ~a.~%" name))) + (format (current-error-port) (G_ "Could not clean file ~a.~%") name))) result) (define (down name stat result) result) (define (up name stat result) result) (define (skip name stat result) result) (define (error name stat errno result) - (format (current-error-port) "While cleaning the cache: ~a: ~a~%" + (format (current-error-port) (G_ "While cleaning the cache: ~a: ~a~%") name (strerror errno)) result) (file-system-fold enter? leaf down up skip error 0 @@ -161,7 +163,7 @@ (let ((response (read-response port))) (values request response (read-response-body response))))))) (lambda error - (format (current-error-port) "Cache miss for ~a: ~s~%" + (format (current-error-port) (G_ "Cache miss for ~a: ~s~%") (uri->string uri) error) (values #f #f #f))))) @@ -255,7 +257,9 @@ (let ((valid (valid? stored-response)) (invariant (not (varies? request stored-request stored-response)))) (unless invariant - (format (current-error-port) "Cache entry for ~a varies.\n" (uri->string uri))) + (format (current-error-port) + (G_ "Cache entry for ~a varies.\n") + (uri->string uri))) (if (and valid invariant) (values stored-response body) (receive (final-response final-body) diff --git a/src/scm/webid-oidc/catalog.scm b/src/scm/webid-oidc/catalog.scm index 11e0877..e12ebe6 100644 --- a/src/scm/webid-oidc/catalog.scm +++ b/src/scm/webid-oidc/catalog.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -24,6 +24,8 @@ #:use-module (sxml match) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) + #:use-module (webid-oidc web-i18n) + #:declarative? #t #:export (resolve-uri)) (define useful-namespaces @@ -161,7 +163,7 @@ (("." components ...) (with-absolute-relative-path defined components)) ((".." components ...) (match defined - (() (error "Invalid relative URI")) + (() (fail (G_ "invalid relative URI"))) ((dropped kept ...) (with-absolute-relative-path kept components)))) ((head components ...) @@ -240,7 +242,8 @@ (lambda (port) (xml->sxml port #:namespaces useful-namespaces)))) (else - (error (format #f "Unsupported delegate catalog URI scheme: ~s\n" (uri-scheme uri)))))) + (error (format #f (G_ "Unsupported delegate catalog URI scheme: ~s\n") + (uri-scheme uri)))))) (define* (resolve-uri uri #:key (http-get http-get)) (when (string? uri) diff --git a/src/scm/webid-oidc/client-manifest.scm b/src/scm/webid-oidc/client-manifest.scm index c4b49f0..847fc54 100644 --- a/src/scm/webid-oidc/client-manifest.scm +++ b/src/scm/webid-oidc/client-manifest.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -17,61 +17,194 @@ (define-module (webid-oidc client-manifest) #:use-module (webid-oidc errors) #:use-module (webid-oidc fetch) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (web uri) #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) #:use-module (rdf rdf) - #:use-module (turtle tordf)) + #:use-module (turtle tordf) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (sxml match) + #:use-module (sxml simple) + #:declarative? #t + #:export + ( -(define-public public-oidc-client + public-oidc-client + + &invalid-client-manifest + make-invalid-client-manifest + invalid-client-manifest? + + &unauthorized-redirect-uri + make-unauthorized-redirect-uri + unauthorized-redirect-uri? + + &inconsistent-client-manifest + make-inconsistent-client-manifest + inconsistent-client-manifest? + + &cannot-serve-public-manifest + make-cannot-serve-public-manifest + cannot-serve-public-manifest? + + &cannot-fetch-client-manifest + make-cannot-fetch-client-manifest + cannot-fetch-client-manifest? + + the-client-manifest + client-manifest? + make-client-manifest + client-manifest-client-id + client-manifest-check-redirect-uri + + serve-client-manifest + get-client-manifest + + )) + +(define public-oidc-client 'public-oidc-client) -(define-public (all-uris x) - (or (null? x) - (and (string->uri (car x)) - (all-uris (cdr x))))) - -(define-public (the-client-manifest x) - (if (eq? x public-oidc-client) - public-oidc-client - (let ((client-id (assq-ref x 'client_id)) - (redirect-uris (assq-ref x 'redirect_uris))) - (unless (and client-id (string? client-id) (string->uri client-id)) - (raise-incorrect-client-id-field client-id)) - (unless (and redirect-uris - (vector? redirect-uris) - (all-uris (vector->list redirect-uris))) - (raise-incorrect-redirect-uris-field redirect-uris)) - x))) - -(define-public (client-manifest? obj) +(define-exception-type + &invalid-client-manifest + &external-error + make-invalid-client-manifest + invalid-client-manifest?) + +(define-exception-type + &unauthorized-redirect-uri + &external-error + make-unauthorized-redirect-uri + unauthorized-redirect-uri?) + +(define-exception-type + &inconsistent-client-manifest + &external-error + make-inconsistent-client-manifest + inconsistent-client-manifest?) + +(define-exception-type + &cannot-serve-public-manifest + &external-error + make-cannot-serve-public-manifest + cannot-serve-public-manifest?) + +(define-exception-type + &cannot-fetch-client-manifest + &external-error + make-cannot-fetch-client-manifest + cannot-fetch-client-manifest?) + +(define (the-client-manifest x) + (with-exception-handler + (lambda (error) + (let ((sysadmin-message + (if (exception-with-message? error) + (format #f (G_ "this is not a client manifest: ~a") + (exception-message error)) + (format #f (G_ "this is not a client manifest")))) + (user-message + (let ((new-paragraph + (sxml-match + (xml->sxml (W_ "<p>The client manifest could +not be queried. It can be because the client application is down, or +it is incomplete, or unusable for other reasons.</p>")) + ((*TOP* ,element) + element)))) + (if (message-for-the-user? error) + (sxml-match + (user-message error) + ((div ,element ...) + `(div ,new-paragraph ,element ...)) + (,element + `(div ,new-paragraph ,element))) + new-paragraph)))) + (raise-exception + (make-exception + (make-invalid-client-manifest) + (make-exception-with-message sysadmin-message) + (make-message-for-the-user user-message) + error)))) + (lambda () + (let examine-fields ((fields x) + (client-id #f) + (redirect-uris #f) + (other-fields '())) + (match fields + (() + (unless (and client-id redirect-uris) + (fail (format #f (G_ "the client manifest is missing ~s") + (apply append + `(,@(if client-id '() '("client_id")) + ,@(if redirect-uris '() '("redirect_uris"))))))) + `((client_id . ,(uri->string client-id)) + (redirect_uris . ,(list->vector (map uri->string redirect-uris))) + ,@(reverse other-fields))) + ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) fields ...) + (examine-fields fields (or client-id client-id-given) + redirect-uris other-fields)) + ((('client_id . invalid) _ ...) + (fail (format #f (G_ "~s is an invalid \"client_id\" value, because it is not an URI") + invalid))) + ((('redirect_uris . #((? string? (= string->uri (? uri? uri))) ...)) fields ...) + (examine-fields fields client-id (or redirect-uris uri) other-fields)) + ((('redirect_uris . #(_ ...)) _ ...) + (fail (format #f (G_ "at least one of the redirect URIs is not a proper URI")))) + ((('redirect_uris . _) _ ...) + (fail (format #f (G_ "the \"redirect_uris\" field should be a vector of URIs")))) + ((other-field fields ...) + (examine-fields fields client-id redirect-uris + `(,other-field ,@other-fields))) + (else + (fail (format #f (G_ "the client manifest should be a JSON object"))))))))) + +(define (client-manifest? x) (false-if-exception - (and (the-client-manifest obj) #t))) + (the-client-manifest x))) -(define-public (make-client-manifest client-id redirect-uris) +(define (make-client-manifest client-id redirect-uris) (the-client-manifest `((client_id . ,(uri->string client-id)) (redirect_uris . ,(list->vector (map uri->string redirect-uris)))))) -(define-public (client-manifest-client-id mf) +(define (client-manifest-client-id mf) (if (eq? mf public-oidc-client) (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient") (string->uri (assq-ref (the-client-manifest mf) 'client_id)))) (define (check-redirect mf uris redir) - (if (null? uris) - (raise-unauthorized-redirection-uri mf (string->uri redir)) - (or (string=? (car uris) redir) - (check-redirect mf (cdr uris) redir)))) + (match uris + (() + (let ((final-message + (format #f (G_ "the client manifest does not allow ~s as a redirection uri") + (uri->string redir))) + (final-user-message + (sxml-match + (xml->sxml (W_ "<p>The application wants to get your +authorization through <strong>~s</strong>, which is not +approved.</p>")) + ((*TOP* ,element) element)))) + (raise-exception + (make-exception + (make-unauthorized-redirect-uri) + (make-exception-with-message final-message) + (make-message-for-the-user final-user-message))))) + (((? (cute equal? <> redir) redir) _ ...) + #t) + ((_ uris ...) + (check-redirect mf uris redir)))) -(define-public (client-manifest-check-redirect-uri mf redir) +(define (client-manifest-check-redirect-uri mf redir) (unless (uri? redir) (set! redir (string->uri redir))) (if (eq? mf public-oidc-client) @@ -79,12 +212,17 @@ (let ((redirect-uris (assq-ref (the-client-manifest mf) 'redirect_uris))) (check-redirect (the-client-manifest mf) - (vector->list redirect-uris) - (uri->string redir))))) + (map string->uri (vector->list redirect-uris)) + redir)))) -(define-public (serve-client-manifest expiration-date mf) +(define (serve-client-manifest expiration-date mf) (when (eq? mf public-oidc-client) - (raise-cannot-serve-public-manifest)) + (let ((final-message + (format #f (G_ "cannot serve the public manifest")))) + (raise-exception + (make-exception + (make-cannot-serve-public-manifest) + (make-exception-with-message final-message))))) (let ((json-object (stubs:scm->json-string `((@context . "https://www.w3.org/ns/solid/oidc-context.jsonld") ,@(the-client-manifest mf))))) @@ -92,14 +230,25 @@ (expires . ,expiration-date))) json-object))) -(define*-public (get-client-manifest id - #:key - (http-get http-get)) +(define* (get-client-manifest id + #:key + (http-get http-get)) (unless (uri? id) (set! id (string->uri id))) (with-exception-handler (lambda (error) - (raise-cannot-fetch-client-manifest id error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot fetch the client manifest ~s: ~a") + (uri->string id) + (exception-message error)) + (format #f (G_ "cannot fetch the client manifest ~s") + (uri->string id))))) + (raise-exception + (make-exception + (make-cannot-fetch-client-manifest) + (make-exception-with-message final-message) + error)))) (lambda () (if (equal? id (string->uri @@ -110,9 +259,13 @@ (when (bytevector? response-body) (set! response-body (utf8->string response-body))) (let ((mf (the-client-manifest (stubs:json-string->scm response-body)))) - (unless (equal? (uri->string (client-manifest-client-id mf)) - (uri->string id)) - (raise-inconsistent-client-manifest-id - id - (client-manifest-client-id mf))) + (unless (equal? (client-manifest-client-id mf) id) + (let ((final-message + (format #f (G_ "the client manifest is dereferenced from ~s, but it pretends to be ~s") + (uri->string id) + (uri->string (client-manifest-client-id mf))))) + (raise-exception + (make-exception + (make-inconsistent-client-manifest) + (make-exception-with-message final-message))))) mf)))))) diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index 4fdb824..f469d19 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -57,6 +57,9 @@ ) #:declarative? #t) +;; Better for syntax highlighting +(define <client:account> client:<account>) + (define-record-type <client> (make-client id key redirect-uri) client? @@ -124,7 +127,7 @@ #:client-id client-id #:client-key client-key #:redirect-uri redirect-uri))) - (($ <account> subject issuer _ _ _ _) + ((($ <client:account> subject issuer _ _ _ _)) (client:save-account (client:login subject issuer #:http-get my-http-get diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm index 98fef85..447f760 100644 --- a/src/scm/webid-oidc/client/accounts.scm +++ b/src/scm/webid-oidc/client/accounts.scm @@ -17,6 +17,7 @@ #:use-module (web uri) #:use-module (web response) #:use-module (rnrs bytevectors) + #:declarative? #t #:export ( <account> @@ -79,17 +80,24 @@ (response token-request-response) (response-body token-request-response-body)) +(define-exception-type + &refresh-token-expired + &external-error + make-refresh-token-expired + refresh-token-expired?) + (define authorization-process (make-parameter (lambda* (uri #:key issuer) - (raise-exception - (make-exception - (make-authorization-code-required uri) - (make-exception-with-message - (G_ (format #f "An authorization code is required to log in with ~s, it can be obtained at ~s." - (uri->string issuer) - (uri->string uri))))) - #:continuable? #t)))) + (let ((final-message + (G_ (format #f "An authorization code is required to log in with ~s, it can be obtained at ~s." + (uri->string issuer) + (uri->string uri))))) + (raise-exception + (make-exception + (make-authorization-code-required uri) + (make-exception-with-message final-message)) + #:continuable? #t))))) (define-record-type <account> (make-account subject issuer id-token access-token refresh-token keypair) @@ -118,16 +126,17 @@ ((hd tl ...) (sxml-match hd - ((disfluid:id-token (@ (sub ,sub) (aud ,aud) (nonce ,nonce) (iat ,iat) (exp ,exp))) + ((disfluid:id-token (@ (alg ,alg) (sub ,sub) (aud ,aud) (nonce ,nonce) (iat ,iat) (exp ,exp))) (collect-arguments - (id:the-id-token-payload - `((webid . ,(uri->string subject)) - (iss . ,(uri->string issuer)) - (sub . ,sub) - (aud . ,aud) - (nonce . ,nonce) - (iat . ,(string->number iat)) - (exp . ,(string->number exp)))) + (id:the-id-token + `(((alg . ,alg)) + . ((webid . ,(uri->string subject)) + (iss . ,(uri->string issuer)) + (sub . ,sub) + (aud . ,aud) + (nonce . ,nonce) + (iat . ,(string->number iat)) + (exp . ,(string->number exp))))) access-token refresh-token keypair @@ -240,7 +249,8 @@ '()) (issuer ,(uri->string issuer))) ,@(if id-token - `((id-token (@ (sub ,(id:id-token-sub id-token)) + `((id-token (@ (alg ,(symbol->string (id:id-token-alg id-token))) + (sub ,(id:id-token-sub id-token)) (aud ,(uri->string (id:id-token-aud id-token))) (nonce ,(id:id-token-nonce id-token)) (iat @@ -404,105 +414,118 @@ (save-account (invalidate-refresh-token (make-account subject issuer #f #f #f #f)))) - (raise-exception - (make-refresh-token-expired) - (make-exception-with-message - (G_ (format #f "The refresh token has expired."))))) + (let ((final-message + (format #f (G_ "The refresh token has expired.")))) + (raise-exception + (make-exception + (make-refresh-token-expired) + (make-exception-with-message final-message))))) (unless (eqv? (response-code response) 200) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token request failed with code ~s (~s).") - (response-code response) - (response-reason-phrase response)))))) + (let ((final-message + (G_ (format #f "The token request failed with code ~s (~s).") + (response-code response) + (response-reason-phrase response)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (unless (response-content-type response) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response did not set the content type.")))))) + (let ((final-message + (format #f (G_ "The token response did not set the content type.")))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (with-exception-handler (lambda (encoding-error) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token endpoint did not respond in UTF-8."))) - encoding-error))) + (let ((final-message + (format #f (G_ "The token endpoint did not respond in UTF-8.")))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message) + encoding-error)))) (lambda () (when (bytevector? response-body) (set! response-body (utf8->string response-body))))) (unless (eq? (car (response-content-type response)) 'application/json) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response has content-type ~s, not application/json.") - (response-content-type response)))))) + (let ((final-message + (format #f (G_ "The token response has content-type ~s, not application/json.") + (response-content-type response)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (let ((data (with-exception-handler (lambda (json-error) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response is not valid JSON."))) - json-error))) + (let ((final-message + (format #f (G_ "The token response is not valid JSON.")))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message) + json-error)))) (lambda () (stubs:json-string->scm response-body))))) (let ((id-token (assq-ref data 'id_token)) (access-token (assq-ref data 'access_token)) (refresh-token (assq-ref data 'refresh_token))) (unless id-token - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response did not include an ID token: ~s") - data))))) + (let ((final-message + (format #f (G_ "The token response did not include an ID token: ~s") + data))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (unless access-token - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The token response did not include an access token: ~s + (let ((final-message + (format #f (G_ "The token response did not include an access token: ~s ") - data))))) + data))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (with-exception-handler (lambda (decoding-error) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The ID token signature is invalid."))) - decoding-error))) + (let ((final-message + (if (exception-with-message? decoding-error) + (format #f (G_ "the ID token signature is invalid: ~a") + (exception-message decoding-error)) + (format #f (G_ "the ID token signature is invalid"))))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message) + decoding-error)))) (lambda () - (match (id:id-token-decode id-token #:http-get http-get) - ((header . payload) - (set! id-token payload))))) + (set! id-token (id:id-token-decode id-token #:http-get http-get)))) ;; We are not interested in the ID token ;; signature anymore, because it won’t be ;; transmitted to other parties and we know that ;; it is valid. (when (and subject (not (equal? subject (id:id-token-webid id-token)))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The ID token delivered by the identity provider for ~s has ~s as webid.") - (uri->string subject) - (id:id-token-webid id-token)))))) + (let ((final-message + (format #f (G_ "the ID token delivered by the identity provider for ~s has ~s as webid") + (uri->string subject) + (id:id-token-webid id-token)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (when (not (equal? issuer (id:id-token-iss id-token))) - (raise-exception - (make-exception - (make-token-request-failed response response-body) - (make-exception-with-message - (G_ (format #f "The ID token delivered by the identity provider ~s is for issuer ~s.") - (uri->string issuer) - (id:id-token-iss id-token)))))) + (let ((final-message + (format #f (G_ "The ID token delivered by the identity provider ~s is for issuer ~s.") + (uri->string issuer) + (id:id-token-iss id-token)))) + (raise-exception + (make-exception + (make-token-request-failed response response-body) + (make-exception-with-message final-message))))) (make-account (id:id-token-webid id-token) issuer diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm index 2ccbddc..b1e07f9 100644 --- a/src/scm/webid-oidc/dpop-proof.scm +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -21,156 +21,241 @@ #:use-module (webid-oidc jti) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module (webid-oidc web-i18n) #:use-module (web uri) #:use-module (ice-9 optargs) - #:use-module (srfi srfi-19)) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:declarative? #t + #:export + ( -(define-public (the-dpop-proof-header x) - (with-exception-handler - (lambda (error) - (raise-not-a-dpop-proof-header x error)) - (lambda () - (let ((x (the-jws-header x))) - (let ((alg (assq-ref x 'alg)) - (typ (assq-ref x 'typ)) - (jwk (assq-ref x 'jwk))) - (unless (and alg (string? alg)) - (raise-unsupported-alg alg)) - (case (string->symbol alg) - ((RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512) - #t) - (else - (raise-unsupported-alg alg))) - (unless (equal? typ "dpop+jwt") - (raise-incorrect-typ-field typ)) - (with-exception-handler - (lambda (error) - (raise-incorrect-jwk-field jwk error)) - (lambda () - (the-public-jwk jwk))) - x))))) - -(define-public (dpop-proof-header? x) - (false-if-exception - (and (the-dpop-proof-header x) #t))) - -(define-public (the-dpop-proof-payload x) - (with-exception-handler - (lambda (error) - (raise-not-a-dpop-proof-payload x error)) - (lambda () - (let ((x (the-jws-payload x))) - (let ((jti (assq-ref x 'jti)) - (htm (assq-ref x 'htm)) - (htu (assq-ref x 'htu)) - (iat (assq-ref x 'iat)) - (ath (assq-ref x 'ath))) - (unless (and jti (string? jti)) - (raise-incorrect-jti-field jti)) - (unless (and htm (string? htm)) - (raise-incorrect-htm-field htm)) - (unless (and htu (string? htu) (string->uri htu)) - (raise-incorrect-htu-field htu)) - (unless (and iat (integer? iat)) - (raise-incorrect-iat-field iat)) - (unless (or (not ath) (string? ath)) - (raise-incorrect-ath-field ath)) - x))))) - -(define-public (dpop-proof-payload? x) - (false-if-exception - (and (the-dpop-proof-payload x) #t))) - -(define-public (the-dpop-proof x) + &invalid-dpop-proof + make-invalid-dpop-proof + invalid-dpop-proof? + + the-dpop-proof + dpop-proof? + + dpop-proof-alg + dpop-proof-typ + dpop-proof-jwk + + dpop-proof-jti + dpop-proof-htm + dpop-proof-htu + dpop-proof-iat + dpop-proof-ath + + &dpop-method-mismatch + make-dpop-method-mismatch + dpop-method-mismatch? + dpop-method-mismatch-advertised + dpop-method-mismatch-actual + + &dpop-uri-mismatch + make-dpop-uri-mismatch + dpop-uri-mismatch? + dpop-uri-mismatch-advertised + dpop-uri-mismatch-actual + + &dpop-invalid-ath + make-dpop-invalid-ath + dpop-invalid-ath? + dpop-invalid-ath-hash + dpop-invalid-ath-access-token + + &dpop-unconfirmed-key + make-dpop-unconfirmed-key + dpop-unconfirmed-key? + + dpop-proof-decode + issue-dpop-proof + )) + +(define-exception-type + &invalid-dpop-proof + &external-error + make-invalid-dpop-proof + invalid-dpop-proof?) + +(define (the-dpop-proof x) (with-exception-handler (lambda (error) - (raise-not-a-dpop-proof x error)) + (let ((final-message + (cond + ((invalid-jws? error) + (if (exception-with-message? error) + (format #f (G_ "this is not a DPoP proof, because it is not even a JWS: ~a") + (exception-message error)) + (format #f (G_ "this is not a DPoP proof, 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-dpop-proof) + (make-exception-with-message final-message) + error)))) (lambda () - (cons (the-dpop-proof-header (car x)) - (the-dpop-proof-payload (cdr x)))))) - -(define-public (dpop-proof? x) - (false-if-exception - (and (the-dpop-proof x) #t))) - -(define-public (make-dpop-proof header payload) - (the-dpop-proof (cons header payload))) - -(define-public (make-dpop-proof-header alg jwk) - (when (symbol? alg) - (set! alg (symbol->string alg))) - (the-dpop-proof-header - `((alg . ,alg) - (typ . "dpop+jwt") - (jwk . ,(stubs:strip-key jwk))))) - -(define-public (make-dpop-proof-payload jti htm htu iat ath) - (when (symbol? htm) - (set! htm (symbol->string htm))) - (when (uri? htu) - (set! htu (uri->string htu))) - (when (date? iat) - (set! iat (date->time-utc iat))) - (when (time? iat) - (set! iat (time-second iat))) - (the-dpop-proof-payload - `((jti . ,jti) - (htm . ,htm) - (htu . ,htu) - (iat . ,iat) - ,@(if ath - `((ath . ,ath)) - '())))) - -(define-public (dpop-proof-header dpop) - (car (the-dpop-proof dpop))) - -(define-public (dpop-proof-payload dpop) - (cdr (the-dpop-proof dpop))) - -(define-public (dpop-proof-alg code) - (when (dpop-proof? code) - (set! code (dpop-proof-header code))) - (jws-alg (the-dpop-proof-header code))) - -(define-public (dpop-proof-jwk dpop) - (when (dpop-proof? dpop) - (set! dpop (dpop-proof-header dpop))) - (assq-ref (the-dpop-proof-header dpop) 'jwk)) - -(define-public (dpop-proof-jti dpop) - (when (dpop-proof? dpop) - (set! dpop (dpop-proof-payload dpop))) - (assq-ref (the-dpop-proof-payload dpop) 'jti)) - -(define-public (dpop-proof-htm dpop) - (when (dpop-proof? dpop) - (set! dpop (dpop-proof-payload dpop))) - (string->symbol - (assq-ref (the-dpop-proof-payload dpop) - 'htm))) - -(define-public (dpop-proof-htu dpop) - (when (dpop-proof? dpop) - (set! dpop (dpop-proof-payload dpop))) - (string->uri - (assq-ref (the-dpop-proof-payload dpop) - 'htu))) - -(define-public (dpop-proof-iat dpop) - (when (dpop-proof? dpop) - (set! dpop (dpop-proof-payload dpop))) - (time-utc->date - (make-time time-utc - 0 - (assq-ref (the-dpop-proof-payload dpop) - 'iat)))) - -(define-public (dpop-proof-ath dpop) - (when (dpop-proof? dpop) - (set! dpop (dpop-proof-payload dpop))) - (assq-ref (the-dpop-proof-payload dpop) - 'ath)) + (match (the-jws x) + ((header . payload) + (let examine-header ((header header) + (alg #f) + (typ #f) + (jwk #f) + (other-header-fields '())) + (match header + (() + (let examine-payload ((payload payload) + (jti #f) + (htm #f) + (htu #f) + (iat #f) + (ath #f) + (other-payload-fields '())) + (match payload + (() + (unless (and alg typ jwk jti htm htu iat) + (fail (format #f (G_ "the DPoP proof is missing ~s") + `(,@(if alg '() '("alg")) + ,@(if typ '() '("typ")) + ,@(if jwk '() '("jwk")) + ,@(if jti '() '("jti")) + ,@(if htm '() '("htm")) + ,@(if htu '() '("htu")) + ,@(if iat '() '("iat")))))) + `(((alg . ,(symbol->string alg)) + (typ . "dpop+jwt") + (jwk . ,(strip jwk)) + ,@other-header-fields) + . ((jti . ,jti) + (htm . ,(symbol->string htm)) + (htu . ,(uri->string htu)) + (iat . ,(time-second (date->time-utc iat))) + ,@(if ath `((ath . ,ath)) '()) + ,@other-payload-fields))) + ((('jti . (? string? given-jti)) payload ...) + (examine-payload payload + (or jti given-jti) htm htu iat ath + other-payload-fields)) + ((('jti . incorrect) payload ...) + (fail (format #f (G_ "the \"jti\" field should be a string, not ~s") + incorrect))) + ((('htm . (? string? given-htm)) payload ...) + (examine-payload payload jti + (or htm (string->symbol given-htm)) + htu iat ath other-payload-fields)) + ((('htm . incorrect) payload ...) + (fail (format #f (G_ "the \"htm\" field should be a string, not ~s") + incorrect))) + ((('htu . (? string? (= string->uri (? uri? given-htu)))) payload ...) + (examine-payload payload jti htm + (or htu given-htu) + iat ath other-payload-fields)) + ((('htu . incorrect) payload ...) + (fail (format #f (G_ "the \"htu\" field should be an URI, not ~s") + incorrect))) + ((('iat . (? (cute >= <> 0) (? integer? given-iat))) payload ...) + (examine-payload payload jti htm htu + (or iat (time-utc->date (make-time time-utc 0 given-iat))) + ath other-payload-fields)) + ((('iat . incorrect) payload ...) + (fail (format #f (G_ "the \"iat\" field should be a timestamp, not ~s") + incorrect))) + ((('ath . (? string? given-ath)) payload ...) + (examine-payload payload jti htm htu iat + (or ath given-ath) + other-payload-fields)) + ((('ath . incorrect) payload ...) + (fail (format #f (G_ "the \"ath\" field should be an encoded JWT, not ~s") + incorrect))) + ((field payload ...) + (examine-payload payload jti htm htu iat ath + `(,field ,@other-payload-fields)))))) + ((('alg . (? string? given-alg)) header ...) + (examine-header header (or alg (string->symbol given-alg)) + typ jwk other-header-fields)) + ((('alg . incorrect) header ...) + (fail (format #f (G_ "the \"alg\" field should be a string, not ~s") + incorrect))) + ((('typ . "dpop+jwt") header ...) + (examine-header header alg #t jwk other-header-fields)) + ((('typ . incorrect) header ...) + (fail (format #f (G_ "the \"typ\" field should be \"dpop+jwt\", not ~s") + incorrect))) + ((('jwk . (? jwk-public? given-jwk)) header ...) + (examine-header header alg typ (or jwk (the-public-jwk given-jwk)) + other-header-fields)) + ((('jwk . incorrect) header ...) + (fail (format #f (G_ "the \"jwk\" field should be a valid public key, not ~s") + incorrect))) + ((field header ...) + (examine-header header alg typ jwk `(,field ,@other-header-fields)))))))))) + +(define (dpop-proof? x) + (false-if-exception (the-dpop-proof x))) + +(define (dpop-proof-alg proof) + (match (the-dpop-proof proof) + ((header . _) + (symbol->string (assq-ref header 'alg))))) + +(define (dpop-proof-typ proof) + (match (the-dpop-proof proof) + ((header . _) + (assq-ref header 'typ)))) + +(define (dpop-proof-jwk proof) + (match (the-dpop-proof proof) + ((header . _) + (the-public-jwk (assq-ref header 'jwk))))) + +(define (dpop-proof-jti proof) + (match (the-dpop-proof proof) + ((_ . payload) + (assq-ref payload 'jti)))) + +(define (dpop-proof-htm proof) + (match (the-dpop-proof proof) + ((_ . payload) + (string->symbol (assq-ref payload 'htm))))) + +(define (dpop-proof-htu proof) + (match (the-dpop-proof proof) + ((_ . payload) + (string->uri (assq-ref payload 'htu))))) + +(define (dpop-proof-iat proof) + (match (the-dpop-proof proof) + ((_ . payload) + (time-utc->date + (make-time time-utc 0 (assq-ref payload 'iat)))))) + +(define (dpop-proof-ath proof) + (match (the-dpop-proof proof) + ((_ . payload) + (assq-ref payload 'ath)))) + +(define-exception-type + &dpop-method-mismatch + &external-error + make-dpop-method-mismatch + dpop-method-mismatch? + (advertised dpop-method-mismatch-advertised) + (actual dpop-method-mismatch-actual)) + +(define-exception-type + &dpop-uri-mismatch + &external-error + make-dpop-uri-mismatch + dpop-uri-mismatch? + (advertised dpop-uri-mismatch-advertised) + (actual dpop-uri-mismatch-actual)) (define (uris-compatible a b) ;; a is what is signed, b is the request @@ -185,71 +270,151 @@ (uri-path a)) (split-and-decode-uri-path (uri-path b)))) - (raise-dpop-uri-mismatch a b))) + (let ((final-message + (format #f (G_ "the DPoP proof is signed for ~s, but it is issued to ~s") + (uri->string a) (uri->string b)))) + (raise-exception + (make-exception + (make-dpop-uri-mismatch a b) + (make-exception-with-message final-message)))))) + +(define-exception-type + &dpop-invalid-ath + &external-error + make-dpop-invalid-ath + dpop-invalid-ath? + (hash dpop-invalid-ath-hash) + (access-token dpop-invalid-ath-access-token)) + +(define-exception-type + &dpop-unconfirmed-key + &external-error + make-dpop-unconfirmed-key + dpop-unconfirmed-key?) -(define*-public (dpop-proof-decode method uri str cnf/check - #:key - (access-token #f)) - (let ((current-time - (time-second (date->time-utc ((p:current-date)))))) +(define* (dpop-proof-decode method uri str cnf/check + #:key + (access-token #f)) + (let* ((current-date ((p:current-date))) + (current-time + (time-second (date->time-utc current-date)))) (with-exception-handler (lambda (error) - (raise-cannot-decode-dpop-proof str error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the DPoP proof cannot be decoded: ~a") + (exception-message error)) + (format #f (G_ "the DPoP proof cannot be decoded"))))) + (raise-exception + (make-exception + (make-invalid-dpop-proof) + (make-exception-with-message final-message) + error)))) (lambda () (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk)))) (unless (eq? method (dpop-proof-htm decoded)) - (raise-dpop-method-mismatch (dpop-proof-htm decoded) method)) + (let ((final-message + (format #f (G_ "the DPoP proof is signed for access through ~s, but it is used with ~s") + (dpop-proof-htm decoded) method))) + (raise-exception + (make-exception + (make-dpop-method-mismatch (dpop-proof-htm decoded) method) + (make-exception-with-message final-message))))) (uris-compatible (dpop-proof-htu decoded) (if (string? uri) (string->uri uri) uri)) - (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded))))) - (unless (>= current-time (- iat 5)) - (raise-dpop-signed-in-future iat current-time)) - (unless (<= current-time (+ iat 120)) ;; Valid for 2 min - (raise-dpop-too-old iat current-time))) + (let ((iat (dpop-proof-iat decoded))) + (let ((iat-s (time-second (date->time-utc iat)))) + (unless (>= current-time (- iat-s 5)) + (let ((final-message + (format #f (G_ "the DPoP proof is signed in the future, ~a, relative to the current date, ~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))))) + (unless (<= current-time (+ iat-s 120)) ;; valid for 2 minutes + (let ((final-message + (format #f (G_ "the DPoP proof is too old, it was signed ~a and now it is ~a") + (date->string iat) + (date->string current-date)))) + (raise-exception + (make-exception + (make-expired (time-utc->date (make-time time-utc 0 (+ iat-s 120))) + current-date) + (make-exception-with-message final-message))))))) (when access-token (let ((h (stubs:hash 'SHA-256 access-token))) (unless (equal? (dpop-proof-ath decoded) h) - (raise-exception - (make-dpop-invalid-access-token-hash (dpop-proof-ath decoded) access-token))))) + (let ((final-message + (format #f (G_ "the DPoP proof should go along with an access token hashed to ~s, not ~s") + (dpop-proof-ath decoded) access-token))) + (raise-exception + (make-exception + (make-dpop-invalid-ath (dpop-proof-ath decoded) access-token) + (make-exception-with-message final-message))))))) (if (string? cnf/check) (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded))) - (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f)) + (let ((final-message + (format #f (G_ "the DPoP proof is signed with the wrong key")))) + (raise-exception + (make-exception + (make-dpop-unconfirmed-key) + (make-exception-with-message final-message))))) (with-exception-handler (lambda (error) - (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the DPoP proof is signed with the wrong key: ~a") + (exception-message error)) + (format #f (G_ "the DPoP proof is signed with the wrong key"))))) + (raise-exception + (make-exception + (make-dpop-unconfirmed-key) + (make-exception-with-message final-message) + error)))) (lambda () (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded))) - ;; deprecated; throw an error instead! - (error "the cnf/check function returned #f"))))) - (parameterize ((p:current-date current-time)) + ;; You should throw an error instead! + (fail (G_ "the cnf/check function returned #f")))))) + (parameterize ((p:current-date current-date)) ;; jti-check should use the same date. - (unless (jti-check (dpop-proof-jti decoded) 120) - (with-exception-handler - (lambda (error) - (raise-jti-found (dpop-proof-jti decoded) error)) - (lambda () - (error "the jti-check function returned #f")))) - decoded)))))) + (jti-check (dpop-proof-jti decoded) 120)) + decoded))))) -(define-public (dpop-proof-encode dpop-proof key) +(define (dpop-proof-encode dpop-proof key) (with-exception-handler (lambda (error) - (raise-cannot-encode-dpop-proof dpop-proof key error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot encode a DPoP proof: ~a") + (exception-message error)) + (format #f (G_ "cannot encode a DPoP proof"))))) + (raise-exception + (make-exception-with-message final-message) + error))) (lambda () (jws-encode dpop-proof key)))) -(define*-public (issue-dpop-proof - client-key - #:key - (alg #f) - (htm #f) - (htu #f) - (access-token #f)) +(define* (issue-dpop-proof + client-key + #:key + (alg #f) + (htm #f) + (htu #f) + (access-token #f)) (dpop-proof-encode - (make-dpop-proof (make-dpop-proof-header alg client-key) - (make-dpop-proof-payload (stubs:random 12) htm htu ((p:current-date)) - (and access-token - (stubs:hash 'SHA-256 access-token)))) + (the-dpop-proof + `(((alg . ,(symbol->string alg)) + (typ . "dpop+jwt") + (jwk . ,client-key)) + . ((jti . ,(stubs:random 12)) + (htm . ,(symbol->string htm)) + (htu . ,(uri->string htu)) + (iat . ,(time-second (date->time-utc ((p:current-date))))) + ,@(if access-token + `((ath . ,(stubs:hash 'SHA-256 access-token))) + '())))) client-key)) diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 1c7d539..4e24659 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -18,1505 +18,36 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (ice-9 exceptions) #:use-module (ice-9 optargs) - #:use-module (ice-9 i18n) + #:use-module (ice-9 match) #:use-module (srfi srfi-19) #:use-module (web uri) #:use-module (web response) - #:use-module (web client)) + #:use-module (web client) + #:declarative? #t + #:export + ( + &message-for-the-user + make-message-for-the-user + message-for-the-user? + user-message -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) + fail + )) -;; This is a collection of all errors that can happen, and a function -;; to log them. - -(define-public ¬-base64 - (make-exception-type - '¬-base64 - &external-error - '(value cause))) - -(define-public (raise-not-base64 value cause) - (raise-exception - ((record-constructor ¬-base64) value cause))) - -(define-public ¬-json - (make-exception-type - '¬-json - &external-error - '(value cause))) - -(define-public (raise-not-json value cause) - (raise-exception - ((record-constructor ¬-json) value cause))) - -(define-public ¬-turtle - (make-exception-type - '¬-turtle - &external-error - '(value cause))) - -(define-public (raise-not-turtle value cause) - (raise-exception - ((record-constructor ¬-turtle) value cause))) - -(define-public &unsupported-crv - (make-exception-type - '&unsupported-crv - &external-error - '(crv))) - -(define-public (raise-unsupported-crv crv) - (raise-exception - ((record-constructor &unsupported-crv) crv))) - -(define-public ¬-a-jwk - (make-exception-type - '¬-a-jwk - &external-error - '(value cause))) - -(define-public (raise-not-a-jwk value cause) - (raise-exception - ((record-constructor ¬-a-jwk) value cause))) - -(define-public ¬-a-public-jwk - (make-exception-type - '¬-a-public-jwk - &external-error - '(value cause))) - -(define-public (raise-not-a-public-jwk value cause) - (raise-exception - ((record-constructor ¬-a-public-jwk) value cause))) - -(define-public ¬-a-private-jwk - (make-exception-type - '¬-a-private-jwk - &external-error - '(value cause))) - -(define-public (raise-not-a-private-jwk value cause) - (raise-exception - ((record-constructor ¬-a-private-jwk) value cause))) - -(define-public ¬-a-jwks - (make-exception-type - '¬-a-jwks - &external-error - '(value cause))) - -(define-public (raise-not-a-jwks value cause) - (raise-exception - ((record-constructor ¬-a-jwks) value cause))) - -(define-public &unsupported-alg - (make-exception-type - '&unsupported-alg - &external-error - '(value))) - -(define-public (raise-unsupported-alg value) - (raise-exception - ((record-constructor &unsupported-alg) value))) - -(define-public &invalid-signature - (make-exception-type - '&invalid-signature - &external-error - '(key payload signature))) - -(define-public (raise-invalid-signature key payload signature) - (raise-exception - ((record-constructor &invalid-signature) key payload signature))) - -(define-public ¬-a-jws-header - (make-exception-type - '¬-a-jws-header - &external-error - '(value cause))) - -(define-public (raise-not-a-jws-header value cause) - (raise-exception - ((record-constructor ¬-a-jws-header) value cause))) - -(define-public ¬-a-jws-payload - (make-exception-type - '¬-a-jws-payload - &external-error - '(value cause))) - -(define-public (raise-not-a-jws-payload value cause) - (raise-exception - ((record-constructor ¬-a-jws-payload) value cause))) - -(define-public ¬-a-jws - (make-exception-type - '¬-a-jws - &external-error - '(value cause))) - -(define-public (raise-not-a-jws value cause) - (raise-exception - ((record-constructor ¬-a-jws-payload) value cause))) - -(define-public ¬-in-3-parts - (make-exception-type - '¬-in-3-parts - &external-error - '(string separator))) - -(define-public (raise-not-in-3-parts string separator) - (raise-exception - ((record-constructor ¬-in-3-parts) string separator))) - -(define-public &missing-alist-key - (make-exception-type - '&missing-alist-key - &external-error - '(value key))) - -(define-public (raise-missing-alist-key value key) - (raise-exception - ((record-constructor &missing-alist-key) value key))) - -(define-public &no-matching-key - (make-exception-type - '&no-matching-key - &external-error - '(candidates alg payload signature other-problems))) - -(define-public (raise-no-matching-key candidates alg payload signature) - (raise-exception - ((record-constructor &no-matching-key) candidates alg payload signature))) - -(define-public &cannot-decode-jws - (make-exception-type - '&cannot-decode-jws - &external-error - '(value cause))) - -(define-public (raise-cannot-decode-jws value cause) - (raise-exception - ((record-constructor &cannot-decode-jws) value cause))) - -(define-public &cannot-encode-jws - (make-exception-type - '&cannot-encode-jws - &external-error - '(jws key cause))) - -(define-public (raise-cannot-encode-jws jws key cause) - (raise-exception - ((record-constructor &cannot-encode-jws) jws key cause))) - -(define-public &request-failed-unexpectedly - (make-exception-type - '&request-failed-unexpectedly - &external-error - '(response-code response-reason-phrase))) - -(define-public (raise-request-failed-unexpectedly - response-code response-reason-phrase) - (raise-exception - ((record-constructor &request-failed-unexpectedly) - response-code response-reason-phrase))) - -(define-public &unexpected-header-value - (make-exception-type - '&unexpected-header-value - &external-error - '(header value))) - -(define-public (raise-unexpected-header-value header value) - (raise-exception - ((record-constructor &unexpected-header-value) header value))) - -(define-public &unexpected-response - (make-exception-type - '&unexpected-response - &external-error - '(response cause))) - -(define-public (raise-unexpected-response response cause) - (raise-exception - ((record-constructor &unexpected-response) response cause))) - -(define-public ¬-an-oidc-configuration - (make-exception-type - '¬-an-oidc-configuration - &external-error - '(value cause))) - -(define-public (raise-not-an-oidc-configuration value cause) - (raise-exception - ((record-constructor ¬-an-oidc-configuration) value cause))) - -(define-public &incorrect-webid-field - (make-exception-type - '&incorrect-webid-field - &external-error - '(value))) - -(define-public (raise-incorrect-webid-field value) - (raise-exception - ((record-constructor &incorrect-webid-field) value))) - -(define-public &incorrect-sub-field - (make-exception-type - '&incorrect-sub-field - &external-error - '(value))) - -(define-public (raise-incorrect-sub-field value) - (raise-exception - ((record-constructor &incorrect-sub-field) value))) - -(define-public &incorrect-iss-field - (make-exception-type - '&incorrect-iss-field - &external-error - '(value))) - -(define-public (raise-incorrect-iss-field value) - (raise-exception - ((record-constructor &incorrect-iss-field) value))) - -(define-public &incorrect-aud-field - (make-exception-type - '&incorrect-aud-field - &external-error - '(value))) - -(define-public (raise-incorrect-aud-field value) - (raise-exception - ((record-constructor &incorrect-aud-field) value))) - -(define-public &incorrect-iat-field - (make-exception-type - '&incorrect-iat-field - &external-error - '(value))) - -(define-public (raise-incorrect-iat-field value) - (raise-exception - ((record-constructor &incorrect-iat-field) value))) - -(define-public &incorrect-exp-field - (make-exception-type - '&incorrect-exp-field - &external-error - '(value))) - -(define-public (raise-incorrect-exp-field value) - (raise-exception - ((record-constructor &incorrect-exp-field) value))) - -(define-public &incorrect-cnf/jkt-field - (make-exception-type - '&incorrect-cnf/jkt-field - &external-error - '(value))) - -(define-public (raise-incorrect-cnf/jkt-field value) - (raise-exception - ((record-constructor &incorrect-cnf/jkt-field) value))) - -(define-public &incorrect-client-id-field - (make-exception-type - '&incorrect-client-id-field - &external-error - '(value))) - -(define-public (raise-incorrect-client-id-field value) - (raise-exception - ((record-constructor &incorrect-client-id-field) value))) - -(define-public &incorrect-redirect-uris-field - (make-exception-type - '&incorrect-redirect-uris-field - &external-error - '(value))) - -(define-public (raise-incorrect-redirect-uris-field value) - (raise-exception - ((record-constructor &incorrect-redirect-uris-field) value))) - -(define-public &incorrect-typ-field - (make-exception-type - '&incorrect-typ-field - &external-error - '(value))) - -(define-public (raise-incorrect-typ-field value) - (raise-exception - ((record-constructor &incorrect-typ-field) value))) - -(define-public &incorrect-jwk-field - (make-exception-type - '&incorrect-jwk-field - &external-error - '(value cause))) - -(define-public (raise-incorrect-jwk-field value cause) - (raise-exception - ((record-constructor &incorrect-jwk-field) value cause))) - -(define-public &incorrect-jti-field - (make-exception-type - '&incorrect-jti-field - &external-error - '(value))) - -(define-public (raise-incorrect-jti-field value) - (raise-exception - ((record-constructor &incorrect-jti-field) value))) - -(define-public &incorrect-nonce-field - (make-exception-type - '&incorrect-nonce-field - &external-error - '(value))) - -(define-public (raise-incorrect-nonce-field value) - (raise-exception - ((record-constructor &incorrect-nonce-field) value))) - -(define-public &incorrect-htm-field - (make-exception-type - '&incorrect-htm-field - &external-error - '(value))) - -(define-public (raise-incorrect-htm-field value) - (raise-exception - ((record-constructor &incorrect-htm-field) value))) - -(define-public &incorrect-htu-field - (make-exception-type - '&incorrect-htu-field - &external-error - '(value))) - -(define-exception-type - &incorrect-ath-field - &external-error - make-incorrect-ath-field - incorrect-ath-field? - (value incorrect-ath-field-value)) - -(export &incorrect-ath-field - make-incorrect-ath-field - incorrect-ath-field? - incorrect-ath-field-value) - -(define-public (raise-incorrect-htu-field value) - (raise-exception - ((record-constructor &incorrect-htu-field) value))) - -(define-public ¬-an-access-token - (make-exception-type - '¬-an-access-token - &external-error - '(value cause))) - -(define-public (raise-not-an-access-token value cause) - (raise-exception - ((record-constructor ¬-an-access-token) value cause))) - -(define-public ¬-an-access-token-header - (make-exception-type - '¬-an-access-token-header - &external-error - '(value cause))) - -(define-public (raise-not-an-access-token-header value cause) - (raise-exception - ((record-constructor ¬-an-access-token-header) value cause))) - -(define-public ¬-an-access-token-payload - (make-exception-type - '¬-an-access-token-payload - &external-error - '(value cause))) - -(define-public (raise-not-an-access-token-payload value cause) - (raise-exception - ((record-constructor ¬-an-access-token-payload) value cause))) - -(define-public ¬-a-dpop-proof - (make-exception-type - '¬-a-dpop-proof - &external-error - '(value cause))) - -(define-public (raise-not-a-dpop-proof value cause) - (raise-exception - ((record-constructor ¬-a-dpop-proof) value cause))) - -(define-public ¬-a-dpop-proof-header - (make-exception-type - '¬-a-dpop-proof-header - &external-error - '(value cause))) - -(define-public (raise-not-a-dpop-proof-header value cause) - (raise-exception - ((record-constructor ¬-a-dpop-proof-header) value cause))) - -(define-public ¬-a-dpop-proof-payload - (make-exception-type - '¬-a-dpop-proof-payload - &external-error - '(value cause))) - -(define-public (raise-not-a-dpop-proof-payload value cause) - (raise-exception - ((record-constructor ¬-a-dpop-proof-payload) value cause))) - -(define-public &cannot-fetch-issuer-configuration - (make-exception-type - '&cannot-fetch-issuer-configuration - &external-error - '(issuer cause))) - -(define*-public (raise-cannot-fetch-issuer-configuration issuer cause #:key (recoverable? #f)) - (raise-exception - ((record-constructor &cannot-fetch-issuer-configuration) issuer cause) - #:continuable? recoverable?)) - -(define-public &cannot-fetch-jwks - (make-exception-type - '&cannot-fetch-jwks - &external-error - '(issuer uri cause))) - -(define-public (raise-cannot-fetch-jwks issuer uri cause) - (raise-exception - ((record-constructor &cannot-fetch-jwks) issuer uri cause))) - -(define-public &dpop-method-mismatch - (make-exception-type - '&dpop-method-mismatch - &external-error - '(signed requested))) - -(define-public (raise-dpop-method-mismatch signed requested) - (raise-exception - ((record-constructor &dpop-method-mismatch) signed requested))) - -(define-public &dpop-uri-mismatch - (make-exception-type - '&dpop-uri-mismatch - &external-error - '(signed requested))) - -(define-public (raise-dpop-uri-mismatch signed requested) - (raise-exception - ((record-constructor &dpop-uri-mismatch) signed requested))) - -(define-public &dpop-signed-in-future - (make-exception-type - '&dpop-signed-in-future - &external-error - '(signed current))) - -(define (the-date object) - (when (integer? object) - (set! object (make-time time-utc 0 object))) - (when (time? object) - (set! object (time-utc->date object))) - object) - -(define-public (raise-dpop-signed-in-future signed current) - (raise-exception - ((record-constructor &dpop-signed-in-future) (the-date signed) (the-date current)))) - -(define-public &dpop-too-old - (make-exception-type - '&dpop-too-old - &external-error - '(signed current))) - -(define-public (raise-dpop-too-old signed current) - (raise-exception - ((record-constructor &dpop-too-old) (the-date signed) (the-date current)))) - -(define-public &dpop-unconfirmed-key - (make-exception-type - '&dpop-unconfirmed-key - &external-error - '(key expected cause))) - -(define-public (raise-dpop-unconfirmed-key key expected cause) - (raise-exception - ((record-constructor &dpop-unconfirmed-key) key expected cause))) +;; A message to show the user is an XHTML paragraph or equivalent (as +;; sxml). A div is used to contain multiple messages. (define-exception-type - &dpop-invalid-access-token-hash + &message-for-the-user &external-error - make-dpop-invalid-access-token-hash - dpop-invalid-access-token-hash? - (hash dpop-invalid-access-token-hash-hash) - (access-token dpop-invalid-access-token-hash-access-token)) - -(export &dpop-invalid-access-token-hash - make-dpop-invalid-access-token-hash - dpop-invalid-access-token-hash? - dpop-invalid-access-token-hash-hash - dpop-invalid-access-token-hash-access-token) - -(define-public &jti-found - (make-exception-type - '&jti-found - &external-error - '(jti cause))) - -(define-public (raise-jti-found jti cause) - (raise-exception - ((record-constructor &jti-found) jti cause))) - -(define-public &cannot-decode-access-token - (make-exception-type - '&cannot-decode-access-token - &external-error - '(value cause))) - -(define-public (raise-cannot-decode-access-token value cause) - (raise-exception - ((record-constructor &cannot-decode-access-token) value cause))) - -(define-public &cannot-encode-access-token - (make-exception-type - '&cannot-encode-access-token - &external-error - '(access-token key cause))) - -(define-public (raise-cannot-encode-access-token access-token key cause) - (raise-exception - ((record-constructor &cannot-encode-access-token) access-token key cause))) - -(define-public &cannot-decode-dpop-proof - (make-exception-type - '&cannot-decode-dpop-proof - &external-error - '(value cause))) - -(define-public (raise-cannot-decode-dpop-proof value cause) - (raise-exception - ((record-constructor &cannot-decode-dpop-proof) value cause))) - -(define-public &cannot-encode-dpop-proof - (make-exception-type - '&cannot-encode-dpop-proof - &external-error - '(dpop-proof key cause))) - -(define-public (raise-cannot-encode-dpop-proof dpop-proof key cause) - (raise-exception - ((record-constructor &cannot-encode-dpop-proof) dpop-proof key cause))) - -(define-public &cannot-fetch-linked-data - (make-exception-type - '&cannot-fetch-linked-data - &external-error - '(uri cause))) - -(define-public (raise-cannot-fetch-linked-data uri cause) - (raise-exception - ((record-constructor &cannot-fetch-linked-data) uri cause))) - -(define-public ¬-a-client-manifest - (make-exception-type - '¬-a-client-manifest - &external-error - '(value cause))) - -(define-public (raise-not-a-client-manifest value cause) - (raise-exception - ((record-constructor ¬-a-client-manifest) value cause))) - -(define-public &unauthorized-redirection-uri - (make-exception-type - '&unauthorized-redirection-uri - &external-error - '(manifest uri))) - -(define-public (raise-unauthorized-redirection-uri manifest uri) - (raise-exception - ((record-constructor &unauthorized-redirection-uri) manifest uri))) - -(define-public &cannot-serve-public-manifest - (make-exception-type - '&cannot-serve-public-manifest - &external-error - '())) - -(define-public (raise-cannot-serve-public-manifest) - (raise-exception - ((record-constructor &cannot-serve-public-manifest)))) - -(define-public &no-client-manifest-registration - (make-exception-type - '&no-client-manifest-registration - &external-error - '(id))) - -(define-public (raise-no-client-manifest-registration id) - (raise-exception - ((record-constructor &no-client-manifest-registration) id))) - -(define-public &inconsistent-client-manifest-id - (make-exception-type - '&inconsistent-client-manifest-id - &external-error - '(id advertised-id))) - -(define-public (raise-inconsistent-client-manifest-id id advertised-id) - (raise-exception - ((record-constructor &inconsistent-client-manifest-id) id advertised-id))) + make-message-for-the-user + message-for-the-user? + (message user-message)) -(define-public &cannot-fetch-client-manifest - (make-exception-type - '&cannot-fetch-client-manifest - &external-error - '(id cause))) - -(define-public (raise-cannot-fetch-client-manifest id cause) - (raise-exception - ((record-constructor &cannot-fetch-client-manifest) id cause))) - -(define-public ¬-an-authorization-code - (make-exception-type - '¬-an-authorization-code - &external-error - '(value cause))) - -(define-public (raise-not-an-authorization-code value cause) - (raise-exception - ((record-constructor ¬-an-authorization-code) value cause))) - -(define-public ¬-an-authorization-code-header - (make-exception-type - '¬-an-authorization-code-header - &external-error - '(value cause))) - -(define-public (raise-not-an-authorization-code-header value cause) - (raise-exception - ((record-constructor ¬-an-authorization-code-header) value cause))) - -(define-public ¬-an-authorization-code-payload - (make-exception-type - '¬-an-authorization-code-payload - &external-error - '(value cause))) - -(define-public (raise-not-an-authorization-code-payload value cause) - (raise-exception - ((record-constructor ¬-an-authorization-code-payload) value cause))) - -(define-public &authorization-code-expired - (make-exception-type - '&authorization-code-expired - &external-error - '(exp current-time))) - -(define-public (raise-authorization-code-expired exp current-time) - (raise-exception - ((record-constructor &authorization-code-expired) - (the-date exp) - (the-date current-time)))) - -(define-public &cannot-decode-authorization-code - (make-exception-type - '&cannot-decode-authorization-code - &external-error - '(value cause))) - -(define-public (raise-cannot-decode-authorization-code value cause) - (raise-exception - ((record-constructor &cannot-decode-authorization-code) value cause))) - -(define-public &cannot-encode-authorization-code - (make-exception-type - '&cannot-encode-authorization-code - &external-error - '(authorization-code key cause))) - -(define-public (raise-cannot-encode-authorization-code authorization-code key cause) +(define (fail message) + ;; Like error, but don’t do funny things when message is not a + ;; string literal (raise-exception - ((record-constructor &cannot-encode-authorization-code) authorization-code key cause))) - -(define-public &invalid-refresh-token - (make-exception-type - '&invalid-refresh-token - &external-error - '(refresh-token))) - -(define-public (raise-invalid-refresh-token refresh-token) - (raise-exception - ((record-constructor &invalid-refresh-token) refresh-token))) - -(define-public &invalid-key-for-refresh-token - (make-exception-type - '&invalid-key-for-refresh-token - &external-error - '(key jkt))) - -(define-public (raise-invalid-key-for-refresh-token key jkt) - (raise-exception - ((record-constructor &invalid-key-for-refresh-token) key jkt))) - -(define-public ¬-an-id-token - (make-exception-type - '¬-an-id-token - &external-error - '(value cause))) - -(define-public (raise-not-an-id-token value cause) - (raise-exception - ((record-constructor ¬-an-id-token) value cause))) - -(define-public ¬-an-id-token-header - (make-exception-type - '¬-an-id-token-header - &external-error - '(value cause))) - -(define-public (raise-not-an-id-token-header value cause) - (raise-exception - ((record-constructor ¬-an-id-token-header) value cause))) - -(define-public ¬-an-id-token-payload - (make-exception-type - '¬-an-id-token-payload - &external-error - '(value cause))) - -(define-public (raise-not-an-id-token-payload value cause) - (raise-exception - ((record-constructor ¬-an-id-token-payload) value cause))) - -(define-public &cannot-decode-id-token - (make-exception-type - '&cannot-decode-id-token - &external-error - '(value cause))) - -(define-public (raise-cannot-decode-id-token value cause) - (raise-exception - ((record-constructor &cannot-decode-id-token) value cause))) - -(define-public &cannot-encode-id-token - (make-exception-type - '&cannot-encode-id-token - &external-error - '(id-token key cause))) - -(define-public (raise-cannot-encode-id-token id-token key cause) - (raise-exception - ((record-constructor &cannot-encode-id-token) id-token key cause))) - -(define-public &unknown-client-locale - (make-exception-type - '&unknown-client-locale - &external-error - '(web-locale c-locale))) - -(define-public (raise-unknown-client-locale web-locale c-locale) - (raise-exception - ((record-constructor &unknown-client-locale) web-locale c-locale) - #:continuable? #t)) - -(define-public &unsupported-grant-type - (make-exception-type - '&unsupported-grant-type - &external-error - '(value))) - -(define-public (raise-unsupported-grant-type value) - (raise-exception - ((record-constructor &unsupported-grant-type) value))) - -(define-public &no-authorization-code - (make-exception-type - '&no-authorization-code - &external-error - '(value))) - -(define-public (raise-no-authorization-code) - (raise-exception - ((record-constructor &no-authorization-code)))) - -(define-public &no-refresh-token - (make-exception-type - '&no-refresh-token - &external-error - '(value))) - -(define-public (raise-no-refresh-token) - (raise-exception - ((record-constructor &no-refresh-token)))) - -(define-public &unconfirmed-provider - (make-exception-type - '&unconfirmed-provider - &external-error - '(subject provider))) - -(define-public (raise-unconfirmed-provider subject provider) - (raise-exception - ((record-constructor &unconfirmed-provider) subject provider))) - -(define-public &neither-identity-provider-nor-webid - (make-exception-type - '&neither-identity-provider-nor-webid - &external-error - '(uri why-not-identity-provider why-not-webid))) - -(define-public (raise-neither-identity-provider-nor-webid uri why-not-identity-provider why-not-webid) - (raise-exception - ((record-constructor &neither-identity-provider-nor-webid) - uri why-not-identity-provider why-not-webid))) - -(define-public &profile-not-found - (make-exception-type - '&profile-not-found - &external-error - '(webid iss dir))) - -(define-public (raise-profile-not-found webid iss dir) - (raise-exception - ((record-constructor &profile-not-found) webid iss dir))) - -(define-public &no-provider-candidates - (make-exception-type - '&no-provider-candidates - &external-error - '(webid causes))) - -(define-public (raise-no-provider-candidates webid causes) - (raise-exception - ((record-constructor &no-provider-candidates) webid causes))) - -;; Server-side exceptions - -(define-exception-type - &path-not-found - &external-error - make-path-not-found - path-not-found? - (path path-not-found-path)) - -(export &path-not-found - make-path-not-found - path-not-found? - path-not-found-path) - -(define-exception-type - &auxiliary-resource-absent - &external-error - make-auxiliary-resource-absent - auxiliary-resource-absent? - (path auxiliary-resource-absent-path) - (kind auxiliary-resource-absent-kind)) - -(export &auxiliary-resource-absent - make-auxiliary-resource-absent - auxiliary-resource-absent? - auxiliary-resource-absent-path - auxiliary-resource-absent-kind) - -(define-exception-type - &uri-slash-semantics-error - &external-error - make-uri-slash-semantics-error - uri-slash-semantics-error? - (path uri-slash-semantics-error-path) - (expected-path uri-slash-semantics-error-expected-path)) - -(export &uri-slash-semantics-error - make-uri-slash-semantics-error - uri-slash-semantics-error? - uri-slash-semantics-error-path - uri-slash-semantics-error-expected-path) - -(define-exception-type - &cannot-delete-root - &external-error - make-cannot-delete-root - cannot-delete-root?) - -(export &cannot-delete-root - make-cannot-delete-root - cannot-delete-root?) - -(define-exception-type - &container-not-empty - &external-error - make-container-not-empty - container-not-empty? - (path container-not-empty-path)) - -(export &container-not-empty - make-container-not-empty - container-not-empty? - container-not-empty-path) - -(define-exception-type - &cannot-fetch-group - &warning - make-cannot-fetch-group - cannot-fetch-group? - (group-uri cannot-fetch-group-group-uri) - (cause cannot-fetch-group-cause)) - -(export &cannot-fetch-group - make-cannot-fetch-group - cannot-fetch-group? - cannot-fetch-group-group-uri - cannot-fetch-group-cause) - -(define-exception-type - &incorrect-containment-triples - &external-error - make-incorrect-containment-triples - incorrect-containment-triples? - (path incorrect-containment-triples-path)) - -(export &incorrect-containment-triples - make-incorrect-containment-triples - incorrect-containment-triples? - incorrect-containment-triples-path) - -(define-exception-type - &unsupported-media-type - &external-error - make-unsupported-media-type - unsupported-media-type? - (content-type unsupported-media-type-content-type)) - -(export &unsupported-media-type - make-unsupported-media-type - unsupported-media-type? - unsupported-media-type-content-type) - -(define-exception-type - &path-is-auxiliary - &external-error - make-path-is-auxiliary - path-is-auxiliary? - (path path-is-auxiliary-path)) - -(export &path-is-auxiliary - make-path-is-auxiliary - path-is-auxiliary? - path-is-auxiliary-path) - -(define-exception-type - &forbidden - &external-error - make-forbidden - forbidden? - (path forbidden-path) - (user forbidden-user) - (owner forbidden-owner) - (mode forbidden-mode)) - -(export &forbidden - make-forbidden - forbidden? - forbidden-path - forbidden-user - forbidden-owner - forbidden-mode) - -(define-exception-type - &precondition-failed - &external-error - make-precondition-failed - precondition-failed? - (path precondition-failed-path) - (if-match precondition-failed-if-match) - (if-none-match precondition-failed-if-none-match) - (real-etag precondition-failed-real-etag)) - -(export &precondition-failed - make-precondition-failed - precondition-failed? - precondition-failed-path - precondition-failed-if-match - precondition-failed-if-none-match - precondition-failed-real-etag) - -(define-exception-type - ¬-acceptable - &external-error - make-not-acceptable - not-acceptable? - (client-accepts not-acceptable-client-accepts) - (path not-acceptable-path) - (content-type not-acceptable-content-type)) - -(export ¬-acceptable - make-not-acceptable - not-acceptable? - not-acceptable-client-accepts - not-acceptable-path - not-acceptable-content-type) - -(define*-public (error->str err #:key (max-depth #f)) - (if (record? err) - (let* ((type (record-type-descriptor err)) - (get - (lambda (slot) - ((record-accessor type slot) err))) - (recurse - (if (eqv? max-depth 0) - (lambda (err) (G_ "that’s how it is")) - (lambda (err) - (error->str err #:max-depth (and max-depth (- max-depth 1))))))) - (case (record-type-name type) - ((¬-base64) - (format #f (G_ "the value ~s is not a base64 string (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-json) - (format #f (G_ "the value ~s is not JSON (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-turtle) - (format #f (G_ "the value ~s is not Turtle (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&unsupported-crv) - (format #f (G_ "the value ~s does not identify an elleptic curve") - (get 'crv))) - ((¬-a-jwk) - (let ((cause (get 'cause))) - (if cause - (format #f (G_ "the value ~s does not identify a JWK (because ~a)") - (get 'value) (recurse cause)) - (format #f (G_ "the value ~s does not identify a JWK") - (get 'value))))) - ((¬-a-public-jwk) - (let ((cause (get 'cause))) - (if cause - (format #f (G_ "the value ~s does not identify a public JWK (because ~a)") - (get 'value) (recurse cause)) - (format #f (G_ "the value ~s does not identify a public JWK") - (get 'value))))) - ((¬-a-private-jwk) - (let ((cause (get 'cause))) - (if cause - (format #f (G_ "the value ~s does not identify a private JWK (because ~a)") - (get 'value) cause) - (format #f (G_ "the value ~s does not identify a private JWK") - (get 'value))))) - ((¬-a-jwks) - (let ((cause (get 'cause))) - (if cause - (format #f (G_ "the value ~s does not identify a JWKS (because ~a)") - (get 'value) (recurse cause)) - (format #f (G_ "the value ~s does not identify a JWKS") - (get 'value))))) - ((&unsupported-alg) - (format #f (G_ "the value ~s does not identify a hash algorithm") - (get 'value))) - ((&missing-alist-key) - (format #f (G_ "the value ~s is not an alist or misses key ~s") - (get 'value) (get 'key))) - ((¬-a-jws-header) - (format #f (G_ "the value ~s is not a JWS header (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-a-jws-payload) - (format #f (G_ "the value ~s is not a JWS payload (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-a-jws) - (format #f (G_ "the value ~s is not a JWS (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-in-3-parts) - (format #f (G_ "the string ~s cannot be split in 3 parts with ~s") - (get 'string) (get 'separator))) - ((&no-matching-key) - (format #f (G_ "all key candidates failed to verify signature ~s with algorithm ~s and payload ~a (there were ~a: ~s)") - (get 'signature) (get 'alg) (get 'payload) (length (get 'candidates)) (get 'candidates))) - ((&cannot-decode-jws) - (format #f (G_ "I cannot decode JWS ~a (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-encode-jws) - (format #f (G_ "I cannot encode JWS ~a (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&response-failed-unexpectedly) - (format #f (G_ "the server request unexpectedly failed with code ~a and reason phrase ~s") - (get 'response-code) (get 'response-reason-phrase))) - ((&unexpected-header-value) - (let ((value (get 'value))) - (if value - (format #f (G_ "the header ~a should not have the value ~s") - (get 'header) value) - (format #f (G_ "the header ~a should be present") - (get 'header))))) - ((&unexpected-response) - (format #f (G_ "the server response wasn't expected: ~s (because ~a)") - (call-with-output-string - (lambda (port) - (write-response (get 'response) port))) - (recurse (get 'cause)))) - ((¬-an-oidc-configuration) - (format #f (G_ "the value ~s is not an OIDC configuration (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&incorrect-webid-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the webid field is incorrect: ~s") value) - (format #f (G_ "the webid field is missing"))))) - ((&incorrect-sub-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the sub field is incorrect: ~s") value) - (format #f (G_ "the sub field is missing"))))) - ((&incorrect-iss-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the iss field is incorrect: ~s") value) - (format #f (G_ "the iss field is missing"))))) - ((&incorrect-aud-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the aud field is incorrect: ~s") value) - (format #f (G_ "the aud field is missing"))))) - ((&incorrect-iat-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the iat field is incorrect: ~s") value) - (format #f (G_ "the iat field is missing"))))) - ((&incorrect-exp-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the exp field is incorrect: ~s") value) - (format #f (G_ "the exp field is missing"))))) - ((&incorrect-cnf/jkt-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the cnf/jkt field is incorrect: ~s") value) - (format #f (G_ "the cnf/jkt field is missing"))))) - ((&incorrect-client-id-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the client-id field is incorrect: ~s") value) - (format #f (G_ "the client-id field is missing"))))) - ((&incorrect-redirect-uris-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the redirect_uris field is incorrect: ~s") value) - (format #f (G_ "the redirect_uris field is missing"))))) - ((&incorrect-typ-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the typ field is incorrect: ~s") value) - (format #f (G_ "the typ field is missing"))))) - ((&incorrect-jwk-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the jwk field is incorrect: ~s (because ~a)") - value (recurse (get 'cause))) - (format #f (G_ "the jwk field is missing"))))) - ((&incorrect-jti-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the jti field is incorrect: ~s") value) - (format #f (G_ "the jti field is missing"))))) - ((&incorrect-nonce-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the nonce field is incorrect: ~s") value) - (format #f (G_ "the nonce field is missing"))))) - ((&incorrect-htm-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the htm field is incorrect: ~s") value) - (format #f (G_ "the htm field is missing"))))) - ((&incorrect-htu-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the htu field is incorrect: ~s") value) - (format #f (G_ "the htu field is missing"))))) - ((&incorrect-ath-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the ath field is incorrect: ~s") value) - (format #f (G_ "the ath field is missing"))))) - ((¬-an-access-token) - (format #f (G_ "~s is not an access token (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-access-token-header) - (format #f (G_ "~s is not an access token header (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-access-token-payload) - (format #f (G_ "~s is not an access token payload (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-a-dpop-proof) - (format #f (G_ "~s is not a DPoP proof (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-a-dpop-proof-header) - (format #f (G_ "~s is not a DPoP proof header (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-a-dpop-proof-payload) - (format #f (G_ "~s is not a DPoP proof payload (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-fetch-issuer-configuration) - (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)") - (let ((iss (get 'issuer))) - (when (uri? iss) - (set! iss (uri->string iss))) - iss) - (recurse (get 'cause)))) - ((&cannot-fetch-jwks) - (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)") - (let ((iss (get 'issuer))) - (when (uri? iss) - (set! iss (uri->string iss))) - iss) - (let ((uri (get 'uri))) - (when (uri? uri) - (set! uri (uri->string uri))) - uri) - (recurse (get 'cause)))) - ((&dpop-method-mismatch) - (format #f (G_ "the HTTP method is signed for ~s, but ~s was requested") - (get 'signed) (get 'requested))) - ((&dpop-uri-mismatch) - (format #f (G_ "the HTTP uri is signed for ~a, but ~a was requested") - (uri->string (get 'signed)) (uri->string (get 'requested)))) - ((&dpop-signed-in-future) - (format #f (G_ "the date is ~a, but the DPoP proof is signed in the future at ~a") - (time-second (date->time-utc (get 'current))) - (time-second (date->time-utc (get 'signed))))) - ((&dpop-too-old) - (format #f (G_ "the date is ~a, but the DPoP proof was signed too long ago at ~a") - (time-second (date->time-utc (get 'current))) - (time-second (date->time-utc (get 'signed))))) - ((&dpop-unconfirmed-key) - (let ((key (get 'key)) - (expected (get 'expected)) - (cause (get 'cause))) - (cond - (expected - (format #f (G_ "the key ~s does not hash to ~a") key expected)) - (cause - (format #f (G_ "the key confirmation of ~s failed (because ~a)") key (recurse cause))) - (else - (format #f (G_ "the key confirmation of ~s failed") key))))) - ((&dpop-invalid-access-token-hash) - (let ((h (get 'hash)) - (at (get 'access-token))) - (if h - (format #f (G_ "the DPoP proof is bound to an access token with hash ~s, not ~s") - h at) - (format #f (G_ "the DPoP proof should be bound to the access token ~s") - at)))) - ((&jti-found) - (format #f (G_ "the jti ~s has already been found (because ~a)") - (get 'jti) (recurse (get 'cause)))) - ((&cannot-decode-access-token) - (format #f (G_ "I cannot decode ~s as an access token (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-encode-access-token) - (format #f (G_ "I cannot encode ~s as an access token with key ~s (because ~a)") - (get 'access-token) (get 'key) (recurse (get 'cause)))) - ((&cannot-decode-dpop-proof) - (format #f (G_ "I cannot decode ~s as a DPoP proof (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-encode-dpop-proof) - (format #f (G_ "I cannot encode ~s as a DPoP proof (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-fetch-linked-data) - (format #f (G_ "I could not fetch a RDF graph at ~a (because ~a)") - (uri->string (get 'uri)) (recurse (get 'cause)))) - ((¬-a-client-manifest) - (format #f (G_ "~s is not a client manifest (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&unauthorized-redirection-uri) - (format #f (G_ "~s does not authorize redirection URI ~a") - (get 'manifest) (uri->string (get 'uri)))) - ((&cannot-serve-public-manifest) - (format #f (G_ "I cannot serve a public manifest"))) - ((&no-client-manifest-registration) - (format #f (G_ "~a does not have a client manifest registration triple") - (uri->string (get 'id)))) - ((&inconsistent-client-manifest-id) - (format #f (G_ "the client manifest at ~a is advertised for ~a") - (uri->string (get 'id)) (uri->string (get 'advertised-id)))) - ((&cannot-fetch-client-manifest) - (format #f (G_ "I could not fetch the client manifest of ~a (because ~a)") - (uri->string (get 'id)) (recurse (get 'cause)))) - ((¬-an-authorization-code) - (format #f (G_ "~s is not an authorization code (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-authorization-code-header) - (format #f (G_ "~s is not an authorization code header (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-authorization-code-payload) - (format #f (G_ "~s is not an authorization code payload (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&authorization-code-expired) - (format #f (G_ "the current time is ~a, and the authorization code expired at ~a") - (time-second (date->time-utc (get 'current-time))) - (time-second (date->time-utc (get 'exp))))) - ((&cannot-decode-authorization-code) - (format #f (G_ "I cannot decode ~s as an authorization code (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-encode-authorization-code) - (format #f (G_ "I cannot encode ~s as an authorization code (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&invalid-refresh-token) - (format #f (G_ "there is no such refresh token as ~s") - (get 'refresh-token))) - ((&invalid-key-for-refresh-token) - (format #f (G_ "the refresh token is bound to a key confirmed as ~s, but it is used with key ~s") - (get 'jkt) (get 'key))) - ((&cannot-decode-id-token) - (format #f (G_ "I cannot decode ~s as an ID token (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-encode-id-token) - (format #f (G_ "I cannot encode ~s as an ID token (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&unsupported-grant-type) - (format #f (G_ "the grant type ~s is not supported") - (get 'value))) - ((&no-authorization-code) - (format #f (G_ "there is no authorization code in the request"))) - ((&no-refresh-token) - (format #f (G_ "there is no refresh token in the request"))) - ((¬-an-id-token) - (format #f (G_ "~s is not an ID token (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-id-token-header) - (format #f (G_ "~s is not an ID token header (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-id-token-payload) - (format #f (G_ "~s is not an ID token payload (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&unknown-client-locale) - (format #f (G_ "I couldn’t set the locale to ~s as an approximation of the client locale ~s") - (get 'c-locale) (get 'web-locale))) - ((&unconfirmed-provider) - (format #f (G_ "~s does not admit ~s as an identity provider") - (get 'subject) (get 'provider))) - ((&neither-identity-provider-nor-webid) - (format #f (G_ "~a is neither an identity provider (because ~a) nor a webid (because ~a)") - (uri->string (get 'uri)) - (recurse (get 'why-not-identity-provider)) - (recurse (get 'why-not-webid)))) - ((&profile-not-found) - (format #f (G_ "you don’t have a refresh token for identity ~a certified by ~a in ~s") - (uri->string (get 'webid)) - (uri->string (get 'iss)) - (get 'dir))) - ((&no-provider-candidates) - (format #f (G_ "all identity provider candidates for ~a failed: ~a") - (uri->string (get 'webid)) - (string-join - (map (lambda (cause) - (format #f (G_ "~s failed (because ~a)") - (uri->string (car cause)) (recurse (cdr cause)))) - (get 'causes)) - (G_ ", ")))) - ((&path-not-found) - (format #f (G_ "no resource has been found to serve URI path ~s") - (get 'path))) - ((&auxiliary-resource-absent) - (format #f (G_ "the resource kind ~s is absent for the resource at ~s") - (get 'kind') (get 'path))) - ((&uri-slash-semantics-error) - (format #f (G_ "no resource has been found to serve URI path ~s, but ~s exists") - (get 'path) (get 'expected-path))) - ((&cannot-delete-root) - (format #f (G_ "the root storage cannot be deleted"))) - ((&container-not-empty) - (format #f (G_ "the container ~s should be emptied before being deleted") - (get 'path))) - ((&cannot-fetch-group) - (format #f (G_ "the group ~s cannot be fetched (because ~a)") - (uri->string (get 'group-uri)) - (recurse (get 'cause)))) - ((&incorrect-containment-triples) - (format #f (G_ "the containment triples in the request to update ~s are not up to date") - (get 'path))) - ((&unsupported-media-type) - (format #f (G_ "the server cannot process resources with the ~s content-type") - (get 'content-type))) - ((&path-is-auxiliary) - (format #f (G_ "the client wants to create a resource at ~s, which is reserved for an auxiliary resource") - (get 'path))) - ((&forbidden) - (format #f (G_ "the operation on ~s by ~a is refused, because it’s not by ~s and the access control forbids the following mode of operation: ~s") - (get 'path) - (if (get 'user) - (uri->string (get 'user)) - (G_ "an anonymous user")) - (uri->string (get 'owner)) - (uri->string (get 'mode)))) - ((&precondition-failed) - (if (get 'real-etag) - (format #f (G_ "the client precondition failed for ~s: it allows for ~s, forbids ~s, but the resource has a representation of ~s") - (get 'path) (get 'if-match) (get 'if-none-match) (get 'real-etag)) - (format #f (G_ "the client precondition failed for ~s: it allows for ~s, forbids ~s, but the resource has no representation") - (get 'path) (get 'if-match) (get 'if-none-match)))) - ((¬-acceptable) - (format #f (G_ "the client wanted a response with a content type among ~s, but the resource at ~s has content-type ~s which cannot be converted to one of them") - (get 'client-accepts) - (get 'path) - (get 'content-type))) - ((&compound-exception) - (let ((components (get 'components))) - (if (null? components) - (G_ "that’s it") - (if (null? (cdr components)) - (recurse (car components)) - (if (null? (cddr components)) - (format #f (G_ "~a and ~a") - (recurse (car components)) - (recurse (cadr components))) - (format #f (G_ "~a, ~a") - (recurse (car components)) - (recurse (apply make-exception (cdr components))))))))) - ((&invalid-signature) - (format #f (G_ "the signature ~a does not match key ~s with payload ~a") - (get 'signature) (get 'key) (get 'payload))) - ((&request-failed-unexpectedly) - (format #f (G_ "the request failed unexpectedly with code ~a: ~s") - (get 'response-code) - (get 'response-reason-phrase))) - ((&undefined-variable) - (G_ "there is an undefined variable")) - ((&origin) - (format #f (G_ "the origin is ~a") - (exception-origin err))) - ((&message) - (format #f (G_ "a message is attached: ~a") - (exception-message err))) - ((&irritants) - (format #f (G_ "the values ~s are problematic") - (exception-irritants err))) - ((&exception-with-kind-and-args) - (format #f (G_ "there is a kind (~s) and args ~s") - (get 'kind) (get 'args))) - ((&assertion-failure) - (format #f (G_ "there is an assertion failure"))) - ((&quit-exception) - (format #f (G_ "the program quits with code ~a") - (get 'code))) - ((&non-continuable) - (format #f (G_ "the program cannot recover from this exception"))) - ((&external-error) - (format #f (G_ "there is an external error"))) - ((&error) - (format #f (G_ "there is an error"))) - (else - (format #f (G_ "there is an unknown exception of kind ~s") - (record-type-name type))))) - (format #f "~a" err))) + (make-exception + (make-error) + (make-exception-with-message message)))) diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm index d6ef2a0..24c4d8a 100644 --- a/src/scm/webid-oidc/example-app.scm +++ b/src/scm/webid-oidc/example-app.scm @@ -17,9 +17,9 @@ (define-module (webid-oidc example-app) #:use-module ((webid-oidc client) #:prefix client:) #:use-module ((webid-oidc client accounts) #:prefix client:) - #:use-module (webid-oidc errors) #:use-module ((webid-oidc cache) #:prefix cache:) #:use-module (webid-oidc dpop-proof) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc config) #:prefix cfg:) @@ -32,7 +32,6 @@ #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (srfi srfi-19) - #:use-module (ice-9 i18n) #:use-module (srfi srfi-26) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) @@ -40,14 +39,8 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (sxml simple) - #:use-module (rnrs bytevectors)) - -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) + #:use-module (rnrs bytevectors) + #:declarative? #t) (define (main) (define (do-the-trick subject issuer) diff --git a/src/scm/webid-oidc/fetch.scm b/src/scm/webid-oidc/fetch.scm index c027787..dfc5406 100644 --- a/src/scm/webid-oidc/fetch.scm +++ b/src/scm/webid-oidc/fetch.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -15,9 +15,10 @@ ;; along with this program. If not, see <https://www.gnu.org/licenses/>. (define-module (webid-oidc fetch) - #:use-module (webid-oidc errors) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) #:use-module (rnrs bytevectors) #:use-module (web client) #:use-module (web request) @@ -27,51 +28,88 @@ #:use-module (turtle tordf) #:use-module (nquads tordf) #:use-module (json) - #:use-module (jsonld)) + #:use-module (jsonld) + #:declarative? #t + #:export + ( -(define*-public (fetch uri #:key (http-get http-get)) + &cannot-fetch-linked-data + make-cannot-fetch-linked-data + cannot-fetch-linked-data? + cannot-fetch-linked-data-uri + + fetch + )) + +(define-exception-type + &cannot-fetch-linked-data + &external-error + make-cannot-fetch-linked-data + cannot-fetch-linked-data? + (uri cannot-fetch-linked-data-uri)) + +(define* (fetch uri #:key (http-get http-get)) (unless (uri? uri) (set! uri (string->uri uri))) (with-exception-handler (lambda (error) - (raise-cannot-fetch-linked-data uri error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot fetch ~s as linked data: ~a") + (exception-message error)) + (format #f (G_ "cannot fetch ~s as linked data"))))) + (raise-exception + (make-exception + (make-cannot-fetch-linked-data uri) + (make-exception-with-message final-message) + error)))) (lambda () (receive (response response-body) (http-get uri #:headers `((accept (text/turtle application/n-quads application/ld+json)))) (with-exception-handler (lambda (error) - (raise-unexpected-response response error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "unexpected response from the server: ~a") + (exception-message error)) + (format #f (G_ "unexpected response from the server"))))) + (raise-exception + (make-exception + (make-exception-with-message final-message))))) (lambda () (unless (eqv? (response-code response) 200) - (raise-request-failed-unexpectedly (response-code response) - (response-reason-phrase response))) + (let ((final-message + (format #f (G_ "the request failed unexpectedly with ~s ~s") + (response-code response) + (response-reason-phrase response)))) + (raise-exception + (make-exception + (make-exception-with-message final-message))))) (let ((content-type (response-content-type response))) - (unless (and content-type - (or - (eq? (car content-type) 'text/turtle) - (eq? (car content-type) 'application/n-quads) - (eq? (car content-type) 'text/x-nquads) - (eq? (car content-type) 'application/ld+json)) - (or (not (assq-ref (cdr content-type) 'charset)) - (equal? (assq-ref (cdr content-type) 'charset) "utf-8"))) - (raise-unexpected-header-value 'content-type content-type)) - (when (bytevector? response-body) - (set! response-body (utf8->string response-body))) - (with-exception-handler - (lambda (rdf-error) - (raise-not-turtle response-body rdf-error)) - (lambda () - (case (car content-type) - ((text/turtle) - (turtle->rdf (string-append - "# This is not a file name\n" - response-body) - (uri->string uri))) - ((application/ld+json) - (rdf-dataset-default-graph - (jsonld->rdf (json-string->scm response-body)))) - ((application/n-quads text/x-nquads) - (nquads->rdf (string-append - "# This is not a file name\n" - response-body))))))))))))) + (define (as-text!) + (when (bytevector? response-body) + (set! response-body + (utf8->string response-body)))) + (match content-type + (('text/turtle . _) + (as-text!) + (turtle->rdf (string-append + "# This is not a file name\n" + response-body) + (uri->string uri))) + ((or ('application/n-quads . _) + ('text/x-nquads . _)) + (nquads->rdf (string-append + "# This is not a file name\n" + response-body))) + (('application/ld+json . _) + (rdf-dataset-default-graph + (jsonld->rdf (json-string->scm response-body)))) + (else + (let ((final-message + (format #f (G_ "cannot negociate a recognized RFD content type, got ~s") + content-type))) + (raise-exception + (make-exception + (make-exception-with-message final-message))))))))))))) diff --git a/src/scm/webid-oidc/hello-world.scm b/src/scm/webid-oidc/hello-world.scm index d752aae..45e0657 100644 --- a/src/scm/webid-oidc/hello-world.scm +++ b/src/scm/webid-oidc/hello-world.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluis, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -17,6 +17,7 @@ (define-module (webid-oidc hello-world) #:use-module (webid-oidc resource-server) #:use-module (webid-oidc server log) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (web request) #:use-module (web response) @@ -28,14 +29,28 @@ #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) #:use-module (sxml simple) - #:use-module (srfi srfi-19)) + #:use-module (sxml match) + #:use-module (srfi srfi-19) + #:declarative? #t) -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) +(define (hello-page id) + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(sxml-match + (xml->sxml + (W_ (format #f (W_ "<h1>Hello, ~a!</h1>") + (uri->string id)) + (sxml->xml + `(a (@ (href ,(uri->string id))) + ,(uri->string id))))) + ((*TOP* ,title) title)) + ,(sxml-match + (xml->sxml + (W_ (format #f (W_ "<p>The client is compatible with Solid.</p>")))) + ((*TOP* ,p) p)))))) (define-public (main) (setvbuf (current-output-port) 'none) @@ -126,48 +141,56 @@ Options: (prepare-log-file log-file)) (when error-file (prepare-error-file error-file)) - (if (eq? (request-method request) 'GET) - (let ((agent (assoc-ref (request-headers request) 'xxx-agent))) - (if (and agent (string->uri agent)) - (values - (build-response - #:headers `((content-type application/xhtml+xml) - (source . ,means-string))) - (with-output-to-string - (lambda () - (sxml->xml - `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang "en")) - (body - (h1 "Hello, " - (a (@ (href ,(uri->string (string->uri agent)))) - ,(uri->string (string->uri agent))) "!")))))))) - (values - (build-response #:code 401 - #:reason-phrase "Unauthorized" - #:headers `((content-type application/xhtml+xml) - (source . ,means-string))) - (with-output-to-string - (lambda () - (sxml->xml - `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang "en")) - (body - (h1 "Please authenticate!")))))))))) - (values - (build-response #:code 405 - #:reason-phrase "Method Not Allowed" - #:headers `((content-type application/xhtml+xml) - (source . ,means-string))) - (with-output-to-string - (lambda () - (sxml->xml - `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang "en")) - (body - (h1 "Please issue a GET request.")))))))))))) + (parameterize ((web-locale request)) + (if (eq? (request-method request) 'GET) + (let ((agent (assoc-ref (request-headers request) 'xxx-agent))) + (if (and agent (string->uri agent)) + (values + (build-response + #:headers `((content-type application/xhtml+xml) + (source . ,means-string))) + (with-output-to-string + (lambda () + (sxml->xml (hello-page agent))))) + (values + (build-response #:code 401 + #:reason-phrase (W_ "reason-phrase|Unauthorized") + #:headers `((content-type application/xhtml+xml) + (source . ,means-string))) + (with-output-to-string + (lambda () + (sxml->xml + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(sxml-match + (xml->sxml + (W_ (format #f "<h1>Please authenticate</h1>"))) + ((*TOP* ,title) title)) + ,(sxml-match + (xml->sxml + (W_ (format #f "<p>This page requires authentication with Solid.</p>"))) + ((*TOP* ,p) p))))))))))) + (values + (build-response #:code 405 + #:reason-phrase (W_ "reason-phrase|Method Not Allowed") + #:headers `((content-type application/xhtml+xml) + (source . ,means-string))) + (with-output-to-string + (lambda () + (sxml->xml + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(sxml-match + (xml->sxml + (W_ (format #f "<h1>Method not allowed</h1>"))) + ((*TOP* ,title) title)) + ,(sxml-match + (xml->sxml + (W_ (format #f "<p>You can only use the <emph>GET</emph> method on this resource.</p>"))) + ((*TOP* ,p) p)))))))))))))) (install-suspendable-ports!) (run-server handler 'http (list #:port (string->number port-string)))))))))) diff --git a/src/scm/webid-oidc/http-link.scm b/src/scm/webid-oidc/http-link.scm index 64efc07..f8a239a 100644 --- a/src/scm/webid-oidc/http-link.scm +++ b/src/scm/webid-oidc/http-link.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -23,6 +23,7 @@ #:use-module (web request) #:use-module (web response) #:use-module (web http) + #:declarative? #t #:export ( diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm index e22f1ef..7f1fb48 100644 --- a/src/scm/webid-oidc/identity-provider.scm +++ b/src/scm/webid-oidc/identity-provider.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -22,6 +22,7 @@ #:use-module (webid-oidc jwk) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (webid-oidc jti) #:use-module (web request) #:use-module (web response) @@ -31,34 +32,37 @@ #:use-module (webid-oidc cache) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) - #:use-module (ice-9 i18n) + #:use-module (webid-oidc web-i18n) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) #:use-module (sxml simple) + #:use-module (sxml match) #:use-module (srfi srfi-19) - #:use-module (rnrs bytevectors)) + #:use-module (rnrs bytevectors) + #:declarative? #t + #:export + ( -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) + make-identity-provider + + )) (define* (same-uri? a b #:key (skip-query #f)) (and (equal? (uri-path a) (uri-path b)) (or skip-query (equal? (uri-query a) (uri-query b))))) -(define*-public (make-identity-provider - issuer - key-file - subject - encrypted-password - jwks-uri - authorization-endpoint-uri - token-endpoint-uri - #:key - (http-get http-get)) +(define* (make-identity-provider + issuer + key-file + subject + encrypted-password + jwks-uri + authorization-endpoint-uri + token-endpoint-uri + #:key + (http-get http-get)) (let ((key (catch #t (lambda () @@ -82,55 +86,63 @@ (token-endpoint (make-token-endpoint token-endpoint-uri issuer alg key 3600)) (openid-configuration - (make-oidc-configuration jwks-uri - authorization-endpoint-uri - token-endpoint-uri)) + `((jwks_uri . ,(uri->string jwks-uri)) + (authorization_endpoint . ,(uri->string authorization-endpoint-uri)) + (token_endpoint . ,(uri->string token-endpoint-uri)) + (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc"))) (openid-configuration-uri (build-uri 'https #:host (uri-host issuer) #:path "/.well-known/openid-configuration"))) (lambda (request request-body) (let ((uri (request-uri request)) - (current-time (current-time))) - (cond ((same-uri? uri openid-configuration-uri) - (let* ((current-sec (time-second current-time)) - (exp-sec (+ current-sec 3600)) - (exp (time-utc->date - (make-time time-utc 0 exp-sec)))) - (serve-oidc-configuration exp openid-configuration))) - ((same-uri? uri jwks-uri) - (let* ((current-sec (time-second current-time)) - (exp-sec (+ current-sec 3600)) - (exp (time-utc->date - (make-time time-utc 0 exp-sec)))) - (serve-jwks exp (make-jwks (list key))))) - ((same-uri? uri authorization-endpoint-uri #:skip-query #t) - (authorization-endpoint request request-body)) - ((same-uri? uri token-endpoint-uri) - (token-endpoint request request-body)) - ((same-uri? uri subject) - (values - (build-response #:headers '((content-type text/turtle)) - #:port #f) - (format #f - "@prefix foaf: <http://xmlns.com/foaf/0.1/> . + (current-time ((p:current-date)))) + (parameterize ((web-locale request)) + (cond ((same-uri? uri openid-configuration-uri) + (let* ((current-sec (time-second (date->time-utc current-time))) + (exp-sec (+ current-sec 3600)) + (exp (time-utc->date + (make-time time-utc 0 exp-sec)))) + (serve-oidc-configuration exp openid-configuration))) + ((same-uri? uri jwks-uri) + (let* ((current-sec (time-second (date->time-utc current-time))) + (exp-sec (+ current-sec 3600)) + (exp (time-utc->date + (make-time time-utc 0 exp-sec)))) + (serve-jwks exp (make-jwks (list key))))) + ((same-uri? uri authorization-endpoint-uri #:skip-query #t) + (authorization-endpoint request request-body)) + ((same-uri? uri token-endpoint-uri) + (token-endpoint request request-body)) + ((same-uri? uri subject) + (values + (build-response #:headers '((content-type text/turtle)) + #:port #f) + (format #f + "@prefix foaf: <http://xmlns.com/foaf/0.1/> . @prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> . <#~a> a foaf:Person ; rdfs:comment \"It works. Now you should use another service to serve that resource.\" . " - (uri-fragment subject)))) - (else - (values - (build-response #:code 404 - #:reason-phrase "Not Found" - #:headers '((content-type application/xhtml+xml))) - (with-output-to-string - (lambda () - (sxml->xml - `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") - (html (@ (xmlns "http://www.w3.org/1999/xhtml") - (xml:lang "en")) - (body - (h1 "Resource not found") - (p "This OpenID Connect identity provider does not know the resource you are requesting.")))))))))))))))) + (uri-fragment subject)))) + (else + (values + (build-response #:code 404 + #:reason-phrase (W_ "reason-phrase|Not Found") + #:headers '((content-type application/xhtml+xml))) + (with-output-to-string + (lambda () + (sxml->xml + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(sxml-match + (xml->sxml + (W_ (format #f "<h1>Resource not found</h1>"))) + ((*TOP* ,title) title)) + ,(sxml-match + (xml->sxml + (W_ (format #f "<p>This OpenID Connect identity provider does not know the resource you are requesting.</p>"))) + ((*TOP* ,p) p)))))))))))))))))) diff --git a/src/scm/webid-oidc/jti.scm b/src/scm/webid-oidc/jti.scm index cf05bbb..150de0b 100644 --- a/src/scm/webid-oidc/jti.scm +++ b/src/scm/webid-oidc/jti.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -16,12 +16,30 @@ (define-module (webid-oidc jti) #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module (webid-oidc web-i18n) #:use-module (ice-9 atomic) #: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) - #:export (jti-check)) + #:declarative? #t + #:export + ( + jti-check + + &jti-found + make-jti-found + jti-found? + jti-found-jti + )) + +(define-exception-type + &jti-found + &external-error + make-jti-found + jti-found? + (jti jti-found-jti)) (define jti-list (make-atomic-box '())) @@ -36,8 +54,15 @@ (match-lambda* ((() item) #f) (((($ <jti-item> exp jti) other ...) item) - (or (string=? jti item) - (lookup other item))))) + (when (string=? jti item) + (let ((final-message + (format #f (G_ "a replay has been detected with JTI ~s") + jti))) + (raise-exception + (make-exception + (make-jti-found jti) + (make-exception-with-message final-message))))) + (lookup other item)))) (define (jti-check jti valid-time) (let* ((current-time diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm index 57da31d..5b17f29 100644 --- a/src/scm/webid-oidc/jwk.scm +++ b/src/scm/webid-oidc/jwk.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -17,34 +17,97 @@ (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 (srfi srfi-19) #:use-module (web response) #:use-module (web client) - #:use-module (rnrs bytevectors)) - -(define-public (the-jwk x) + #:use-module (rnrs bytevectors) + #:declarative? #t + #:export + ( + the-jwk + jwk? + kty + the-public-jwk + jwk-public? + strip + jkt + make-rsa-public-key + make-rsa-private-key + make-ec-point + make-ec-scalar + generate-key + the-jwks + jwks? + make-jwks + jwks-keys + serve-jwks + 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 (the-jwk x) (with-exception-handler - (lambda (cause) - (raise-not-a-jwk x cause)) + (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 x))) (unless (or (eq? kty 'EC) (eq? kty 'RSA)) - (throw 'really-not-a-jwk)) + (fail (format #f (G_ "unknown key type ~s") + kty))) x)))) -(define-public (jwk? x) +(define (jwk? x) (false-if-exception (and (the-jwk x) #t))) -(define-public (kty x) +(define (kty x) (stubs:kty (the-jwk x))) -(define-public (the-public-jwk x) +(define (the-public-jwk x) (with-exception-handler - (lambda (cause) - (raise-not-a-public-jwk x cause)) + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the public JWK is invalid: ~a") + (exception-message error)) + (format #f (G_ "the public JWK is invalid"))))) + (raise-exception + (make-exception + (make-not-a-jwk) + (make-exception-with-message final-message) + error)))) (lambda () (let ((key (the-jwk x))) (let ((crv (assq-ref key 'crv)) @@ -61,26 +124,35 @@ ((EC) ec-part) ((RSA) rsa-part)))))))) -(define-public (jwk-public? key) +(define (jwk-public? key) (false-if-exception (and (the-public-jwk key) #t))) -(define-public (strip key) +(define (strip key) (with-exception-handler - (lambda (cause) - (raise-not-a-public-jwk key cause)) + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot extract the public part of the key: ~a") + (exception-message error)) + (format #f (G_ "cannot extract the public part of the key"))))) + (raise-exception + (make-exception + (make-not-a-jwk) + (make-exception-with-message final-message) + error)))) (lambda () (stubs:strip-key key)))) -(define-public (jkt x) +(define (jkt x) (stubs:jkt (the-public-jwk x))) -(define-public (make-rsa-public-key n e) +(define (make-rsa-public-key n e) (the-public-jwk `((n . ,n) (e . ,e)))) -(define-public (make-rsa-private-key d p q dp dq qi) +(define (make-rsa-private-key d p q dp dq qi) (the-jwk `((d . ,d) (p . ,p) @@ -89,7 +161,7 @@ (dq . ,dq) (qi . ,qi)))) -(define-public (make-ec-point crv x y) +(define (make-ec-point crv x y) (if (symbol? crv) (make-ec-point (symbol->string crv) x y) (the-public-jwk @@ -97,48 +169,62 @@ (x . ,x) (y . ,y))))) -(define-public (make-ec-scalar crv d) +(define (make-ec-scalar crv d) (if (symbol? crv) (make-ec-scalar (symbol->string crv) d) (the-jwk `((crv . ,crv) (d . ,d))))) -(define-public generate-key stubs:generate-key) +(define generate-key stubs:generate-key) (define (the-public-keys keys) (map the-public-jwk keys)) -(define-public (the-jwks jwks) +(define (the-jwks jwks) (let ((keys (vector->list (assoc-ref jwks 'keys)))) (unless keys - (raise-not-a-jwks jwks #f)) + (let ((final-message + (format #f (G_ "the JWKS is invalid, because it does not have keys")))) + (raise-exception + (make-exception + (make-not-a-jwks) + (make-exception-with-message final-message))))) (with-exception-handler - (lambda (cause) - (raise-not-a-jwks jwks cause)) + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the JWKS is invalid: ~a") + (exception-message error)) + (format #f (G_ "the JWKS is invalid"))))) + (raise-exception + (make-exception + (make-not-a-jwks) + (make-exception-with-message final-message) + error)))) (lambda () `((keys . ,(list->vector (the-public-keys keys)))))))) -(define-public (jwks? jwks) +(define (jwks? jwks) (false-if-exception (and (the-jwks jwks) #t))) -(define-public (make-jwks keys) +(define (make-jwks keys) (if (vector? keys) (make-jwks (vector->list keys)) (let ((pubs (list->vector (map strip keys)))) (the-jwks `((keys . ,pubs)))))) -(define-public (jwks-keys jwks) +(define (jwks-keys jwks) (vector->list (assq-ref (the-jwks jwks) 'keys))) -(define-public (serve-jwks expiration-date jwks) +(define (serve-jwks expiration-date jwks) (values (build-response #:headers `((content-type . (application/json)) (expires . ,expiration-date))) (stubs:scm->json-string (the-jwks jwks)))) -(define*-public (get-jwks uri #:key (http-get http-get)) +(define* (get-jwks uri #:key (http-get http-get)) (receive (response response-body) (http-get uri) (with-exception-handler (lambda (cause) diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm index 43eb707..24a8bbc 100644 --- a/src/scm/webid-oidc/jws.scm +++ b/src/scm/webid-oidc/jws.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -17,91 +17,180 @@ (define-module (webid-oidc jws) #:use-module (webid-oidc jwk) #:use-module (webid-oidc errors) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (rnrs bytevectors) - #:use-module (ice-9 receive)) + #:use-module (ice-9 receive) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:declarative? #t + #:export + ( -(define-public (the-jws-header x) - (with-exception-handler - (lambda (cause) - (raise-not-a-jws-header x cause)) - (lambda () - (let ((alg (assq-ref x 'alg))) - (unless alg - (raise-missing-alist-key x 'alg)) - (unless (string? alg) - (raise-unsupported-alg alg)) - (case (string->symbol alg) - ((HS256 HS384 HS512 RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512) - x) - (else - (raise-unsupported-alg (string->symbol alg)))))))) - -(define-public (the-jws-payload x) - (with-exception-handler - (lambda (cause) - (raise-not-a-jws-payload x cause)) - (lambda () - (unless (list? x) - (scm-error 'wrong-type-arg "the-jws-payload" "expected a list" '() (list x))) - x))) + &invalid-jws + make-invalid-jws + invalid-jws? -(define-public (the-jws x) - (with-exception-handler - (lambda (cause) - (raise-not-a-jws x cause)) - (lambda () - (unless (pair? x) - (scm-error 'wrong-type-arg "the-jws" "expected a pair" '() (list x))) - (cons (the-jws-header (car x)) - (the-jws-payload (cdr x)))))) + the-jws + jws? -(define-public (jws-header? x) - (false-if-exception - (and (the-jws-header x) #t))) + jws-alg -(define-public (jws-payload? x) - (false-if-exception - (and (the-jws-payload x) #t))) + &cannot-query-identity-provider + make-cannot-query-identity-provider + cannot-query-identity-provider? + cannot-query-identity-provider-value -(define-public (jws? x) - (false-if-exception - (and (the-jws x) #t))) + &signed-in-future + make-signed-in-future + signed-in-future? + error-signature-date + error-current-date -(define-public (make-jws header payload) - (the-jws (cons (the-jws-header header) - (the-jws-payload payload)))) + &expired + make-expired + expired? + error-expiration-date + ;; error-current-date works for that one too -(define-public (jws-header jws) - (car (the-jws jws))) + jws-decode + jws-encode -(define-public (jws-payload jws) - (cdr (the-jws jws))) + )) -(define-public (jws-alg jws) - (if (jws? jws) - (jws-alg (jws-header jws)) - (string->symbol (assq-ref (the-jws-header jws) 'alg)))) +(define-exception-type + &invalid-jws + &external-error + make-invalid-jws + invalid-jws?) + +(define (the-jws x) + (with-exception-handler + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the JWS is invalid: ~a") + (exception-message error)) + (format #f (G_ "the JWS is invalid"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) + (lambda () + (match x + ((header . payload) + (let examine-header ((header header) + (alg #f) + (other-header-fields '())) + (match header + (() + (let examine-payload ((payload payload) + (other-payload-fields '())) + (match payload + (() + (unless alg + (fail (format #f (G_ "the JWS header does not have an \"alg\" field")))) + `(((alg . ,(symbol->string alg)) + ,@(reverse other-header-fields)) + . ,(reverse other-payload-fields))) + ((((? symbol? key) . value) payload ...) + (examine-payload payload + `((,key . ,value) ,@other-payload-fields))) + (else + (fail (format #f (G_ "invalid JSON object as payload"))))))) + ((('alg . (? string? given-alg)) header ...) + (case (string->symbol given-alg) + ((HS256 HS384 HS512 + RS256 RS384 RS512 + ES256 ES384 ES512 + PS256 PS384 PS512) + #t) + (else + (fail (format #f (G_ "invalid signature algorithm: ~s") given-alg)))) + (examine-header header (or alg (string->symbol given-alg)) + other-header-fields)) + ((('alg . invalid) header ...) + (fail (format #f (G_ "invalid \"alg\" value: ~s") invalid))) + ((((? symbol? key) . value) header ...) + (examine-header header alg + `((,key . ,value) ,@other-header-fields))) + (else + (fail (format #f (G_ "invalid JSON object as header"))))))) + (else + (fail (format #f (G_ "this is not a pair")))))))) + +(define (jws? x) + (false-if-exception + (the-jws x))) + +(define (jws-alg jws) + (match (the-jws jws) + ((header . _) + (string->symbol (assq-ref header 'alg))))) (define (split-in-3-parts string separator) - (let ((parts (list->vector (string-split string separator)))) - (unless (eqv? (vector-length parts) 3) - (raise-not-in-3-parts string separator)) - (values (vector-ref parts 0) (vector-ref parts 1) (vector-ref parts 2)))) + (match (string-split string separator) + ((header payload signature) + (values header payload signature)) + (else + (let ((final-message + (format #f (G_ "the encoded JWS is not in 3 parts")))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message))))))) (define (base64-decode-json str) (with-exception-handler (lambda (error) - (cond - (((record-predicate ¬-base64) error) - (raise-exception error)) - (((record-predicate ¬-json) error) - (raise-exception error)) - (else - ;; From utf8->string - (raise-not-base64 str error)))) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the encoded JWS header or payload is not a JSON object encoded in base64: ~a") + (exception-message error)) + (format #f (G_ "the encoded JWS header or payload is not a JSON object encoded in base64"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) (lambda () - (stubs:json-string->scm (utf8->string (stubs:base64-decode str)))))) + (stubs:json-string->scm + (utf8->string (stubs:base64-decode str)))))) + +(define-exception-type + &cannot-query-identity-provider + &external-error + make-cannot-query-identity-provider + cannot-query-identity-provider? + (identity-provider cannot-query-identity-provider-value)) + +(define-exception-type + &signed-in-future + &external-error + make-signed-in-future + signed-in-future? + (signature-date error-signature-date) + (current-date error-current-date*)) + +(define-exception-type + &expired + &external-error + make-expired + expired? + (expiration-date error-expiration-date) + (current-date error-current-date**)) + +(define error-current-date + (match-lambda + ((or ($ &signed-in-future _ date) + ($ &expired _ date) + ($ &compound-exception (($ &signed-in-future _ date) _ ...)) + ($ &compound-exception (($ &expired _ date) _ ...))) + date) + (($ &compound-exception (_ sub-exceptions ...)) + (error-current-date (apply make-exception sub-exceptions))) + (else #f))) (define (parse str verify) (receive (header payload signature) @@ -109,31 +198,53 @@ (let ((base (string-append header "." payload)) (header (base64-decode-json header)) (payload (base64-decode-json payload))) - (let ((ret (make-jws header payload))) + (let ((ret `(,header . ,payload))) (verify ret base signature) ret)))) (define (verify-any alg keys payload signature) - (define (aux candidates) - (if (null? keys) - (raise-no-matching-key keys alg payload signature) - (let ((next-ok - (with-exception-handler - (lambda (error) - #f) - (lambda () - (stubs:verify alg (car candidates) payload signature) - #t) - #:unwind? #t - #:unwind-for-type &invalid-signature))) - (or next-ok - (aux (cdr candidates)))))) - (aux keys)) - -(define-public (jws-decode str lookup-keys) + (let try-with-key ((keys keys)) + (match keys + (() + (let ((final-message + (format #f (G_ "the JWS is not signed by any of the expected set of public keys")))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message))))) + ((next-key keys ...) + (with-exception-handler + (lambda (error) + (unless (stubs:invalid-signature? error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "while verifying the JWS signature: ~a") + (exception-message error)) + (format #f (G_ "an unexpected error happened while verifying a JWS"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) + (try-with-key keys)) + (lambda () + (stubs:verify alg next-key payload signature)) + #:unwind? #t + #:unwind-for-type stubs:&invalid-signature))))) + +(define (jws-decode str lookup-keys) (with-exception-handler (lambda (error) - (raise-cannot-decode-jws str error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot decode a JWS: ~a") + (exception-message error)) + (format #f (G_ "cannot decode a JWS"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) (lambda () (parse str (lambda (jws payload signature) @@ -143,17 +254,26 @@ (else keys)))) (verify-any (jws-alg jws) keys payload signature)))))))) -(define-public (jws-encode jws key) +(define (jws-encode jws key) (with-exception-handler (lambda (error) - (raise-cannot-encode-jws jws key error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot encode a JWS: ~a") + (exception-message error)) + (format #f (G_ "cannot encode a JWS"))))) + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message final-message) + error)))) (lambda () - (let ((header (jws-header jws)) - (payload (jws-payload jws))) - (let ((header (stubs:scm->json-string header)) - (payload (stubs:scm->json-string payload))) - (let ((header (stubs:base64-encode header)) - (payload (stubs:base64-encode payload))) - (let ((payload (string-append header "." payload))) - (let ((signature (stubs:sign (jws-alg jws) key payload))) - (string-append payload "." signature))))))))) + (match jws + ((header . payload) + (let ((header (stubs:scm->json-string header)) + (payload (stubs:scm->json-string payload))) + (let ((header (stubs:base64-encode header)) + (payload (stubs:base64-encode payload))) + (let ((payload (string-append header "." payload))) + (let ((signature (stubs:sign (jws-alg jws) key payload))) + (string-append payload "." signature)))))))))) diff --git a/src/scm/webid-oidc/offloading.scm b/src/scm/webid-oidc/offloading.scm index 9620193..1332c70 100644 --- a/src/scm/webid-oidc/offloading.scm +++ b/src/scm/webid-oidc/offloading.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; dislfuid, implementation of the Solid specification ;; Copyright (C) 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -16,6 +16,7 @@ (define-module (webid-oidc offloading) #:use-module (ice-9 threads) + #:declarative? #t #:export (with-threads in-another-thread)) (define tag (make-prompt-tag)) diff --git a/src/scm/webid-oidc/oidc-configuration.scm b/src/scm/webid-oidc/oidc-configuration.scm index 2169a99..d9aab84 100644 --- a/src/scm/webid-oidc/oidc-configuration.scm +++ b/src/scm/webid-oidc/oidc-configuration.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -17,6 +17,7 @@ (define-module (webid-oidc oidc-configuration) #:use-module (webid-oidc jwk) #:use-module (webid-oidc errors) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (web uri) #:use-module (web client) @@ -24,81 +25,135 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-19) #:use-module (ice-9 receive) - #:use-module (ice-9 optargs)) + #:use-module (ice-9 optargs) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:declarative? #t + #:export + ( + &invalid-oidc-configuration + make-invalid-oidc-configuratioon + invalid-oidc-configuration? -(define-public (the-oidc-configuration x) + the-oidc-configuration + oidc-configuration? + oidc-configuration-jwks-uri + oidc-configuration-authorization-endpoint + oidc-configuration-token-endpoint + oidc-configuration-jwks + serve-oidc-configuration + get-oidc-configuration + )) + +(define-exception-type + &invalid-oidc-configuration + &external-error + make-invalid-oidc-configuration + invalid-oidc-configuration?) + +(define (the-oidc-configuration x) (with-exception-handler - (lambda (cause) - (raise-not-an-oidc-configuration x cause)) + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the OIDC configuration is invalid: ~a") + (exception-message error)) + (format #f (G_ "the OIDC configuration is invalid"))))) + (raise-exception + (make-exception + (make-invalid-oidc-configuration) + (make-exception-with-message final-message) + error)))) (lambda () - (let ((jwks-uri (assq-ref x 'jwks_uri)) - (token-endpoint (assq-ref x 'token_endpoint)) - (authorization-endpoint (assq-ref x 'authorization_endpoint))) - (unless jwks-uri - (raise-missing-alist-key x 'jwks_uri)) - (unless token-endpoint - (raise-missing-alist-key x 'token_endpoint)) - (unless authorization-endpoint - (raise-missing-alist-key x 'authorization_endpoint)) - (for-each - (lambda (field) - (unless (string->uri field) - (scm-error 'wrong-type-arg - "the-oidc-configuration" - "expected an uri-like string" - '() - (list field)))) - (list jwks-uri token-endpoint authorization-endpoint)) - x)))) + (let examine ((data x) + (jwks-uri #f) + (token-endpoint #f) + (authorization-endpoint #f) + (solid-oidc-supported #f) + (other-fields '())) + (match data + (() + (unless (and jwks-uri token-endpoint authorization-endpoint solid-oidc-supported) + (fail (format #f (G_ "the OIDC configuration does not have: ~s") + `(,@(if jwks-uri '() '("jwks_uri")) + ,@(if token-endpoint '() '("token_endpoint")) + ,@(if authorization-endpoint '() '("authorization_endpoint")) + ,@(if solid-oidc-supported '() '("solid_oidc_supported")))))) + `((jwks_uri . ,(uri->string jwks-uri)) + (token_endpoint . ,(uri->string token-endpoint)) + (authorization_endpoint . ,(uri->string authorization-endpoint)) + (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc") + ,@(reverse other-fields))) + ((('jwks_uri . (? string->uri (? string? given-jwks-uri))) data ...) + (examine data (or jwks-uri (string->uri given-jwks-uri)) + token-endpoint authorization-endpoint + solid-oidc-supported other-fields)) + ((('jwks_uri . invalid) data ...) + (fail (format #f (G_ "invalid JWKS URI: ~s") + invalid))) + ((('token_endpoint . (? string->uri (? string? given-token-endpoint))) data ...) + (examine data jwks-uri + (or token-endpoint (string->uri given-token-endpoint)) + authorization-endpoint solid-oidc-supported other-fields)) + ((('token_endpoint . invalid) data ...) + (fail (format #f (G_ "invalid token endpoint: ~s") + invalid))) + ((('authorization_endpoint + . (? string->uri (? string? given-authorization-endpoint))) + data ...) + (examine data jwks-uri token-endpoint + (or authorization-endpoint (string->uri given-authorization-endpoint)) + solid-oidc-supported other-fields)) + ((('authorization_endpoint . invalid) data ...) + (fail (format #f (G_ "invalid authorization endpoint: ~s") + invalid))) + ((('solid_oidc_supported . "https://solidproject.org/TR/solid-oidc") + data ...) + (examine data jwks-uri token-endpoint authorization-endpoint + (or solid-oidc-supported #t) + other-fields)) + ((('solid_oidc_supported . incorrect) data ...) + (fail (format #f (G_ "\"solid_oidc_supported\" should be set to ~s, not ~s") + "https://solidproject.org/TR/solid-oidc" + incorrect))) + ((((? symbol? key) . value) data ...) + (examine data jwks-uri token-endpoint authorization-endpoint + solid-oidc-supported + `((,key . ,value) ,@other-fields))) + (else + (fail (format #f (G_ "invalid JSON object"))))))))) -(define-public (oidc-configuration? obj) +(define (oidc-configuration? obj) (false-if-exception - (and (the-oidc-configuration obj) obj))) - -(define-public (make-oidc-configuration jwks-uri - authorization-endpoint - token-endpoint) - (when (string? jwks-uri) - (set! jwks-uri (string->uri jwks-uri))) - (when (string? authorization-endpoint) - (set! authorization-endpoint (string->uri authorization-endpoint))) - (when (string? token-endpoint) - (set! token-endpoint (string->uri token-endpoint))) - (the-oidc-configuration - `((jwks_uri . ,(uri->string jwks-uri)) - (token_endpoint . ,(uri->string token-endpoint)) - (authorization_endpoint . ,(uri->string authorization-endpoint))))) + (the-oidc-configuration obj))) (define (uri-field what) (lambda (x) (let ((str (assq-ref (the-oidc-configuration x) what))) (string->uri str)))) -(define-public oidc-configuration-jwks-uri +(define oidc-configuration-jwks-uri (uri-field 'jwks_uri)) -(define-public oidc-configuration-authorization-endpoint +(define oidc-configuration-authorization-endpoint (uri-field 'authorization_endpoint)) -(define-public oidc-configuration-token-endpoint +(define oidc-configuration-token-endpoint (uri-field 'token_endpoint)) -(define-public (oidc-configuration-jwks cfg . args) +(define (oidc-configuration-jwks cfg . args) (apply get-jwks (oidc-configuration-jwks-uri cfg) args)) -(define-public (serve-oidc-configuration expiration-date cfg) - (let ((with-solid-oidc-supported - (acons 'solid_oidc_supported "https://solidproject.org/TR/solid-oidc" - (the-oidc-configuration cfg)))) - (values (build-response #:headers `((content-type . (application/json)) - (expires . ,expiration-date))) - (stubs:scm->json-string with-solid-oidc-supported)))) +(define (serve-oidc-configuration expiration-date cfg) + (values (build-response #:headers `((content-type . (application/json)) + (expires . ,expiration-date))) + (stubs:scm->json-string cfg))) -(define*-public (get-oidc-configuration host - #:key - (userinfo #f) - (port #f) - (http-get http-get)) +(define* (get-oidc-configuration host + #:key + (userinfo #f) + (port #f) + (http-get http-get)) (when (and (string? host) (false-if-exception (string->uri host))) @@ -113,21 +168,31 @@ #:path "/.well-known/openid-configuration"))) (receive (response response-body) (http-get uri) (with-exception-handler - (lambda (cause) - (raise-unexpected-response response cause)) + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot fetch the OIDC configuration: ~a") + (exception-message error)) + (format #f (G_ "cannot fetch the OIDC configuration"))))) + (raise-exception + (make-exception + (make-invalid-oidc-configuration) + (make-exception-with-message final-message) + error)))) (lambda () (unless (eqv? (response-code response) 200) - (raise-request-failed-unexpectedly - (response-code response) - (response-reason-phrase response))) + (fail (format #f (G_ "the server responded with ~s ~s") + (response-code response) + (response-reason-phrase response)))) (let ((content-type (response-content-type response))) (unless content-type - (raise-unexpected-header-value 'content-type content-type)) + (fail (format #f (G_ "there is no 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)))) - (raise-unexpected-header-value 'content-type content-type)) + (fail (format #f (G_ "unexpected content-type: ~s") + content-type))) (unless (string? response-body) (set! response-body (utf8->string response-body))) (the-oidc-configuration (stubs:json-string->scm response-body)))))))) diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm index e95efaf..2f84f64 100644 --- a/src/scm/webid-oidc/oidc-id-token.scm +++ b/src/scm/webid-oidc/oidc-id-token.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -19,201 +19,307 @@ #:use-module (webid-oidc errors) #:use-module (webid-oidc jws) #:use-module (webid-oidc jti) + #: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 (srfi srfi-19)) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (srfi srfi-19) + #:declarative? #t + #:export + ( + &invalid-id-token + make-invalid-id-token + invalid-id-token? -(define-public (the-id-token-header x) - (with-exception-handler - (lambda (error) - (raise-not-an-id-token-header x error)) - (lambda () - (the-jws-header x)))) + the-id-token + id-token? -(define-public (id-token-header? x) - (false-if-exception - (and (the-id-token-header x) #t))) + id-token-alg + id-token-webid + id-token-iss + id-token-sub + id-token-aud + id-token-nonce + id-token-iat + id-token-exp + + id-token-decode + issue-id-token + )) -(define-public (the-id-token-payload x) +(define-exception-type + &invalid-id-token + &external-error + make-invalid-id-token + invalid-id-token?) + +(define (the-id-token x) (with-exception-handler (lambda (error) - (raise-not-an-id-token-payload x error)) + (let ((final-message + (cond + ((and (invalid-jws? error) + (exception-with-message? error)) + (format #f (G_ "this is not an ID token, because it is not even a JWS: ~a") + (exception-message error))) + ((invalid-jws? error) + (format #f (G_ "this is not an ID token, because it is not even a JWS"))) + ((exception-with-message? error) + (format #f (G_ "this is not an ID token: ~a") + (exception-message error))) + (else + (format #f (G_ "this is not an ID token")))))) + (raise-exception + (make-exception + (make-invalid-id-token) + (make-exception-with-message final-message) + error)))) (lambda () - (let ((x (the-jws-payload x))) - (let ((webid (assq-ref x 'webid)) - (iss (assq-ref x 'iss)) - (sub (assq-ref x 'sub)) - (aud (assq-ref x 'aud)) - (nonce (assq-ref x 'nonce)) - (iat (assq-ref x 'iat)) - (exp (assq-ref x 'exp))) - (unless (and webid (string? webid) (string->uri webid)) - (raise-incorrect-webid-field webid)) - (unless (and iss (string? iss) (string->uri iss)) - (raise-incorrect-iss-field iss)) - (unless (string? sub) - (raise-incorrect-sub-field sub)) - (unless (and aud (string? aud) (string->uri aud)) - (raise-incorrect-aud-field aud)) - (unless (string? nonce) - (raise-incorrect-nonce-field nonce)) - (unless (integer? iat) - (raise-incorrect-iat-field iat)) - (unless (and (integer? exp) (>= exp iat)) - (raise-incorrect-exp-field exp)) - x))))) - -(define-public (id-token-payload? x) + (match (the-jws x) + ((header . payload) + (let examine-payload ((payload payload) + (webid #f) + (iss #f) + (sub #f) + (aud #f) + (nonce #f) + (iat #f) + (exp #f) + (other-fields '())) + (match payload + (() + (unless (and webid iss sub aud nonce iat exp) + (fail (format #f (G_ "the payload is missing ~s") + `(,@(if webid '() '("webid")) + ,@(if iss '() '("iss")) + ,@(if sud '() '("sub")) + ,@(if aud '() '("aud")) + ,@(if nonce '() '("nonce")) + ,@(if iat '() '("iat")) + ,@(if exp '() '("exp")))))) + `(,header + . ((webid . ,(uri->string webid)) + (iss . ,(uri->string iss)) + (sub . ,sub) + (aud . ,(uri->string aud)) + (nonce . ,nonce) + (iat . ,(time-second (date->time-utc iat))) + (exp . ,(time-second (date->time-utc exp)))))) + ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...) + (examine-payload payload + (or webid webid-given) + iss sub aud nonce iat exp other-fields)) + ((('webid . invalid) payload ...) + (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given") + invalid))) + ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...) + (examine-payload payload webid + (or iss iss-given) + sub aud nonce iat exp other-fields)) + ((('iss . invalid) payload ...) + (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given") + invalid))) + ((('sub . (? string? sub-given)) payload ...) + (examine-payload payload webid iss + (or sub sub-given) + aud nonce iat exp other-fields)) + ((('sub . invalid) payload ...) + (fail (format #f (G_ "the \"sub\" field should be a string, ~s is given") + invalid))) + ((('aud . (? string? (= string->uri (? uri? aud-given)))) payload ...) + (examine-payload payload webid iss sub + (or aud aud-given) + nonce iat exp other-fields)) + ((('aud . invalid) payload ...) + (fail (format #f (G_ "the \"aud\" field should be an URI, ~s is given") + invalid))) + ((('nonce . (? string? nonce-given)) payload ...) + (examine-payload payload webid iss sub aud + (or nonce nonce-given) + iat exp other-fields)) + ((('nonce . invalid) payload ...) + (fail (format #f (G_ "the \"nonce\" field should be a string, ~s is given") + invalid))) + ((('iat . (? (lambda (x) (>= x 0)) (? integer? iat-given))) payload ...) + (examine-payload payload webid iss sub aud nonce + (or iat (time-utc->date (make-time time-utc 0 iat-given))) + exp other-fields)) + ((('iat . invalid) payload ...) + (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given") + invalid))) + ((('exp . (? (lambda (x) (>= x 0)) (? integer? exp-given))) payload ...) + (examine-payload payload webid iss sub aud nonce iat + (or exp (time-utc->date (make-time time-utc 0 exp-given))) + other-fields)) + ((('exp . invalid) payload ...) + (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given") + invalid))) + ((field payload ...) + (examine-payload payload webid iss sub aud nonce iat exp + `(,field ,@other-fields))) + (else + (fail (format #f (G_ "the payload should be a JSON object"))))))))))) + +(define (id-token? x) (false-if-exception - (and (the-id-token-header x) #t))) + (the-id-token x))) -(define-public (the-id-token x) - (with-exception-handler - (lambda (cause) - (raise-not-an-id-token x cause)) - (lambda () - (cons (the-id-token-header (car x)) - (the-id-token-payload (cdr x)))))) +(define (id-token-alg code) + (match (the-id-token code) + ((header . _) + (string->symbol (assq-ref header 'alg))))) -(define-public (id-token? x) - (false-if-exception - (and (the-id-token x) #t))) - -(define-public (make-id-token header payload) - (the-id-token - (cons header payload))) - -(define-public (make-id-token-payload webid iss sub aud nonce exp iat) - (when (date? exp) - (set! exp (date->time-utc exp))) - (when (time? exp) - (set! exp (time-second exp))) - (when (date? iat) - (set! iat (date->time-utc iat))) - (when (time? iat) - (set! iat (time-second iat))) - (when (uri? webid) - (set! webid (uri->string webid))) - (when (uri? iss) - (set! iss (uri->string iss))) - (when (uri? aud) - (set! aud (uri->string aud))) - (the-id-token-payload - `((webid . ,webid) - (iss . ,iss) - (sub . ,sub) - (aud . ,aud) - (nonce . ,nonce) - (exp . ,exp) - (iat . ,iat)))) - -(define-public (id-token-header code) - (car (the-id-token code))) - -(define-public (id-token-payload code) - (cdr (the-id-token code))) - -(define-public (id-token-alg code) - (when (id-token? code) - (set! code (id-token-header code))) - (jws-alg (the-id-token-header code))) - -(define-public (id-token-webid code) - (when (id-token? code) - (set! code (id-token-payload code))) - (string->uri - (assq-ref (the-id-token-payload code) 'webid))) - -(define-public (id-token-iss code) - (when (id-token? code) - (set! code (id-token-payload code))) - (string->uri - (assq-ref (the-id-token-payload code) 'iss))) - -(define-public (id-token-sub code) - (when (id-token? code) - (set! code (id-token-payload code))) - (assq-ref (the-id-token-payload code) 'sub)) - -(define-public (id-token-aud code) - (when (id-token? code) - (set! code (id-token-payload code))) - (string->uri - (assq-ref (the-id-token-payload code) 'aud))) - -(define-public (id-token-nonce code) - (when (id-token? code) - (set! code (id-token-payload code))) - (assq-ref (the-id-token-payload code) 'nonce)) - -(define-public (id-token-exp code) - (when (id-token? code) - (set! code (id-token-payload code))) - (time-utc->date - (make-time time-utc 0 (assq-ref - (the-id-token-payload code) - 'exp)))) - -(define-public (id-token-iat code) - (when (id-token? code) - (set! code (id-token-payload code))) - (time-utc->date - (make-time time-utc 0 (assq-ref - (the-id-token-payload code) - 'iat)))) - -(define*-public (id-token-decode str #:key (http-get http-get)) +(define (id-token-webid code) + (match (the-id-token code) + ((_ . payload) + (string->uri (assq-ref payload 'webid))))) + +(define (id-token-iss code) + (match (the-id-token code) + ((_ . payload) + (string->uri (assq-ref payload 'iss))))) + +(define (id-token-sub code) + (match (the-id-token code) + ((_ . payload) + (assq-ref payload 'sub)))) + +(define (id-token-aud code) + (match (the-id-token code) + ((_ . payload) + (string->uri (assq-ref payload 'aud))))) + +(define (id-token-nonce code) + (match (the-id-token code) + ((_ . payload) + (assq-ref payload 'nonce)))) + +(define (id-token-iat code) + (match (the-id-token code) + ((_ . payload) + (time-utc->date + (make-time time-utc 0 (assq-ref payload 'iat)))))) + +(define (id-token-exp code) + (match (the-id-token code) + ((_ . payload) + (time-utc->date + (make-time time-utc 0 (assq-ref payload 'exp)))))) + +(define* (id-token-decode str #:key (http-get http-get)) (with-exception-handler (lambda (error) - (raise-cannot-decode-id-token str error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the ID token is invalid: ~a") + (exception-message error)) + (format #f (G_ "the ID token is invalid"))))) + (raise-exception + (make-exception + (make-invalid-id-token) + (make-exception-with-message final-message) + error)))) (lambda () (jws-decode str (lambda (token) (let ((iss (id-token-iss token))) - (let ((cfg - (with-exception-handler - (lambda (error) - (raise-cannot-fetch-issuer-configuration iss error)) - (lambda () - (get-oidc-configuration - (uri-host iss) - #:userinfo (uri-userinfo iss) - #:port (uri-port iss) - #:http-get http-get))))) - (with-exception-handler - (lambda (error) - (raise-cannot-fetch-jwks iss - (oidc-configuration-jwks-uri cfg) - error)) - (lambda () - (oidc-configuration-jwks cfg #:http-get http-get)))))))))) - -(define-public (id-token-encode id-token key) + (let* ((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) + (raise-exception + (make-exception + (make-cannot-query-identity-provider iss) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a") + (exception-message error)) + (format #f (G_ "I cannot query the JWKS URI of the identity provider"))))))) + (lambda () + (oidc-configuration-jwks cfg #:http-get http-get))))) + (let ((iat (id-token-iat token)) + (exp (id-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 ID 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 ID 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 (id-token-encode id-token key) (with-exception-handler (lambda (error) - (raise-cannot-encode-id-token id-token key error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot encode the ID token: ~a") + (exception-message error)) + (format #f (G_ "cannot encode the ID token"))))) + (raise-exception + (make-exception-with-message final-message)))) (lambda () (jws-encode id-token key)))) -(define*-public (issue-id-token - issuer-key - #:key - (alg #f) - (webid #f) - (iss #f) - (sub #f) - (aud #f) - (validity 3600)) +(define* (issue-id-token + issuer-key + #:key + (alg #f) + (webid #f) + (iss #f) + (sub #f) + (aud #f) + (validity 3600)) (unless sub - (set! sub webid)) - (id-token-encode - (make-id-token - `((alg . ,(symbol->string alg))) - (let ((iat (time-second (date->time-utc ((p:current-date)))))) - (make-id-token-payload webid iss sub aud (stubs:random 12) - (+ iat validity) iat))) - issuer-key)) + (set! sub (uri->string webid))) + (let* ((iat (time-second (date->time-utc ((p:current-date))))) + (exp (+ iat validity))) + (jws-encode + (the-id-token + `(((alg . ,(symbol->string alg))) + . ((webid . ,(uri->string webid)) + (iss . ,(uri->string iss)) + (sub . ,sub) + (aud . ,(uri->string aud)) + (nonce . ,(stubs:random 12)) + (iat . ,iat) + (exp . ,exp)))) + issuer-key))) diff --git a/src/scm/webid-oidc/parameters.scm b/src/scm/webid-oidc/parameters.scm index 3b24361..603a2cd 100644 --- a/src/scm/webid-oidc/parameters.scm +++ b/src/scm/webid-oidc/parameters.scm @@ -1,7 +1,24 @@ +;; 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 <https://www.gnu.org/licenses/>. + (define-module (webid-oidc parameters) #:use-module (srfi srfi-19) #:use-module (webid-oidc jti) - #:export (data-home cache-home current-date)) + #:export (data-home cache-home current-date) + #:declarative? #t) (define data-home (make-parameter diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm index 9d65b70..2b80bef 100644 --- a/src/scm/webid-oidc/program.scm +++ b/src/scm/webid-oidc/program.scm @@ -25,6 +25,7 @@ #:use-module (webid-oidc jti) #:use-module (webid-oidc offloading) #:use-module (webid-oidc catalog) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc config) #:prefix cfg:) @@ -45,13 +46,6 @@ #:use-module (webid-oidc cache) #:use-module (web server)) -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) - (define logging-mutex (make-mutex)) (define* (http-get-with-log uri #:key (headers '())) @@ -59,16 +53,17 @@ (define uri-string (if (uri? uri) (uri->string uri) uri)) (with-mutex logging-mutex (when (getenv "XML_CATALOG_FILES") - (format (current-error-port) "~a: Warning: XML_CATALOG_FILES is set to ~s.\n" + (format (current-error-port) (G_ "~a: Warning: XML_CATALOG_FILES is set to ~s.\n") date (getenv "XML_CATALOG_FILES"))) - (format (current-error-port) "~a: GET ~a ~s...\n" + (format (current-error-port) (G_ "~a: GET ~a ~s...\n") date uri-string headers)) (set! uri (resolve-uri uri #:http-get (lambda* (uri . args) (with-mutex logging-mutex - (format (current-error-port) "~a: Warning: loading XML catalog from the web, ~s.\n" + (format (current-error-port) + (G_ "~a: Warning: loading XML catalog from the web, ~s.\n") date (uri->string uri))) (apply http-get uri args)))) @@ -76,7 +71,7 @@ (in-another-thread (http-get uri #:headers headers)) (with-mutex logging-mutex - (format (current-error-port) "~a: GET ~a ~s: ~s ~a bytes\n" + (format (current-error-port) (G_ "~a: GET ~a ~s: ~s ~a bytes\n") date uri-string headers response (cond ((bytevector? response-body) @@ -115,84 +110,81 @@ (string-append (getenv "HOME") "/.cache")) "/disfluid")) ;; Fix the date - (p:current-date ((p:current-date)))) + (p:current-date ((p:current-date))) + (web-locale request)) (call/ec (lambda (return) (with-exception-handler (lambda (error) + (unless (exception-with-message? error) + (let ((final-message + (format #f (G_ "really bad internal server error")))) + (raise-exception + (make-exception + (make-exception-with-message final-message) + error)))) (with-mutex logging-mutex (format (current-error-port) (G_ "~a: ~a: Internal server error: ~a\n") (date->string ((p:current-date))) (request-ip-address request) - (error->str error))) + (exception-message error))) (return (build-response #:code 500 - #:reason-phrase "Internal Server Error" + #:reason-phrase (W_ "Internal Server Error") #:headers `((source . ,complete-corresponding-source) (date . ,((p:current-date))))) - "Sorry, there was an error.")) + (W_ "Sorry, there was an error."))) (lambda () - (with-exception-handler - (lambda (error) - (with-mutex logging-mutex - (format (current-error-port) - (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n") - ((record-accessor &unknown-client-locale 'web-locale) error) - ((record-accessor &unknown-client-locale 'c-locale) error) - (error->str error)))) - (lambda () - (receive (response response-body user cause) - (call-with-values - (lambda () - (handler request request-body)) - (case-lambda - ((response response-body) - (values response response-body #f #f)) - ((response response-body user) - (values response response-body user #f)) - ((response response-body user cause) - (values response response-body user cause)))) - (let ((logging-port - (let ((response-code (response-code response))) - (if (>= response-code 400) - ;; That’s an error - (current-error-port) - (current-output-port))))) - (with-mutex logging-mutex - (format logging-port - (G_ "~a: ~s ~a ~s ~a\n") - (if user - (format #f (G_ "~a: ~a (~a)") - (date->string (time-utc->date (current-time))) - (uri->string user) - (request-ip-address request)) - (format #f (G_ "~a: ~a") - (date->string (time-utc->date (current-time))) - (request-ip-address request))) - (request-method request) - (uri-path (request-uri request)) - (response-code response) - (if cause - (string-append - (response-reason-phrase response) - " " - (format #f (G_ "(there was an error: ~a)") - (error->str cause))) - (response-reason-phrase response))))) - (return - (build-response - #:version (response-version response) - #:code (response-code response) - #:reason-phrase (response-reason-phrase response) - #:headers `((source . ,complete-corresponding-source) - (date . ,((p:current-date))) - ,@(response-headers response)) - #:port (response-port response) - #:validate-headers? #t) - response-body))) - #:unwind? #t - #:unwind-for-type &unknown-client-locale)))))))) + (receive (response response-body user cause) + (call-with-values + (lambda () + (handler request request-body)) + (case-lambda + ((response response-body) + (values response response-body #f #f)) + ((response response-body user) + (values response response-body user #f)) + ((response response-body user cause) + (values response response-body user cause)))) + (let ((logging-port + (let ((response-code (response-code response))) + (if (>= response-code 400) + ;; That’s an error + (current-error-port) + (current-output-port))))) + (with-mutex logging-mutex + (format logging-port + (G_ "~a: ~s ~a ~s ~a\n") + (if user + (format #f (G_ "~a: ~a (~a)") + (date->string (time-utc->date (current-time))) + (uri->string user) + (request-ip-address request)) + (format #f (G_ "~a: ~a") + (date->string (time-utc->date (current-time))) + (request-ip-address request))) + (request-method request) + (uri-path (request-uri request)) + (response-code response) + (if (and cause (exception-with-message? cause)) + (string-append + (response-reason-phrase response) + " " + (format #f (G_ "(there was an error: ~a)") + (exception-message cause))) + (response-reason-phrase response))))) + (return + (build-response + #:version (response-version response) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers `((source . ,complete-corresponding-source) + (date . ,((p:current-date))) + ,@(response-headers response)) + #:port (response-port response) + #:validate-headers? #t) + response-body))))))))) (define (serve-one-client* handler implementation server state) ;; Same as serve-one-client, except it is served in a promise. diff --git a/src/scm/webid-oidc/provider-confirmation.scm b/src/scm/webid-oidc/provider-confirmation.scm index 1baf2f3..aa9e085 100644 --- a/src/scm/webid-oidc/provider-confirmation.scm +++ b/src/scm/webid-oidc/provider-confirmation.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -22,24 +22,50 @@ #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) + #:use-module (webid-oidc web-i18n) #:use-module (rdf rdf) - #:use-module (turtle tordf)) + #:use-module (turtle tordf) + #:declarative? #t + #:export + ( + + &unconfirmed-provider + make-unconfirmed-provider + unconfirmed-provider? + + get-provider-confirmations + confirm-provider + )) + +(define-exception-type + &unconfirmed-provider + &external-error + make-unconfirmed-provider + unconfirmed-provider?) (define (find-confirmations subject graph) - (cond ((null? graph) '()) - ((and (string=? (rdf-triple-predicate (car graph)) - "http://www.w3.org/ns/solid/terms#oidcIssuer") - (string? (rdf-triple-subject (car graph))) - (string=? (rdf-triple-subject (car graph)) subject) - (string? (rdf-triple-object (car graph))) - (string->uri (rdf-triple-object (car graph))) - (eq? (uri-scheme (string->uri (rdf-triple-object (car graph)))) - 'https)) - (cons (string->uri (rdf-triple-object (car graph))) - (find-confirmations subject (cdr graph)))) - (else (find-confirmations subject (cdr graph))))) + (let search-graph ((graph graph) + (confirmations '())) + (match graph + (() (reverse confirmations)) + ((hd graph ...) + (match `(,(rdf-triple-subject hd) + ,(rdf-triple-predicate hd) + ,(rdf-triple-object hd)) + (((? (cute equal? subject <>) _) + "http://www.w3.org/ns/solid/terms#oidcIssuer" + (? string? + (= string->uri + (and (? uri? provider) + (= uri-scheme 'https))))) + (search-graph graph `(,provider ,@confirmations))) + (else + (search-graph graph confirmations))))))) (define (serve-confirmations expiration-date subject cnf) (let ((resource (format #f "@prefix solid: <http://www.w3.org/ns/solid/terms#> . @@ -55,9 +81,9 @@ (expires . ,expiration-date))) resource))) -(define*-public (get-provider-confirmations subject - #:key - (http-get http-get)) +(define* (get-provider-confirmations subject + #:key + (http-get http-get)) (unless (equal? (uri-scheme subject) 'https) (set! subject (build-uri 'https #:userinfo (uri-userinfo subject) @@ -73,14 +99,28 @@ #:port (uri-port subject)) (find-confirmations (uri->string subject) graph)))) -(define*-public (confirm-provider subject issuer - #:key (http-get http-get)) +(define* (confirm-provider subject issuer + #:key (http-get http-get)) (define (search lst) (if (null? lst) (raise-unconfirmed-provider subject issuer) (or (string=? (car lst) (uri->string issuer)) (search (cdr lst))))) (unless (string=? (uri-host subject) (uri-host issuer)) - (search (get-provider-confirmations - subject - #:http-get http-get)))) + (let search ((providers (get-provider-confirmations + subject + #:http-get http-get))) + (match providers + (() + (let ((final-message + (format #f ("~s has not set ~s as an identity provider") + (uri->string subject) + (uri->string issuer)))) + (raise-exception + (make-exception + (make-unconfirmed-provider) + (make-exception-with-message final-message))))) + (((? (cute equal? <> issuer) _) . _) + #t) + ((_ providers ...) + (search providers)))))) diff --git a/src/scm/webid-oidc/rdf-index.scm b/src/scm/webid-oidc/rdf-index.scm index b70dc9a..71919ad 100644 --- a/src/scm/webid-oidc/rdf-index.scm +++ b/src/scm/webid-oidc/rdf-index.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -18,56 +18,52 @@ #:use-module (oop goops) #:use-module (rdf rdf) #:use-module (web uri) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:declarative? #t #:export ( with-index )) -(define (normalize uri) - ;; It is possible to hide triples by percent-escaping - ;; some characters, so that match will fail to see - ;; them. With normalization, it should be impossible. - (when (string? uri) - (set! uri (string->uri uri))) - (let ((scheme (uri-scheme uri)) - (userinfo (uri-userinfo uri)) - (host (uri-host uri)) - (port (uri-port uri)) - (path (uri-path uri)) - (query (uri-query uri)) - (fragment (uri-fragment uri))) - (let ((normalized-scheme scheme) - (normalized-userinfo userinfo) - (normalized-host host) - (normalized-port port) - (normalized-path - (let ((path-ends-in-slash? (string-suffix? "/" path))) - (string-append - "/" - (encode-and-join-uri-path - (split-and-decode-uri-path path)) - (if (and (not (equal? path "/")) - path-ends-in-slash?) - "/" - "")))) - (normalized-query - (and query - (uri-encode (uri-decode query)))) - (normalized-fragment - (and fragment - (uri-encode (uri-decode fragment))))) - (build-uri normalized-scheme - #:userinfo normalized-userinfo - #:host normalized-host - #:port normalized-port - #:path normalized-path - #:query normalized-query - #:fragment normalized-fragment)))) +(define normalize + (match-lambda + ((and (= uri-scheme scheme) + (= uri-userinfo userinfo) + (= uri-host host) + (= uri-port port) + (= uri-path path) + (= uri-query query) + (= uri-fragment fragment)) + (let ((normalized-path + (let ((path-ends-in-slash? (string-suffix? "/" path))) + (string-append + "/" + (encode-and-join-uri-path + (split-and-decode-uri-path path)) + (if (and (not (equal? path "/")) + path-ends-in-slash?) + "/" + "")))) + (normalized-query + (and query + (uri-encode (uri-decode query)))) + (normalized-fragment + (and fragment + (uri-encode (uri-decode fragment))))) + (build-uri scheme + #:userinfo userinfo + #:host host + #:port port + #:path normalized-path + #:query normalized-query + #:fragment normalized-fragment))))) -(define (normalize-object object) - (if (string? object) - (uri->string (normalize object)) - object)) +(define normalize-object + (match-lambda + ((? string? (= string->uri (? uri? x))) + (uri->string (normalize x))) + (object object))) (define-class <rdf-index> () (triples #:init-keyword #:triples #:getter triples) @@ -80,43 +76,41 @@ (define (build-index triples) (let ((ret (make <rdf-index> #:triples (list->vector triples)))) - (define (do-index n triples) - (unless (null? triples) - (let ((first (car triples)) - (rest (cdr triples))) - (let ((s (normalize-object (rdf-triple-subject first))) - (p (normalize-object (rdf-triple-predicate first))) - (o (normalize-object (rdf-triple-object first)))) - (let ((other-s (hash-ref (subject-index ret) s '())) - (other-p (hash-ref (predicate-index ret) p '())) - (other-o (hash-ref (object-index ret) o '())) - (i (- n 1))) - (hash-set! (subject-index ret) s (cons i other-s)) - (hash-set! (predicate-index ret) p (cons i other-p)) - (hash-set! (object-index ret) o (cons i other-o)))) - (do-index (- n 1) rest)))) - (do-index (length triples) (reverse triples)) - ret)) + (let do-index ((n (length triples)) + (triples (reverse triples))) + (match triples + (() ret) + ((($ rdf-triple + (= normalize-object s) + (= normalize-object p) + (= normalize-object o)) + triples ...) + (let ((other-s (hash-ref (subject-index ret) s '())) + (other-p (hash-ref (predicate-index ret) p '())) + (other-o (hash-ref (object-index ret) o '())) + (i (- n 1))) + (hash-set! (subject-index ret) s `(,i ,@other-s)) + (hash-set! (predicate-index ret) p `(,i ,@other-p)) + (hash-set! (object-index ret) o `(,i ,@other-o))) + (do-index (- n 1) triples)))))) -(define (intersection-2 a b) - (cond - ((not a) b) - ((not b) a) - ((or (null? a) (null? b)) - '()) - ((< (car a) (car b)) - (intersection-2 (cdr a) b)) - ((> (car a) (car b)) - (intersection-2 a (cdr b))) - (else - (cons (car a) (intersection-2 (cdr a) (cdr b)))))) +(define intersection-2 + ;; Intersection of two lists of integers, but if one is false, only + ;; consider the other. + (match-lambda* + ((or (#f x) (x #f)) x) + ((or (() _) (_ ())) '()) + ((and (a b) + ((hda tla ...) (hdb tlb ...))) + (cond ((< hda hdb) (intersection-2 tla b)) + ((> hda hdb) (intersection-2 a tlb)) + (else `(,hda ,@(intersection-2 tla tlb))))))) -(define (intersection a . rest) - (if (null? rest) - a - (let ((b (car rest)) - (true-rest (cdr rest))) - (apply intersection (intersection-2 a b) true-rest)))) +(define intersection + (match-lambda* + ((x) x) + ((a b c ...) + (apply intersection (intersection-2 a b) c)))) (define (rdf-match index subject predicate object) (let ((by-subject @@ -135,17 +129,15 @@ (normalize-object object) '())))) (let ((indices (intersection by-subject by-predicate by-object))) - (define (accumulate-triples acc i) - (if (null? i) - (reverse acc) - (let ((t (vector-ref (triples index) (car i)))) - (accumulate-triples (cons t acc) (cdr i))))) (if indices - (accumulate-triples '() indices) + (let accumulate-triples ((acc '()) + (i indices)) + (match i + (() (reverse acc)) + ((next i ...) + (let ((t (vector-ref (triples index) next))) + (accumulate-triples `(,t ,@acc) i))))) (vector->list (triples index)))))) - (define (with-index graph f) - (let ((index (build-index graph))) - (f (lambda (s p o) - (rdf-match index s p o))))) + (f (cute rdf-match (build-index graph) <> <> <>))) diff --git a/src/scm/webid-oidc/refresh-token.scm b/src/scm/webid-oidc/refresh-token.scm index e3fbf7c..14d7361 100644 --- a/src/scm/webid-oidc/refresh-token.scm +++ b/src/scm/webid-oidc/refresh-token.scm @@ -18,13 +18,33 @@ #: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 ( + <refresh-token> + 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 @@ -32,83 +52,141 @@ remove-refresh-token )) +(define-exception-type + &invalid-refresh-token + &external-error + make-invalid-refresh-token + invalid-refresh-token?) + +(define-record-type <refresh-token> + (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) - (catch #t - (lambda () - (with-input-from-file (format #f "~a/refresh-tokens.scm" (p:data-home)) - read)) - (lambda errors - '()))) - -;; TODO: use stubs:atomically-update-file and remove that mutex. -(define mutex (make-mutex)) - -(define (set-refresh-token-list list) - (define dir (p:data-home)) - (define old-file (format #f "~a/refresh-tokens.scm" dir)) - (define new-file (format #f "~a/refresh-tokens.scm~" dir)) - (stubs:call-with-output-file* - new-file - (lambda (port) - (write list port) - (close-port port))) - (rename-file new-file old-file)) + (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 f) - (with-mutex mutex - (let ((old (list-refresh-tokens))) - (let ((new (f old))) - (set-refresh-token-list new))))) +(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 + (($ <refresh-token> + (= 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 + (($ <refresh-token> + (? (cute equal? <> sub) _) + (? (cute equal? <> aud) _) + _ _) + #f) + (else #t)) + <>)) + +(define (keep-n n) (lambda (old) - (filter (lambda (o) - (not (and (equal? (assq-ref o 'sub) - (uri->string sub)) - (equal? (assq-ref o 'aud) - (uri->string aud))))) - old))) - -(define (keep-n n list) - (cond - ((<= n 0) '()) - ((null? list) '()) - (else (cons (car list) (keep-n (- n 1) (cdr list)))))) + (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) - (keep-n - 20 - (cons `((sub . ,(uri->string sub)) - (aud . ,(uri->string aud)) - (jkt . ,jkt) - (refresh_token . ,jti)) - (remover old))))) + (truncator + `(,(make-refresh-token sub aud jkt jti) + ,@(remover old))))) (define (issue-refresh-token sub aud jkt) - (define jti (stubs:random 12)) - (update-refresh-token-list (insert sub aud jkt jti)) - jti) + (let ((jti (stubs:random 12))) + (update-refresh-token-list (insert sub aud jkt jti)) + jti)) (define (with-refresh-token refresh-token key f) - (let ((list (list-refresh-tokens))) - (define (check list) - (if (null? list) - (raise-invalid-refresh-token refresh-token) - (let ((hd (car list)) - (tl (cdr list))) - (let ((sub (string->uri (assq-ref hd 'sub))) - (aud (string->uri (assq-ref hd 'aud))) - (cnf/jkt (assq-ref hd 'jkt)) - (the-refresh-token (assq-ref hd 'refresh_token))) - (if (string=? refresh-token the-refresh-token) - (begin - (unless (equal? (jkt key) cnf/jkt) - (raise-invalid-key-for-refresh-token key cnf/jkt)) - (f sub aud)) - (check tl)))))) - (check list))) + (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))))) + ((($ <refresh-token> (? 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))) diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index 5ee84db..4b38248 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -25,6 +25,8 @@ #:use-module ((webid-oidc server read) #:prefix ldp:) #:use-module ((webid-oidc server update) #:prefix ldp:) #:use-module ((webid-oidc server delete) #:prefix ldp:) + #:use-module ((webid-oidc server resource wac) #:prefix wac:) + #:use-module ((webid-oidc server resource path) #:prefix ldp:) #:use-module (webid-oidc server precondition) #:use-module (webid-oidc http-link) #:use-module ((webid-oidc parameters) #:prefix p:) @@ -38,33 +40,33 @@ #:use-module (web client) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) - #:use-module (ice-9 i18n) + #:use-module (webid-oidc web-i18n) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) #:use-module (ice-9 control) #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) #:use-module (sxml simple) - #:use-module (srfi srfi-19)) + #:use-module (srfi srfi-19) + #:declarative? #t + #:export + ( + make-authenticator + make-resource-server + )) -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) - -(define*-public (make-authenticator #:key - (server-uri #f) - (current-time current-time) - (http-get http-get)) +(define* (make-authenticator #:key + (server-uri #f) + (http-get http-get)) (unless (and server-uri (uri? server-uri)) - (error "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri).")) + (fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri)."))) (lambda (request request-body) (let ((headers (request-headers request)) (uri (request-uri request)) (method (request-method request)) (current-time ((p:current-date)))) - (parameterize ((p:current-date current-time)) ;; fix the date + (parameterize ((web-locale request) + (p:current-date current-time)) ;; fix the date (let ((authz (assoc-ref headers 'authorization)) (dpop (assoc-ref headers 'dpop)) (full-uri (build-uri (uri-scheme server-uri) @@ -82,10 +84,14 @@ (eq? (car authz) 'dpop) (with-exception-handler (lambda (error) - (format (current-error-port) - (G_ "~a: authentication failure: ~a\n") - (date->string current-time) - (error->str error)) + (if (exception-with-message? error) + (format (current-error-port) + (G_ "~a: authentication failure: ~a\n") + (date->string current-time) + (exception-message error)) + (format (current-error-port) + (G_ "~a: authentication failure\n") + (date->string current-time))) #f) (lambda () ;; Sometimes the access is the cadr as a symbol, @@ -151,7 +157,7 @@ (return (build-response #:code 412 - #:reason-phrase "Precondition Failed") + #:reason-phrase (W_ "reason-phrase|Precondition Failed")) #f user)) (lambda () @@ -166,7 +172,7 @@ (return (build-response #:code 304 - #:reason-phrase "Not Modified" + #:reason-phrase (W_ "reason-phrase|Not Modified") #:headers headers) #f user)) @@ -175,14 +181,14 @@ (check-precondition path if-match if-none-match etag)) (respond-normal))))) -(define*-public (make-resource-server - #:key - (server-uri #f) - (owner #f) - (authenticator #f) - (http-get http-get)) +(define* (make-resource-server + #:key + (server-uri #f) + (owner #f) + (authenticator #f) + (http-get http-get)) (unless owner - (error "The owner is not defined.")) + (fail (G_ "The owner is not defined."))) (declare-link-header!) (unless authenticator (set! authenticator @@ -190,7 +196,8 @@ #:server-uri server-uri #:http-get http-get))) (lambda (request request-body) - (parameterize ((p:current-date ((p:current-date)))) ;; Fix the date + (parameterize ((p:current-date ((p:current-date))) ;; Fix the date + (web-locale request)) (let ((user (authenticator request request-body))) (handle-errors (lambda (return) @@ -253,7 +260,7 @@ (request-links request))))) (return (build-response - #:code 201 #:reason-phrase "Created" + #:code 201 #:reason-phrase (W_ "reason-phrase|Created") #:headers `((location . ,(ldp:create server-uri owner user (uri-path (request-uri request)) @@ -275,15 +282,21 @@ "" user))))) (lambda (return error) - (if (cannot-fetch-group? error) - (format (current-error-port) (G_ "Warning: ~a\n") - (error->str error)) + (if (wac:cannot-fetch-group? error) + (if (exception-with-message? error) + (format (current-error-port) + (G_ "~a: ignoring a group that cannot be fetched: ~a\n") + (date->string ((p:current-date))) + (exception-message error)) + (format (current-error-port) + (G_ "~a: ignoring a group that cannot be fetched\n") + (date->string ((p:current-date))))) (cond - ((uri-slash-semantics-error? error) + ((ldp:uri-slash-semantics-error? error) (return (build-response #:code 301 - #:reason-phrase "Found" + #:reason-phrase (W_ "reason-phrase|Found") #:headers `((location . ,(build-uri @@ -294,55 +307,55 @@ #:path (uri-slash-semantics-error-expected-path error))))) #f user)) - ((or (path-not-found? error) - (auxiliary-resource-absent? error) - (forbidden? error)) + ((or (ldp:path-not-found? error) + (ldp:auxiliary-resource-absent? error) + (wac:forbidden? error)) (if user ;; That’s a forbidden (return - (build-response #:code 403 #:reason-phrase "Forbidden") + (build-response #:code 403 #:reason-phrase (W_ "reason-phrase|Forbidden")) #f user) (return - (build-response #:code 401 #:reason-phrase "Unauthorized" + (build-response #:code 401 #:reason-phrase (W_ "reason-phrase|Unauthorized") #:headers `((www-authenticate . ((DPoP))))) #f user))) - ((or (cannot-delete-root? error)) + ((ldp:cannot-delete-root? error) (return (build-response #:code 405 - #:reason-phrase "Method Not Allowed") + #:reason-phrase (W_ "reason-phrase|Method Not Allowed")) #f user)) - ((or (container-not-empty? error) - (incorrect-containment-triples? error) - (path-is-auxiliary? error)) + ((or (ldp:container-not-empty? error) + (ldp:incorrect-containment-triples? error) + (ldp:path-is-auxiliary? error)) (return (build-response #:code 409 - #:reason-phrase "Conflict") + #:reason-phrase (W_ "reason-phrase|Conflict")) #f user)) - ((unsupported-media-type? error) + ((ldp:unsupported-media-type? error) (return (build-response #:code 415 - #:reason-phrase "Unsupported Media Type") + #:reason-phrase (W_ "reason-phrase|Unsupported Media Type")) #f user)) ((precondition-failed? error) (return (build-response #:code 412 - #:reason-phrase "Precondition Failed") + #:reason-phrase (W_ "reason-phrase|Precondition Failed")) #f user)) ((not-acceptable? error) (return (build-response #:code 406 - #:reason-phrase "Not Acceptable") + #:reason-phrase (W_ "reason-phrase|Not Acceptable")) #f user)) (else diff --git a/src/scm/webid-oidc/reverse-proxy.scm b/src/scm/webid-oidc/reverse-proxy.scm index a1b05e3..30e6d48 100644 --- a/src/scm/webid-oidc/reverse-proxy.scm +++ b/src/scm/webid-oidc/reverse-proxy.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -32,14 +32,20 @@ #:use-module (web response) #:use-module (web client) #:use-module (webid-oidc cache) - #:use-module (web server)) + #:use-module (webid-oidc web-i18n) + #:use-module (web server) + #:declarative? #t + #:export + ( + make-reverse-proxy + )) -(define*-public (make-reverse-proxy - #:key - (server-uri #f) - (http-get http-get) - (endpoint #f) - (auth-header 'XXX-Agent)) +(define* (make-reverse-proxy + #:key + (server-uri #f) + (http-get http-get) + (endpoint #f) + (auth-header 'XXX-Agent)) (set! auth-header ;; We need to remove the lowercase version of auth-header from ;; all incoming requests! @@ -51,7 +57,7 @@ #:server-uri server-uri #:http-get http-get)) (unless (and endpoint (uri? endpoint)) - (error "#:endpoint argument is not present or not an URI.")) + (fail (G_ "#:endpoint argument is not present or not an URI."))) (lambda (request request-body) (let ((agent (catch #t @@ -66,7 +72,8 @@ (else (apply throw key args)))))) (request-time ((p:current-date)))) - (parameterize ((p:current-date request-time)) + (parameterize ((p:current-date request-time) + (web-locale request)) ;; The time is now set for the duration of the request (let ((raw-headers (request-headers request))) (let ((modified-headers diff --git a/src/scm/webid-oidc/serve.scm b/src/scm/webid-oidc/serve.scm index c46ab8c..db95089 100644 --- a/src/scm/webid-oidc/serve.scm +++ b/src/scm/webid-oidc/serve.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -17,6 +17,7 @@ (define-module (webid-oidc serve) #:use-module (webid-oidc errors) #:use-module (webid-oidc fetch) + #:use-module (webid-oidc web-i18n) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (ice-9 exceptions) @@ -30,11 +31,29 @@ #:use-module (nquads fromrdf) #:use-module (json) #:use-module (jsonld) + #:declarative? #t #:export ( + + ¬-acceptable + make-not-acceptable + not-acceptable? + not-acceptable-client-accepts + not-acceptable-path + not-acceptable-content-type + convert )) +(define-exception-type + ¬-acceptable + &external-error + make-not-acceptable + not-acceptable? + (client-accepts not-acceptable-client-accepts) + (path not-acceptable-path) + (content-type not-acceptable-content-type)) + (define (convert client-accepts server-name path content-type content) (let ((data-as-rdf (false-if-exception @@ -53,7 +72,11 @@ ;; Content negociation is asked (let try-satisfy ((accepts client-accepts)) (if (null? accepts) - (raise-exception (make-not-acceptable client-accepts path content-type)) + (let ((final-message + (format #f (G_ "content negociation failed while serving a request")))) + (raise-exception + (make-not-acceptable client-accepts path content-type) + (make-exception-with-message final-message))) (let ((request (caar accepts))) (cond ((or (eq? request content-type) diff --git a/src/scm/webid-oidc/server/create.scm b/src/scm/webid-oidc/server/create.scm index b7b208d..dc9651e 100644 --- a/src/scm/webid-oidc/server/create.scm +++ b/src/scm/webid-oidc/server/create.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -21,6 +21,7 @@ #:use-module (webid-oidc server read) #:use-module (webid-oidc cache) #:use-module (webid-oidc fetch) + #:use-module (webid-oidc web-i18n) #:use-module (webid-oidc rdf-index) #:use-module (webid-oidc server resource wac) #:use-module ((webid-oidc stubs) #:prefix stubs:) @@ -42,20 +43,51 @@ #:use-module (ice-9 threads) #:use-module (rnrs bytevectors) #:use-module (oop goops) + #:declarative? #t #:export ( + &incorrect-containment-triples + make-incorrect-containment-triples + incorrect-containment-triples? + incorrect-containment-triples-path + + &unsupported-media-type + make-unsupported-media-type + unsupported-media-type? + unsupported-media-type-content-type + create create-root )) +(define-exception-type + &incorrect-containment-triples + &external-error + make-incorrect-containment-triples + incorrect-containment-triples? + (path incorrect-containment-triples-path)) + +(define-exception-type + &unsupported-media-type + &external-error + make-unsupported-media-type + unsupported-media-type? + (content-type unsupported-media-type-content-type)) + (define (without-containment-triples doc-uri content-type content) (case content-type ((text/turtle) #t) (else - (raise-exception (make-unsupported-media-type content-type)))) + (let ((final-message + (format #f (G_ "only text/turtle is allowed for the target of a POST request, not ~s") + content-type))) + (raise-exception + (make-exception + (make-unsupported-media-type content-type) + (make-exception-with-message final-message)))))) (let ((graph (fetch doc-uri #:http-get @@ -69,8 +101,13 @@ (unless (null? (rdf-match (uri->string doc-uri) "http://www.w3.org/ns/auth/acl#contains" #f)) - (raise-exception (make-incorrect-containment-triples - (uri-path doc-uri)))))))) + (let ((final-message + (format #f (G_ "the created resource cannot have containment triples")))) + (raise-exception + (make-exception + (make-incorrect-containment-triples + (uri-path doc-uri)) + (make-exception-with-message final-message))))))))) (define (types-indicate-container? types) (and (not (null? types)) @@ -106,7 +143,13 @@ ;; non-empty. (if container? "/" ""))))) (when (auxiliary-path? (uri-path doc-uri)) - (raise-exception (make-path-is-auxiliary (uri-path doc-uri)))) + (let ((final-message + (format #f (G_ "cannot POST to an auxiliary resource path, ~s") + (uri-path doc-uri)))) + (raise-exception + (make-exception + (make-path-is-auxiliary (uri-path doc-uri)) + (make-exception-with-message final-message))))) (when container? (without-containment-triples doc-uri content-type content)) (with-session diff --git a/src/scm/webid-oidc/server/delete.scm b/src/scm/webid-oidc/server/delete.scm index b5fb3a9..4e4ce66 100644 --- a/src/scm/webid-oidc/server/delete.scm +++ b/src/scm/webid-oidc/server/delete.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -43,6 +43,7 @@ #:use-module (ice-9 hash-table) #:use-module (rnrs bytevectors) #:use-module (oop goops) + #:declarative? #t #:export ( diff --git a/src/scm/webid-oidc/server/log.scm b/src/scm/webid-oidc/server/log.scm index f7dfa48..23c13c6 100644 --- a/src/scm/webid-oidc/server/log.scm +++ b/src/scm/webid-oidc/server/log.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -16,6 +16,7 @@ (define-module (webid-oidc server log) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:declarative? #t #:export ( prepare-log-file diff --git a/src/scm/webid-oidc/server/precondition.scm b/src/scm/webid-oidc/server/precondition.scm index 6912a7a..03ee967 100644 --- a/src/scm/webid-oidc/server/precondition.scm +++ b/src/scm/webid-oidc/server/precondition.scm @@ -44,10 +44,28 @@ #:export ( + &precondition-failed + make-precondition-failed + precondition-failed? + precondition-failed-path + precondition-failed-if-match + precondition-failed-if-none-match + precondition-failed-etag + check-precondition )) +(define-exception-type + &precondition-failed + &external-error + make-precondition-failed + precondition-failed? + (path precondition-failed-path) + (if-match precondition-failed-if-match) + (if-none-match precondition-failed-if-none-match) + (etag precondition-failed-etag)) + (define (the-etag object) ;; Sometimes the user passes a pair as an etag (just like what ;; request-if-match may return). diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm index aecde36..e672b15 100644 --- a/src/scm/webid-oidc/server/read.scm +++ b/src/scm/webid-oidc/server/read.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -22,6 +22,7 @@ #:use-module (webid-oidc fetch) #:use-module (webid-oidc http-link) #:use-module (webid-oidc server resource wac) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) @@ -44,10 +45,24 @@ #:export ( + &auxiliary-resource-absent + make-auxiliary-resource-absent + auxiliary-resource-absent? + auxiliary-resource-absent-base-path + auxiliary-resource-absent-path-type + read )) +(define-exception-type + &auxiliary-resource-absent + &external-error + make-auxiliary-resource-absent + auxiliary-resource-absent? + (base-path auxiliary-resource-absent-base-path) + (path-type auxiliary-resource-absent-path-type)) + (define* (read server-name owner user path #:key (http-get http-get)) @@ -86,8 +101,14 @@ (container? '(GET HEAD OPTIONS POST PUT DELETE)) (else '(GET HEAD OPTIONS PUT DELETE))))) (unless relevant-etag - (raise-exception - (make-auxiliary-resource-absent base-path path-type))) + (let ((final-message + (format #f (G_ "the auxiliary resource of type ~s at ~s is absent") + (uri->string path-type) + (uri->string base-path)))) + (raise-exception + (make-exception + (make-auxiliary-resource-absent base-path path-type) + (exception-with-message final-message))))) (let ((accept-put (if (or container? path-type) "text/turtle; application/n-quads; application/ld+json" "*/*"))) diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm index 55c4274..b8a9472 100644 --- a/src/scm/webid-oidc/server/resource/path.scm +++ b/src/scm/webid-oidc/server/resource/path.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -18,6 +18,7 @@ #:use-module (webid-oidc errors) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) @@ -31,9 +32,35 @@ #:use-module (ice-9 threads) #:use-module (rnrs bytevectors) #:use-module (oop goops) + #:declarative? #t #:export ( + &path-not-found + make-path-not-found + path-not-found? + path-not-found-path + + &uri-slash-semantics-error + make-uri-slash-semantics-error + uri-slash-semantics-error? + uri-slash-semantics-error-requested + uri-slash-semantics-error-existing + + &container-not-empty + make-container-not-empty + container-not-empty? + container-not-empty-path + + &cannot-delete-root + make-cannot-delete-root + cannot-delete-root? + + &path-is-auxiliary + make-path-is-auxiliary + path-is-auxiliary? + path-is-auxiliary-path + read-path update-path @@ -48,6 +75,41 @@ )) +(define-exception-type + &path-not-found + &external-error + make-path-not-found + path-not-found? + (path path-not-found-path)) + +(define-exception-type + &uri-slash-semantics-error + &external-error + make-uri-slash-semantics-error + uri-slash-semantics-error? + (requested uri-slash-semantics-error-requested) + (existing uri-slash-semantics-error-existing)) + +(define-exception-type + &container-not-empty + &external-error + make-container-not-empty + container-not-empty? + (path container-not-empty-path)) + +(define-exception-type + &cannot-delete-root + &external-error + make-cannot-delete-root + cannot-delete-root?) + +(define-exception-type + &path-is-auxiliary + &external-error + make-path-is-auxiliary + path-is-auxiliary? + (path path-is-auxiliary-path)) + (define (hash-path/lock path) (let ((h (stubs:hash 'SHA-256 path)) (dir (p:data-home))) @@ -78,17 +140,30 @@ (without-slash-exists (file-exists? (hash-path without-slash)))) (cond (with-slash-exists - (raise-exception - (make-exception - (make-path-not-found path) - (make-uri-slash-semantics-error path with-slash)))) + (let ((final-message + (format #f (G_ "incorrect slash semantics: path ~s should have a slash") + path))) + (raise-exception + (make-exception + (make-path-not-found path) + (make-uri-slash-semantics-error path with-slash) + (make-exception-with-message final-message))))) (without-slash-exists - (raise-exception - (make-exception - (make-path-not-found path) - (make-uri-slash-semantics-error path with-slash)))) + (let ((final-message + (format #f (G_ "incorrect slash semantics: path ~s should not have a slash") + path))) + (raise-exception + (make-exception + (make-path-not-found path) + (make-uri-slash-semantics-error path without-slash) + (make-exception-with-message final-message))))) (else - (raise-exception (make-path-not-found path))))))) + (let ((final-message + (format #f (G_ "path ~s does not exist") path))) + (raise-exception + (make-exception + (make-path-not-found path) + (make-exception-with-message final-message))))))))) (lambda () (call-with-input-file h (lambda (port) @@ -152,19 +227,28 @@ (case-lambda ((false) (when false - (error "You’re using the API wrong.")) + (fail (G_ "You’re using the API wrong."))) ;; Delete the resource (unless (or (not etag) (not (contained etag)) (null? (contained etag))) - (raise-exception (make-container-not-empty path))) + (raise-exception + (make-exception + (make-container-not-empty path) + (make-exception-with-message + (format #f (G_ "the path ~s exists, it has contained paths, and it is not empty") + path))))) (when (equal? path "/") - (raise-exception (make-cannot-delete-root))) + (raise-exception + (make-exception + (make-cannot-delete-root) + (make-exception-with-message + (format #f (G_ "you cannot delete the root")))))) (set! has-been-deleted? #t) #f) ((new-etag new-auxiliary) (unless (and (string? new-etag) (list? new-auxiliary)) - (error "You’re using the API wrong.")) + (fail (G_ "You’re using the API wrong."))) (hash-remove! garbage new-etag) (when new-auxiliary (for-each diff --git a/src/scm/webid-oidc/server/resource/wac.scm b/src/scm/webid-oidc/server/resource/wac.scm index 073d77b..e3ed089 100644 --- a/src/scm/webid-oidc/server/resource/wac.scm +++ b/src/scm/webid-oidc/server/resource/wac.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -23,6 +23,7 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module (webid-oidc web-i18n) #:use-module (web uri) #:use-module (web client) #:use-module (rdf rdf) @@ -35,11 +36,26 @@ #:use-module (ice-9 textual-ports) #:use-module (ice-9 binary-ports) #:use-module (ice-9 threads) + #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (oop goops) + #:declarative? #t #:export ( + &cannot-fetch-group + make-cannot-fetch-group + cannot-fetch-group? + cannot-fetch-group-uri + + &forbidden + make-forbidden + forbidden? + forbidden-path + forbidden-user + forbidden-owner + forbidden-expected-mode + wac-get-modes check-acl-can-read @@ -49,6 +65,23 @@ )) +(define-exception-type + &cannot-fetch-group + &external-error + make-cannot-fetch-group + cannot-fetch-group? + (group-uri cannot-fetch-group-uri)) + +(define-exception-type + &forbidden + &external-error + make-forbidden + forbidden? + (path forbidden-path) + (user forbidden-user) + (owner forbidden-owner) + (expected-mode forbidden-expected-mode)) + (define (group-member? http-get group-uri agent) (when (string? group-uri) (set! group-uri (string->uri group-uri))) @@ -63,9 +96,19 @@ #:query (uri-query group-uri)))) (with-exception-handler (lambda (error) - (raise-exception - (make-cannot-fetch-group group-uri error) - #:continuable? #t) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "cannot fetch group ~s: ~a") + (uri->string group-uri) + (exception-message error)) + (format #f (G_ "cannot fetch group ~s") + (uri->string group-uri))))) + (raise-exception + (make-exception + (make-cannot-fetch-group group-uri) + (make-exception-with-message final-message) + error) + #:continuable? #t)) #f) (lambda () (let ((data (fetch group-doc-uri #:http-get http-get))) @@ -252,8 +295,10 @@ (accumulate-unique '() (sort all-modes - (lambda (a b) - (string< (uri->string a) (uri->string b))))))))) + (match-lambda* + (((? uri? (= uri->string a)) + (? uri? (= uri->string b))) + (string< a b))))))))) (define (check-mode server-name path owner user http-get expected-mode) (unless (equal? owner user) @@ -271,8 +316,18 @@ (let ((modes (wac-get-modes server-name path user #:http-get http-get))) (define (check-modes modes) (if (null? modes) - (raise-exception - (make-forbidden path user owner expected-mode)) + (let ((final-message + (format #f (G_ "the resource under ~s is owned by ~s, and ~s can’t access it with ~s") + path + (uri->string owner) + (if user + (uri->string user) + (G_ "is owned by ..., and <> can’t access it|an anonymous user")) + (uri->string expected-mode)))) + (raise-exception + (make-exception + (make-forbidden path user owner expected-mode) + (make-exception-with-message final-message)))) (or (equal? (car modes) expected-mode) ;; It is also OK if we’re asking for acl:Append but diff --git a/src/scm/webid-oidc/server/update.scm b/src/scm/webid-oidc/server/update.scm index 2e811ae..3eec8f8 100644 --- a/src/scm/webid-oidc/server/update.scm +++ b/src/scm/webid-oidc/server/update.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -43,6 +43,7 @@ #:use-module (ice-9 hash-table) #:use-module (rnrs bytevectors) #:use-module (oop goops) + #:declarative? #t #:export ( @@ -55,7 +56,9 @@ ((text/turtle) #t) (else - (raise-exception (make-unsupported-media-type content-type)))) + (raise-exception + (make-exception + (make-unsupported-media-type content-type))))) (let ((graph (fetch doc-uri #:http-get diff --git a/src/scm/webid-oidc/simulation.scm b/src/scm/webid-oidc/simulation.scm index 45fb1f3..30f7b43 100644 --- a/src/scm/webid-oidc/simulation.scm +++ b/src/scm/webid-oidc/simulation.scm @@ -18,6 +18,8 @@ #:use-module ((webid-oidc client) #:prefix client:) #:use-module (webid-oidc identity-provider) #:use-module (webid-oidc resource-server) + #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc errors) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc server create) #:prefix server:) #:use-module (web uri) @@ -125,7 +127,9 @@ (response-location response) (uri-query (response-location response)) (string-prefix? "code=" (uri-query (response-location response)))) - (error "Invalid credentials.\n")) + (fail (format #f (G_ "invalid credentials: response ~s ~s") + (response-code response) + (response-reason-phrase response)))) (let* ((uri (response-location response)) (query (uri-query uri)) (code (substring query (string-length "code=")))) diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm index 08d15aa..e029b7c 100644 --- a/src/scm/webid-oidc/stubs.scm +++ b/src/scm/webid-oidc/stubs.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -16,84 +16,201 @@ (define-module (webid-oidc stubs) #:use-module (webid-oidc config) - #:use-module (webid-oidc errors) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 i18n) #:use-module (webid-oidc parameters) - #:use-module (json)) + #:use-module (json) + #:export + ( + + &invalid-base64-data + make-invalid-base64-data + invalid-base64-data? + error-base64-data + + &unsupported-elliptic-curve + make-unsupported-elliptic-curve + unsupported-elliptic-curve? + unsupported-elliptic-curve-value + + &unsupported-algorithm + make-unsupported-algorithm + unsupported-algorithm? + unsupported-algorithm-alg + unsupported-algorithm-application + + &invalid-signature + make-invalid-signature + invalid-signature? + invalid-signature-alg + invalid-signature-key + invalid-signature-payload + invalid-signature-signature + + &invalid-json + make-invalid-json + invalid-json? + invalid-json-input + + base64-encode + (fix-base64-decode . base64-decode) + random + (fix-random-init! . random-init!) + (fix-generate-key . generate-key) + kty + strip-key + (fix-hash . hash) + jkt + (fix-sign . sign) + (fix-verify . verify) + (fixed:json-string->scm . json-string->scm) + (fixed:json->scm . json->scm) + (fixed:scm->json-string . scm->json-string) + (fixed:scm->json . scm->json) + + mkdir-p + open-output-file* + call-with-output-file* + atomically-update-file + + )) + +(define (G_ text) + (let ((out (gettext text))) + (if (string=? out text) + ;; No translation, disambiguate + (car (reverse (string-split text #\|))) + out))) (load-extension (format #f "~a/libwebidoidc" libdir) "init_webidoidc") +(define-exception-type + &invalid-base64-data + &external-error + make-invalid-base64-data + invalid-base64-data? + (data error-base64-data)) + +(define (summarize str) + (if (> (string-length str) 10) + (format #f "~s" + (string-append + (substring str 0 10) + "...")) + (format #f "~s" str))) + (define (fix-base64-decode data) (catch 'base64-decoding-error (lambda () (base64-decode data)) (lambda error - (raise-not-base64 data error)))) + (let ((final-message + (format #f (G_ "invalid base64 data: ~a") + (summarize data)))) + (raise-exception + (make-exception + (make-invalid-base64-data data) + (make-exception-with-message final-message) + (make-exception-with-irritants (list data)))))))) + +(define-exception-type + &unsupported-elliptic-curve + &external-error + make-unsupported-elliptic-curve + unsupported-elliptic-curve? + (curve unsupported-elliptic-curve-value)) + +(define (unsupported-crv crv) + (let ((final-message + (format #f (G_ "~s is not a recognized elliptic curve") + crv))) + (raise-exception + (make-exception + (make-unsupported-elliptic-curve crv) + (make-exception-with-message final-message) + (make-exception-with-irritants (list crv)))))) (define (fix-generate-key . args) (catch 'unsupported-crv (lambda () (apply generate-key args)) - (lambda (error) - (raise-unsupported-crv (cadr error))))) - -(define (fix-kty key) - (catch 'unsupported-crv - (lambda () - (let ((ret (kty key))) - (unless ret - (raise-not-a-jwk key #f)) - ret)) (lambda error - (raise-unsupported-crv (cadr error))))) + (unsupported-crv (cadr error))))) + +(define-exception-type + &unsupported-algorithm + &external-error + make-unsupported-algorithm + unsupported-algorithm? + (alg unsupported-algorithm-alg) + ;; 'sign or 'hash: + (application unsupported-algorithm-application)) + +(define (unsupported-alg alg application) + (let ((final-message + (case application + ((sign) + (format #f (G_ "~s is not a supported signature algorithm") + alg)) + ((hash) + (format #f (G_ "~s is not a supported hash algorithm") + alg))))) + (raise-exception + (make-exception + (make-unsupported-algorithm alg application) + (make-exception-with-message final-message) + (make-exception-with-irritants (list alg)))))) (define (fix-hash alg payload) (catch 'unsupported-alg (lambda () (hash alg payload)) (lambda error - (raise-unsupported-alg (cadr error))))) + (unsupported-alg alg 'hash)))) (define (fix-sign alg key payload) (catch 'unsupported-alg (lambda () (sign alg key payload)) (lambda error - (raise-unsupported-alg (cadr error))))) + (unsupported-alg alg 'sign)))) + +(define-exception-type + &invalid-signature + &external-error + make-invalid-signature + invalid-signature? + (alg invalid-signature-alg) + (key invalid-signature-key) + (payload invalid-signature-payload) + (signature invalid-signature-signature)) (define (fix-verify alg key payload signature) (catch 'unsupported-alg (lambda () - (let ((ok - (verify alg key payload signature))) + (let ((ok (verify alg key payload signature))) (unless ok - (raise-invalid-signature key payload signature)))) + (let ((final-message + (format #f (G_ "the signature is invalid")))) + (raise-exception + (make-exception + (make-invalid-signature alg key payload signature) + (make-exception-with-message final-message) + (make-exception-with-irritants (list alg key payload signature)))))))) (lambda error - (raise-unsupported-alg (cadr error))))) + (unsupported-alg alg 'sign)))) (define (fix-random-init!) (setenv "XDG_CACHE_HOME" (cache-home)) (setenv "DISFLUID_APPLICATION_NAME" ".") (random-init!)) -(export - base64-encode - (fix-base64-decode . base64-decode) - random - (fix-random-init! . random-init!) - (fix-generate-key . generate-key) - (fix-kty . kty) - strip-key - (fix-hash . hash) - jkt - (fix-sign . sign) - (fix-verify . verify)) - ;; json reader from guile-json will not behave consistently with ;; SRFI-180 with objects: keys will be mapped to strings, not ;; symbols. So we fix alist keys to be symbols. -(define-public (fix-alists data) +(define (fix-alists data) (define (fix-an-alist rest alist) (if (null? alist) (reverse rest) @@ -117,33 +234,47 @@ (fix-a-vector data)) (else data))) +(define-exception-type + &invalid-json + &external-error + make-invalid-json + invalid-json? + (input invalid-json-input)) + (define (fixed:json-string->scm str) (with-exception-handler - (lambda (err) - (raise-not-json str err)) + (lambda (exn) + (let ((final-message + (format #f (G_ "invalid JSON data: ~a") + (summarize str)))) + (raise-exception + (make-exception + (make-invalid-json str) + (make-exception-with-message final-message) + (make-exception-with-irritants (list str)) + exn)))) (lambda () (fix-alists (json-string->scm str))))) -(export (fixed:json-string->scm . json-string->scm)) - (define (fixed:json->scm port) (with-exception-handler (lambda (err) - (raise-not-json "(input)" err)) + (let ((final-message + (format #f (G_ "invalid JSON data in input port")))) + (raise-exception + (make-exception + (make-invalid-json "(input)") + (make-exception-with-message final-message) + (make-exception-with-irritants (list port)) + exn)))) (lambda () (fix-alists (json->scm port))))) -(export (fixed:json->scm . json->scm)) - (define fixed:scm->json-string scm->json-string) -(export (fixed:scm->json-string . scm->json-string)) - (define fixed:scm->json scm->json) -(export (fixed:scm->json . scm->json)) - -(define-public (mkdir-p name) +(define (mkdir-p name) (catch 'system-error (lambda () (mkdir name)) @@ -159,15 +290,15 @@ (else (throw key subr message args rest)))))) -(define-public (open-output-file* filename . args) +(define (open-output-file* filename . args) (mkdir-p (dirname filename)) (apply open-output-file filename args)) -(define-public (call-with-output-file* filename . args) +(define (call-with-output-file* filename . args) (mkdir-p (dirname filename)) (apply call-with-output-file filename args)) -(define-public (atomically-update-file file lock-file-name f) +(define (atomically-update-file file lock-file-name f) ;; Call f with an output port. If f returns #f, delete the original ;; file. Otherwise, replace it. (let ((updating-file-name (string-append file "~"))) @@ -187,7 +318,16 @@ (with-exception-handler (lambda (error) (false-if-exception (delete-file updating-file-name)) - (raise-exception error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "while updating file ~s: ~a") + file (exception-message error)) + (format #f (G_ "an error happened while updating file ~s") + file)))) + (raise-exception + (make-exception + (make-exception-with-message final-message) + error)))) (lambda () (let ((ok (f port))) (fsync port) diff --git a/src/scm/webid-oidc/testing.scm b/src/scm/webid-oidc/testing.scm index f4de433..06d0127 100644 --- a/src/scm/webid-oidc/testing.scm +++ b/src/scm/webid-oidc/testing.scm @@ -27,17 +27,11 @@ ;; This module is used only when running tests. (define-public (with-test-environment test-name f) - (with-exception-handler - (lambda (error) - (format (current-error-port) "The test failed, because ~a.\n" - (error->str error)) - (raise-exception error)) - (lambda () - (parameterize ((data-home (format #f "tests/~a.home/disfluid" test-name)) - (cache-home (format #f "tests/~a.cache/disfluid" test-name))) - (call-with-output-file* - (format #f "~a/seed" (cache-home)) - (lambda (port) - (format port "This is the initial seed for the random number generator"))) - (random-init!) - (f))))) + (parameterize ((data-home (format #f "tests/~a.home/disfluid" test-name)) + (cache-home (format #f "tests/~a.cache/disfluid" test-name))) + (call-with-output-file* + (format #f "~a/seed" (cache-home)) + (lambda (port) + (format port "This is the initial seed for the random number generator"))) + (random-init!) + (f))) diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm index 7c4d41c..30a78d4 100644 --- a/src/scm/webid-oidc/token-endpoint.scm +++ b/src/scm/webid-oidc/token-endpoint.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -22,6 +22,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-id-token) #:use-module (webid-oidc access-token) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) @@ -32,58 +33,158 @@ #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (ice-9 control) + #:use-module (ice-9 exceptions) #:use-module (srfi srfi-19) - #:use-module (rnrs bytevectors)) + #:use-module (rnrs bytevectors) + #:use-module (sxml simple) + #:use-module (sxml match) + #:declarative? #t + #:export + ( + &unsupported-grant-type + make-unsupported-grant-type + unsupported-grant-type? + unsupported-grant-type-grant-type + + &no-authorization-code + make-no-authorization-code + no-authorization-code? + + &no-refresh-token + make-no-refresh-token + no-refresh-token? + + make-token-endpoint + )) + +(define-exception-type + &unsupported-grant-type + &external-error + make-unsupported-grant-type + unsupported-grant-type? + (grant-type unsupported-grant-type-grant-type)) + +(define-exception-type + &no-authorization-code + &external-error + make-no-authorization-code + no-authorization-code?) + +(define-exception-type + &no-refresh-token + &external-error + make-no-refresh-token + no-refresh-token?) (define (try-handle-web-failure thunk) - (define (error->str err) - (if (record? err) - (let* ((type (record-type-descriptor err)) - (get - (lambda (slot) - ((record-accessor type slot) err))) - (recurse - (lambda (err) - (error->str err)))) - (case (record-type-name type) - ((&cannot-decode-dpop-proof) - (format #f "the DPoP proof is invalid")) - ((&no-authorization-code) - (format #f "there is no authorization code in the request")) - ((&no-refresh-token) - (format #f "there is no refresh token in the request")) - ((&cannot-decode-authorization-code) - (format #f "the authorization code is invalid")) - ((&invalid-refresh-token) - (format #f "the refresh token is invalid")) - ((&invalid-key-for-refresh-token) - (format #f "the refresh token is bound to another key")) - ((&unsupported-grant-type) - (format #f "the grant type ~s is not supported" (get 'value))) - (else - (raise-exception err)))) - (throw err))) (call/ec (lambda (return) (with-exception-handler (lambda (error) - (return - (build-response - #:code 400 - #:reason-phrase (string-append "Bad Request: " (error->str error))) - (error->str error) - #f - error)) - thunk - #:unwind? #t)))) + (unless (or (unsupported-grant-type? error) + (no-authorization-code? error) + (no-refresh-token? error) + (refresh:invalid-refresh-token? error) + (invalid-authorization-code? error)) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "while handling web failure for the token endpoint: ~a") + (exception-message error)) + (format #f (G_ "an error happened during the token endpoint failure handling"))))) + (raise-exception + (make-exception + (make-exception-with-message final-message) + error)))) + (cond + ((refresh:invalid-refresh-token? error) + (return + (build-response + #:code 403 + #:reason-phrase (G_ "reason-phrase|Forbidden") + #:headers '((content-type application/xhtml-xml))) + (call-with-output-string + (lambda (port) + (sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(sxml-match + (xml->sxml + (W_ (format #f "<h1>Invalid refresh token</h1>"))) + ((*TOP* ,title) title)) + ,(sxml-match + (xml->sxml + (W_ (format #f "<p>The refresh token you sent is invalid, or it is already bound to another key.</p>"))) + ((*TOP* ,p) p)) + ,@(if (message-for-the-user? error) + (user-message error) + '())))) + port))))) + ((invalid-authorization-code? error) + (return + (build-response + #:code 400 + #:reason-phrase (G_ "reason-phrase|Bad Request") + #:headers '((content-type application/xhtml-xml))) + (call-with-output-string + (lambda (port) + (sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(sxml-match + (xml->sxml + (W_ (format #f "<h1>Invalid authorization code</h1>"))) + ((*TOP* ,title) title)) + ,(sxml-match + (xml->sxml + (W_ (format #f "<p>The authorization code is forged, or expired.</p>"))) + ((*TOP* ,p) p)) + ,@(if (message-for-the-user? error) + (user-message error) + '())))) + port))))) + ;; Other bad request + (else + (return + (build-response + #:code 400 + #:reason-phrase (G_ "reason-phrase|Bad Request") + #:headers '((content-type application/xhtml+xml))) + (call-with-output-string + (lambda (port) + (sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (body + ,(sxml-match + (xml->sxml + (W_ (format #f "<h1>Bad token request</h1>"))) + ((*TOP* ,title) title)) + ,(sxml-match + (xml->sxml + (W_ (format #f "<p>The token request failed.</p>"))) + ((*TOP* ,p) p)) + ,@(if (message-for-the-user? error) + (user-message error) + '())))) + port))))))) + thunk)))) -(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity) - (lambda* (request request-body) +(define (make-token-endpoint token-endpoint-uri iss alg jwk validity) + (lambda (request request-body) + (when (bytevector? request-body) + (set! request-body (utf8->string request-body))) (try-handle-web-failure (lambda () - (when (bytevector? request-body) - (set! request-body (utf8->string request-body))) - (parameterize ((p:current-date ((p:current-date)))) + (parameterize ((p:current-date ((p:current-date))) + (web-locale request)) (let ((current-time ((p:current-date))) ;; thunk parameter (form-args (if (and (request-content-type request) @@ -117,47 +218,93 @@ (assq-ref (request-headers request) 'dpop) (lambda (jkt) #t)))) (unless (and grant-type (string? grant-type)) - (raise-unsupported-grant-type #f)) + (let ((final-message + (format #f (G_ "missing grant type"))) + (final-user-message + (sxml-match + (xml->sxml + (format #f (W_ "<p>You did not specify a grant_type for this request.</p>"))) + ((*TOP* ,p) p)))) + (raise-exception + (make-exception + (make-unsupported-grant-type #f) + (make-exception-with-message final-message) + (make-message-for-the-user final-user-message))))) (receive (webid client-id) (case (string->symbol grant-type) ((authorization_code) (let ((code (let ((str (assoc-ref form-args "code"))) (unless str - (raise-no-authorization-code)) + (let ((final-message + (format #f (G_ "missing authorization code"))) + (final-user-message + (sxml-match + (xml->sxml + (format #f (W_ "<p>You want to grant an authorization code, but you did not set one.</p>"))) + ((*TOP* ,p) p)))) + (raise-exception + (make-exception + (make-no-authorization-code) + (make-exception-with-message final-message) + (make-message-for-the-user final-user-message))))) (authorization-code-decode str jwk)))) (values (authorization-code-webid code) (authorization-code-client-id code)))) ((refresh_token) (let ((refresh-token (assoc-ref form-args "refresh_token"))) (unless refresh-token - (raise-no-refresh-token)) + (let ((final-message + (format #f (G_ "missing refresh token"))) + (final-user-message + (sxml-match + (xml->sxml + (format #f (W_ "<p>You want to grant a refresh token, but you did not set one.</p>"))) + ((*TOP* ,p) p)))) + (raise-exception + (make-exception + (make-no-refresh-token) + (make-exception-with-message final-message) + (make-message-for-the-user final-user-message))))) (refresh:with-refresh-token refresh-token (dpop-proof-jwk dpop) values))) (else - (raise-unsupported-grant-type grant-type))) + (let ((final-message + (format #f (G_ "unsupported grant type: ~s") + grant-type)) + (final-user-message + (sxml-match + (xml->sxml + (format #f (W_ "<p>You want to use <pre>~s</pre> as a grant type, but this is not supported.</p>") + grant-type)) + ((*TOP* ,p) p)))) + (raise-exception + (make-exception + (make-unsupported-grant-type grant-type) + (make-exception-with-message final-message) + (make-message-for-the-user final-user-message)))))) (let* ((iat (time-second (date->time-utc current-time))) (exp (+ iat validity))) (let ((id-token (issue-id-token jwk #:alg alg - #:webid (uri->string webid) + #:webid webid #:sub (uri->string webid) - #:iss (uri->string iss) - #:aud (uri->string client-id) + #:iss iss + #:aud client-id #:validity 3600)) (access-token (issue-access-token jwk #:alg alg - #:webid (uri->string webid) - #:iss (uri->string iss) + #:webid webid + #:iss iss #:validity 3600 #:client-key (dpop-proof-jwk dpop) - #:client-id (uri->string client-id))) + #:client-id client-id)) (refresh-token (if (equal? grant-type "refresh_token") (assoc-ref form-args "refresh_token") diff --git a/src/scm/webid-oidc/web-i18n.scm b/src/scm/webid-oidc/web-i18n.scm new file mode 100644 index 0000000..d3a773f --- /dev/null +++ b/src/scm/webid-oidc/web-i18n.scm @@ -0,0 +1,92 @@ +;; 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 <https://www.gnu.org/licenses/>. + +(define-module (webid-oidc web-i18n) + #:use-module (ice-9 i18n) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-26) + #:use-module (web request) + #:declarative? #t + #:export + ( + + web-locale + + (web-gettext . W_) + (sysadmin-gettext . G_) + + )) + +(define locale-mutex + (make-mutex)) + +(define sort-qlist + (cute sort <> + (match-lambda* + (((px . _) (py . _)) + (>= px py))))) + +(define get-preferred-language + (match-lambda + ((? request? + (= request-accept-language + (= sort-qlist + (((_ . language) _ ...))))) + (get-preferred-language language)) + ((? string? + (= (cute string-split <> #\-) + ((? string? lang) + (? string? region)))) + (format #f "~a_~a.UTF-8" lang region)) + (else ""))) + +(define web-locale + (make-parameter + "en-US" + get-preferred-language)) + +(define (disambiguate str out) + (if (string=? out str) + ;; No translation, disambiguate + (car (reverse (string-split str #\|))) + ;; Translation done, nothing to do + out)) + +(define (web-gettext str) + (let ((out + (with-mutex locale-mutex + (let ((previous-locale (setlocale LC_ALL))) + (dynamic-wind + (lambda () + (with-exception-handler + (lambda (exn) + (setlocale LC_ALL "C")) + (lambda () + (setlocale LC_ALL (web-locale))) + #:unwind? #t)) + (lambda () + (gettext str)) + (lambda () + (setlocale LC_ALL previous-locale))))))) + (disambiguate str out))) + +(define (sysadmin-gettext str) + (let ((out + (with-mutex locale-mutex + (gettext str)))) + (disambiguate str out))) |