Switch to a more sensible error reporting system

1 files changed, 72 insertions, 60 deletions

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))))))))))))))))))