server: add client endpoints

3 files changed, 200 insertions, 174 deletions

diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 5322af1..ee0b72c 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -22,6 +22,8 @@
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc client-manifest)
   #:use-module (webid-oidc web-i18n)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc server endpoint client)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
@@ -168,183 +170,39 @@
       ((kw value args ...)
        (scan-arguments args headers `(,value ,kw ,@non-header-args) method)))))
 
-(define-class <extended-client-manifest> (<client-manifest>)
-  (client-name #:init-keyword #:client-name #:accessor client-name)
-  (client-uri #:init-keyword #:client-uri #:accessor client-uri)
-  (grant-types #:init-keyword #:grant-types #:accessor grant-types)
-  (response-types #:init-keyword #:response-types #:accessor response-types)
-  #:module-name '(webid-oidc client))
-
-(define-method (initialize (client <extended-client-manifest>) initargs)
-  (next-method)
-  (let-keywords
-   initargs #t
-   ((client-name (G_ "Example application"))
-    (client-uri "https://webid-oidc-demo.planete-kraus.eu")
-    (grant-types '(refresh_token authorization_code))
-    (response-types '(code)))
-   (let fix-grant-types ((grant-types grant-types)
-                         (ok '()))
-     (match grant-types
-       (()
-        (let ((grant-types (reverse ok)))
-          (let fix-response-types ((response-types response-types)
-                                   (ok '()))
-            (match response-types
-              (()
-               (let ((response-types (reverse ok)))
-                 (let fix-client-uri ((client-uri client-uri))
-                   (match client-uri
-                     ((? uri? client-uri)
-                      (let fix-client-name ((client-name client-name))
-                        (match client-name
-                          ((? string? client-name)
-                           (begin
-                             (slot-set! client 'client-name client-name)
-                             (slot-set! client 'client-uri client-uri)
-                             (slot-set! client 'grant-types grant-types)
-                             (slot-set! client 'response-types response-types)))
-                          (else
-                           (scm-error 'wrong-type-arg "make"
-                                      (G_ "#:client-name should be a string")
-                                      '()
-                                      (list client-name))))))
-                     ((? string? (= string->uri (? uri? client-uri)))
-                      (fix-client-uri client-uri))
-                     (else
-                      (scm-error 'wrong-type-arg "make"
-                                 (G_ "#:client-uri should be an URI")
-                                 '()
-                                 (list client-uri)))))))
-              (((or (? string? (= string->symbol hd))
-                    (? symbol? hd))
-                response-types ...)
-               (fix-response-types response-types `(,hd ,@ok)))
-              (else
-               (scm-error 'wrong-type-arg "make"
-                          (G_ "#:response-types should be a list of symbols")
-                          '()
-                          (list response-types)))))))
-       (((or (? string? (= string->symbol hd))
-             (? symbol? hd))
-         grant-types ...)
-        (fix-grant-types grant-types `(,hd ,@ok)))
-       (else
-        (scm-error 'wrong-type-arg "make"
-                   (G_ "#:grant-types should be a list of symbols")
-                   '()
-                   (list grant-types)))))))
-
-(define-method (->json-data (client <extended-client-manifest>))
-  (let ((other
-         (catch 'goops-error
-           (lambda ()
-             (next-method))
-           (lambda _
-             '()))))
-    (let ((all
-           `((client_name . ,(client-name client))
-             (client_uri . ,(uri->string (client-uri client)))
-             (grant_types . ,(list->vector (map symbol->string (grant-types client))))
-             (response_types . ,(list->vector (map symbol->string (response-types client))))
-             ,@other)))
-      ;; Put @context first
-      (receive (context non-context)
-          (let search-context ((fields all)
-                               (context-ones '())
-                               (non-context-ones '()))
-            (match fields
-              ((('@context . ,context) fields ...)
-               (search-context fields `(,context ,@context-ones) non-context-ones))
-              ((non-context fields ...)
-               (search-context fields context-ones `(,non-context ,@non-context-ones)))
-              (()
-               (values (reverse context-ones) (reverse non-context-ones)))))
-        (append
-         (map (lambda (ctx) `(@context . ,ctx)) context)
-         non-context)))))
-
 (define* (serve-application id redirect-uri . args)
-  (let ((manifest (apply make <extended-client-manifest>
+  (let ((endpoint (apply make <client-id>
                          #:client-id id
                          #:redirect-uris (list redirect-uri)
                          args)))
     (lambda (request request-body)
-      (parameterize ((web-locale request))
-        (let ((uri (request-uri request)))
-          (cond
-           ((equal? (uri-path uri) (uri-path id))
-            (receive (response response-body) (serve manifest #f)
-              (let ((if-none-match (request-if-none-match request))
-                    (etag (response-etag response)))
-                (if (and (list? if-none-match)
-                         etag
-                         (member (car etag) (map car if-none-match)))
-                    (values
-                     (build-response
-                      #:code 304
-                      #:reason-phrase (W_ "reason-phrase|Not Modified")
-                      #:headers `((content-type application/ld+json)
-                                  (etag . ,etag)))
-                     #f)
-                    (values response response-body)))))
-           ((equal? (uri-path uri) (uri-path redirect-uri))
-            (let ((query-args
-                   (map
-                    (lambda (key=value)
-                      (let ((splits
-                             (map uri-decode (string-split key=value #\=))))
-                        (if (or (null? splits) (null? (cdr splits)))
-                            splits
-                            (cons (string->symbol (car splits)) (cdr splits)))))
-                    (string-split (uri-query uri) #\&))))
-              (let ((code (assq-ref query-args 'code)))
-                (if code
-                    (values
-                     (build-response
-                      #: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")))
-                                  (head
-                                   (title ,(W_ "page-title|Authorization")))
-                                  (body
-                                   (p ,(W_ "You have been authorized. Please paste the following code in the application:"))
-                                   (p (strong ,code)))))))))
-                    (values
-                     (build-response
-                      #:code 400
-                      #:reason-phrase (W_ "reason-phrase|Invalid Request")
-                      #: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")))
-                                  (head
-                                   (title ,(W_ "page-title|Error")))
-                                  (body
-                                   (p ,(W_ "Your identity provider did not authorize you. :(")))))))))))))
-           (else
+      (with-exception-handler
+          (lambda (exn)
+            (unless (web-exception? exn)
+              (raise-exception exn))
             (values
              (build-response
-              #:code 404
-              #:reason-phrase (W_ "reason-phrase|Not Found")
+              #:code (web-exception-code exn)
+              #:reason-phrase (web-exception-reason-phrase exn)
               #: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")))
-                          (head
-                           (title ,(W_ "page-title|Not Found")))
-                          (body
-                           (p ,(W_ "This page does not exist on the server."))))))))))))))))
+             (call-with-output-string
+               (cute 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
+                              ,(call-with-input-string
+                                   (format #f (W_ "<h1>The request failed</h1>"))
+                                 xml->sxml)
+                              ,(if (user-message? exn)
+                                   (user-message-sxml exn)
+                                   (call-with-input-string
+                                       (format #f (W_ "<p>No more information.</p>"))
+                                     xml->sxml)))))
+                     <>))))
+        (lambda ()
+          (receive (response response-body response-meta)
+              (handle endpoint request request-body)
+            (values response response-body)))
+        #:unwind? #t))))
diff --git a/src/scm/webid-oidc/server/endpoint/Makefile.am b/src/scm/webid-oidc/server/endpoint/Makefile.am
index 1e4ee16..e6c6158 100644
--- a/src/scm/webid-oidc/server/endpoint/Makefile.am
+++ b/src/scm/webid-oidc/server/endpoint/Makefile.am
@@ -17,9 +17,11 @@
 dist_endpointserverwebidoidcmod_DATA += \
   %reldir%/reverse-proxy.scm \
   %reldir%/authentication.scm \
