From 34624c72245b483e645efd281a27c9c9e210a19a Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Thu, 14 Oct 2021 11:36:14 +0200
Subject: server: add an identity provider endpoint

---
 src/scm/webid-oidc/authorization-endpoint.scm | 135 ++++++++------------------
 1 file changed, 42 insertions(+), 93 deletions(-)

(limited to 'src/scm/webid-oidc/authorization-endpoint.scm')

diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm
index cbf91cf..74417aa 100644
--- a/src/scm/webid-oidc/authorization-endpoint.scm
+++ b/src/scm/webid-oidc/authorization-endpoint.scm
@@ -16,10 +16,12 @@
 
 (define-module (webid-oidc authorization-endpoint)
   #:use-module (webid-oidc errors)
-  #:use-module (webid-oidc authorization-page)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc server endpoint identity-provider)
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc authorization-code)
   #:use-module (webid-oidc client-manifest)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (web uri)
   #:use-module (web request)
@@ -30,6 +32,7 @@
   #:use-module (ice-9 receive)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 match)
+  #:use-module (sxml simple)
   #:use-module (oop goops)
   #:declarative? #t
   #:duplicates (merge-generics)
@@ -40,97 +43,43 @@
 
    ))
 
-(define (verify-password encrypted-password password)
-  (let ((c (crypt password encrypted-password)))
-    (string=? c encrypted-password)))
-
-(define (make-authorization-endpoint subject encrypted-password jwk)
-  (define (parse-arg x decode-plus-to-space?)
-    (map (lambda (x) (uri-decode
-                      x
-                      #:decode-plus-to-space? decode-plus-to-space?))
-         (string-split x #\=)))
-  (lambda* (request request-body)
+(define (make-authorization-endpoint subject encrypted-password jwk-file)
+  (define endpoint
+    (make <authorization-endpoint>
+      #:subject subject
+      #:encrypted-password encrypted-password
+      #:key-file jwk-file))
+  (lambda (request request-body)
     (when (bytevector? request-body)
       (set! request-body (utf8->string request-body)))
-    (let* ((uri (request-uri request))
-           (method (request-method request))
-           (query (uri-query uri))
-           (query-parts (if query
-                            (string-split query #\&)
-                            '()))
-           (get-args (map (cute parse-arg <> #f) query-parts))
-           (form-args
-            (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
-            (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))
-         ((not redirect-uri)
-          (error-no-redirect-uri locale))
-         ((and (eq? method 'POST)
-               (string? password)
-               (verify-password encrypted-password password))
-          (with-exception-handler
-              (lambda (error)
-                (error-application locale error))
-            (lambda ()
-              (let ((code (issue <authorization-code>
-                           jwk
-                           #:webid subject
-                           #:client-id client-id))
-                    (mf (make <client-manifest>
-                          #:client-id client-id)))
-                (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
-                              (not (and password
-                                        (verify-password encrypted-password password)))
-                              client-id
-                              uri)))))))
+    (parameterize ((web-locale request))
+      (with-exception-handler
+          (lambda (exn)
+            (unless (web-exception? exn)
+              (raise-exception exn))
+            (values
+             (build-response
+              #:code (web-exception-code exn)
+              #:reason-phrase (web-exception-reason-phrase exn)
+              #:headers `((content-type application/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")))
+                             (body
+                              ,(call-with-input-string
+                                   (format #f (W_ "<h1>The authorization 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))))
-- 
cgit v1.2.3