From 94dd29912cf969321870921c752a80c4e984b6aa Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Fri, 4 Dec 2020 19:23:04 +0100
Subject: Make an authorization endpoint

---
 src/scm/webid-oidc/authorization-endpoint.scm | 113 ++++++++++++++++++++++++++
 1 file changed, 113 insertions(+)
 create mode 100644 src/scm/webid-oidc/authorization-endpoint.scm

(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
new file mode 100644
index 0000000..8dfa71f
--- /dev/null
+++ b/src/scm/webid-oidc/authorization-endpoint.scm
@@ -0,0 +1,113 @@
+(define-module (webid-oidc authorization-endpoint)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc authorization-page)
+  #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc authorization-code)
+  #:use-module (webid-oidc client-manifest)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs))
+
+(define*-public (make-authorization-endpoint subject the-password alg jwk validity
+                                             #:key
+                                             (http-get http-get)
+                                             (current-time current-time))
+  (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)
+    (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 (lambda (x) (parse-arg x #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))
+                '()))
+           (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 (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)))
+        (cond
+         ((not client-id)
+          (error-no-client-id locale))
+         ((not redirect-uri)
+          (error-no-redirect-uri locale))
+         ((and (eq? method 'POST)
+               (string? password)
+               (string=? password the-password))
+          (with-exception-handler
+              (lambda (error)
+                (error-application locale error))
+            (lambda ()
+              (let* ((current-time (if (thunk? current-time)
+                                       (current-time)
+                                       current-time))
+                     (current-sec
+                      (cond ((date? current-time)
+                             (time-second (date->time-utc current-time)))
+                            ((time? current-time)
+                             (time-second current-time))
+                            ((integer? current-time)
+                             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 (string->uri 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
+                                   (string->uri client-id)
+                                   uri))))))
+            #:unwind? #t))
+         (else
+          (authorization-page locale
+                              (not (and password
+                                        (string=? password the-password)))
+                              client-id
+                              uri)))))))
+
-- 
cgit v1.2.3