-  %reldir%/hello.scm
+  %reldir%/hello.scm \
+  %reldir%/client.scm
 
 endpointserverwebidoidcgo_DATA += \
   %reldir%/reverse-proxy.go \
   %reldir%/authentication.go \
-  %reldir%/hello.go
+  %reldir%/hello.go \
+  %reldir%/client.go
diff --git a/src/scm/webid-oidc/server/endpoint/client.scm b/src/scm/webid-oidc/server/endpoint/client.scm
new file mode 100644
index 0000000..ffa93c3
--- /dev/null
+++ b/src/scm/webid-oidc/server/endpoint/client.scm
@@ -0,0 +1,166 @@
+;; 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 server endpoint client)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc provider-confirmation)
+  #:use-module (webid-oidc client-manifest)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module ((webid-oidc config) #:prefix cfg:)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (web server)
+  #:use-module (web client)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #: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-26)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
+  #:declarative? #t
+  #:re-export
+  (
+   client-id
+   redirect-uris
+   )
+  #:export
+  (
+   <client-id>
+   client-name
+   client-uri
+   grant-types
+   response-types
+
+   <redirect-uri>
+   ))
+
+(define-class <client-id> (<endpoint> <client-manifest>)
+  (client-name #:init-keyword #:client-name #:getter client-name)
+  (client-uri #:init-keyword #:client-uri #:getter client-uri)
+  (grant-types #:init-keyword #:grant-types #:getter grant-types)
+  (response-types #:init-keyword #:response-types #:getter response-types)
+  #:module-name '(webid-oidc server endpoint client))
+
+(define-method (initialize (c <client-id>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((client-name (G_ "Example Solid Application"))
+    (client-uri (string->uri "https://disfluid.planete-kraus.eu"))
+    (grant-types '(refresh_token authorization_code))
+    (response-types '(code)))
+   (match client-uri
+     ((? string? (= string->uri (? uri? client-uri)))
+      (slot-set! c 'client-uri client-uri))
+     ((? uri?)
+      #t)
+     (else
+      (scm-error 'wrong-type-arg "make <client-id>"
+                 (G_ "#:client-uri should be an URI")
+                 '()
+                 (list client-uri))))
+   (let ((fix-symbol-list
+          (lambda (items what)
+            (let fix ((values items)
+                      (fixed '())
+                      (index 0))
+              (match values
+                ((? vector? x)
+                 (fix (vector->list x) fixed index))
+                (()
+                 (slot-set! c what (reverse fixed)))
+                (((or (? string? (= string->symbol value))
+                      (? symbol? value))
+                  values ...)
+                 (fix values `(,value @fixed) (+ index 1)))
+                ((wrong _ ...)
+                 (scm-error 'wrong-type-arg "make <client-id>"
+                            (format #f (G_ "#:~a element ~a should be a string or a symbol")
+                                    what index)
+                            '()
+                            (list wrong)))
+                (else
+                 (scm-error 'wrong-type-arg "make <client-id>"
+                            (format #f (G_ "#:~a should be a list")
+                                    what
+                                    '()
+                                    (list wrong)))))))))
+     (fix-symbol-list grant-types 'grant-types)
+     (fix-symbol-list response-types 'response-types))))
+
+(define-method (handle (endpoint <client-id>) request request-body)
+  (receive (response response-body) (serve endpoint #f)
+    (let ((if-none-match (request-if-none-match request))
+          (etag (response-etag response)))
+      (if (and (list? if-none-match)
+               etag
+               (member (car etag) (map car if-none-match)))
+          (values
+           (build-response
+            #:code 304
+            #:reason-phrase (W_ "reason-phrase|Not Modified")
+            #:headers `((content-type application/ld+json)
+                        (etag . ,etag)))
+           #f
+           '())
+          (values response response-body '())))))
+
+(define-class <redirect-uri> (<endpoint>))
+
+(define-method (handle (endpoint <redirect-uri>) request request-body)
+  (let ((query-args
+         (apply
+          append
+          (map
+           (lambda (key=value)
+             (match (map uri-decode (string-split key=value #\=))
+               ((key value)
+                `((,key . ,value)))
+               (else '())))
+           (string-split (uri-query (request-uri request)) #\&)))))
+    (let ((code (assq-ref query-args 'code)))
+      (if code
+          (values
+           (build-response
+            #:headers `((content-type applicationn/xhtml+xml)))
+           (call-with-output-string
+             (cute 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")))
+                           (head
+                            (title ,(W_ "page-title|Authorization")))
+                           (body
+                            (p ,(W_ "You have been authorized. Please paste the following code in the application:"))
+                            (p (strong ,code)))))
+                   <>))
+           '())
+          ;; No code:
+          (raise-exception
+           (make-exception
+            (make-web-exception 400 (W_ "reason-phrase|Invalid Request"))
+            (make-user-message
+             `(p ,(W_ "This page should obtain a code from your identity provider, but none has been provided.")))))))))