diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-09 18:46:48 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-13 01:06:38 +0200 |
commit | ded10e28782f289ad3db15320bcf619ab4336876 (patch) | |
tree | 32609fd9f1eb0d2f8a23105e09f193827d16a275 /src/scm/webid-oidc/authorization-endpoint.scm | |
parent | 7b62790238902e10edb83c07286cf0643b097997 (diff) |
Switch to a more sensible error reporting system
Diffstat (limited to 'src/scm/webid-oidc/authorization-endpoint.scm')
-rw-r--r-- | src/scm/webid-oidc/authorization-endpoint.scm | 121 |
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 |