Define the web pages for the authorization endpoint

4 files changed, 267 insertions, 2 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 56b50ec..57bd1b1 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -13,7 +13,10 @@ dist_webidoidcmod_DATA += \
   %reldir%/client-manifest.scm \
   %reldir%/authorization-code.scm \
   %reldir%/refresh-token.scm \
-  %reldir%/oidc-id-token.scm
+  %reldir%/oidc-id-token.scm \
+  %reldir%/authorization-page.scm \
+  %reldir%/authorization-page-unsafe.scm
+
 webidoidcgo_DATA += \
   %reldir%/errors.go \
   %reldir%/stubs.go \
@@ -29,4 +32,8 @@ webidoidcgo_DATA += \
   %reldir%/client-manifest.go \
   %reldir%/authorization-code.go \
   %reldir%/refresh-token.go \
-  %reldir%/oidc-id-token.go
+  %reldir%/oidc-id-token.go \
+  %reldir%/authorization-page.go \
+  %reldir%/authorization-page-unsafe.go
+
+EXTRA_DIST += %reldir%/ChangeLog
diff --git a/src/scm/webid-oidc/authorization-page-unsafe.scm b/src/scm/webid-oidc/authorization-page-unsafe.scm
new file mode 100644
index 0000000..f969caf
--- /dev/null
+++ b/src/scm/webid-oidc/authorization-page-unsafe.scm
@@ -0,0 +1,185 @@
+(define-module (webid-oidc authorization-page-unsafe)
+  #:use-module (webid-oidc errors)
+  #:use-module (sxml simple)
+  #:use-module (web uri)
+  #:use-module (web response)
+  #:use-module (ice-9 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)))
+
+(define (str->sxml str)
+  (cdadr
+   (xml->sxml
+    (string-append "<protect>" str "</protect>"))))
+
+(define (make-page title . body)
+  (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 ,(G_ "xml-lang|en")))
+               (head
+                (title ,title))
+               (body
+                ,@body)))))))
+
+(define-public (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")
+           (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>?")
+                                         client-id client-id))))
+           `(p ,@(str->sxml (G_ "Do you want to authorize this application to represent you?")))
+           `(form (@ (action ,(uri->string post-uri))
+                     (method "POST"))
+                  (div
+                   (label (@ (for "password")
+                             ,@(if credential-invalid?
+                                   '((class "authz-page-credential-error"))
+                                   '()))
+                          ,@(str->sxml
+                             (if credential-invalid?
+                                 (G_ "Please retry your password:")
+                                 (G_ "Please enter your password:"))))
+                   (input (@ (type "password")
+                             (name "password")
+                             (id "password"))))
+                  (input (@ (type "submit")
+                            (value ,(G_ "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)))
+
+(define-public (error-no-client-id)
+  (bad-request
+   `(p ,@(str->sxml
+          (G_ "The application did not set the <emph>client_id</emph> parameter.")))))
+
+(define-public (error-no-redirect-uri)
+  (bad-request
+   `(p ,@(str->sxml
+          (G_ "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)
+          ((&not-base64)
+           `((li ,(format #f (G_ "the value ~s is not a base64 string.")
+                          (get 'value)))))
+          ((&not-json)
+           `((li ,(format #f (G_ "the following value is not JSON:"))
+                 (pre ,(get 'value)))))
+          ((&not-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))))
+          ((&not-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))))
+          ((&not-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)))
+
+(define-public (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)))))
+
+(define-public (redirection client-id uri)
+  (values (build-response
+           #:code 302
+           #:headers `((location . ,uri)
+                       (content-type application/xhtml+xml)))
+          (make-page
+           (G_ "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.")
+                   (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
new file mode 100644
index 0000000..b2c2f1f
--- /dev/null
+++ b/src/scm/webid-oidc/authorization-page.scm
@@ -0,0 +1,59 @@
+(define-module (webid-oidc authorization-page)
+  #:use-module (webid-oidc errors)
+  #: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)))
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index b0e9a19..714e0be 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -777,6 +777,17 @@
   (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 (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -1087,6 +1098,9 @@
           ((&not-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)))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)