Switch to a more sensible error reporting system

1 files changed, 67 insertions, 54 deletions

diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm
index 4786a7a..86a8a4d 100644
--- a/src/scm/webid-oidc/authorization-endpoint.scm
+++ b/src/scm/webid-oidc/authorization-endpoint.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
@@ -27,16 +27,25 @@
   #:use-module (web response)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 receive)
-  #:use-module (ice-9 optargs))
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 match)
+  #:declarative? #t
+  #:export
+  (
+
+   make-authorization-endpoint
+
+   ))
 
 (define (verify-password encrypted-password password)
   (let ((c (crypt password encrypted-password)))
     (string=? c encrypted-password)))
 
-(define*-public (make-authorization-endpoint subject encrypted-password alg jwk validity
-                                             #:key
-                                             (http-get http-get))
+(define* (make-authorization-endpoint subject encrypted-password alg jwk validity
+                                      #:key
+                                      (http-get http-get))
   (define (parse-arg x decode-plus-to-space?)
     (map (lambda (x) (uri-decode
                       x
@@ -51,35 +60,40 @@
            (query-parts (if query
                             (string-split query #\&)
                             '()))
-           (get-args (map (lambda (x) (parse-arg x #f)) query-parts))
+           (get-args (map (cute parse-arg <> #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))
-                '()))
+            (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 (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
-                (string->uri (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)))
+           (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))
@@ -92,30 +106,29 @@
               (lambda (error)
                 (error-application locale error))
             (lambda ()
-              (let* ((current-time ((p:current-date))) ;; current-date is a thunk parameter
-                     (current-sec
-                      (time-second (date->time-utc 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 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 client-id uri))))))
+              (let ((code (issue-authorization-code
+                           jwk
+                           #:alg alg
+                           #:webid subject
+                           #:client-id client-id))
+                    (mf (get-client-manifest 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 client-id uri)))))
             #:unwind? #t))
          (else
           (authorization-page locale