Make an authorization endpoint

6 files changed, 301 insertions, 3 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 57bd1b1..0aea0d9 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -15,7 +15,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/refresh-token.scm \
   %reldir%/oidc-id-token.scm \
   %reldir%/authorization-page.scm \
-  %reldir%/authorization-page-unsafe.scm
+  %reldir%/authorization-page-unsafe.scm \
+  %reldir%/authorization-endpoint.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
@@ -34,6 +35,7 @@ webidoidcgo_DATA += \
   %reldir%/refresh-token.go \
   %reldir%/oidc-id-token.go \
   %reldir%/authorization-page.go \
-  %reldir%/authorization-page-unsafe.go
+  %reldir%/authorization-page-unsafe.go \
+  %reldir%/authorization-endpoint.go
 
 EXTRA_DIST += %reldir%/ChangeLog
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)))))))
+
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 6a0eb0d..1270451 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -30,7 +30,10 @@ TESTS = %reldir%/load-library.scm \
   %reldir%/refresh-token.scm \
   %reldir%/too-many-refresh-tokens.scm \
   %reldir%/refresh-token-with-wrong-key.scm \
-  %reldir%/unknown-client-locale.scm
+  %reldir%/unknown-client-locale.scm \
+  %reldir%/authorization-endpoint-no-args.scm \
+  %reldir%/authorization-endpoint-get-form.scm \
+  %reldir%/authorization-endpoint-submit-form.scm
 
 EXTRA_DIST += $(TESTS) %reldir%/ChangeLog
 
diff --git a/tests/authorization-endpoint-get-form.scm b/tests/authorization-endpoint-get-form.scm
new file mode 100644
index 0000000..d6fabe9
--- /dev/null
+++ b/tests/authorization-endpoint-get-form.scm
@@ -0,0 +1,43 @@
+(use-modules (webid-oidc authorization-endpoint)
+             (webid-oidc jwk)
+             (webid-oidc testing)
+             (web uri)
+             (web request)
+             (web response)
+             (srfi srfi-19)
+             (web response)
+             (ice-9 optargs)
+             (ice-9 receive))
+
+(with-test-environment
+ "authorization-endpoint-get-form"
+ (lambda ()
+   (define alg 'RS256)
+   (define key (generate-key #:n-size 2048))
+   (define subject (string->uri "https://authorization-endpoint-get-form.scm/profile/card#me"))
+   (define password "p4ssw0rd")
+   (define validity 120)
+   (define the-time 0)
+   (define (current-time)
+     (make-time time-utc 0 the-time))
+   (define* (http-get uri #:key (headers '()))
+     (exit 2))
+   (define endpoint
+     (make-authorization-endpoint
+      subject password alg key validity
+      #:http-get http-get
+      #:current-time current-time))
+   (receive (response response-body)
+       (endpoint
+        (build-request (string->uri
+                        (format #f "https://authorization-endpoint-get-form.scm/authorize?client_id=~a&redirect_uri=~a"
+                                (uri-encode "https://authorization-endpoint-get-form.scm/client/card#app")
+                                (uri-encode "https://authorization-endpoint-get-form.scm/client/redirect"))))
+        "")
+     (unless (eq? (response-code response) 200)
+       (exit 3))
+     (unless (response-content-type response)
+       (exit 4))
+     (unless (eq? (car (response-content-type response))
+                  'application/xhtml+xml)
+       (exit 5)))))
diff --git a/tests/authorization-endpoint-no-args.scm b/tests/authorization-endpoint-no-args.scm
new file mode 100644
index 0000000..04ab575
--- /dev/null
+++ b/tests/authorization-endpoint-no-args.scm
@@ -0,0 +1,36 @@
+(use-modules (webid-oidc authorization-endpoint)
+             (webid-oidc jwk)
+             (webid-oidc testing)
+             (web uri)
+             (web request)
+             (web response)
+             (srfi srfi-19)
+             (web response)
+             (ice-9 optargs)
+             (ice-9 receive))
+
+(with-test-environment
+ "authorization-endpoint-get-form"
+ (lambda ()
+   (define alg 'RS256)
+   (define key (generate-key #:n-size 2048))
+   (define subject (string->uri "https://authorization-endpoint-get-form.scm/profile/card#me"))
+   (define password "p4ssw0rd")
+   (define validity 120)
+   (define the-time 0)
+   (define (current-time)
+     (make-time time-utc 0 the-time))
+   (define* (http-get uri #:key (headers '()))
+     (exit 2))
+   (define endpoint
+     (make-authorization-endpoint
+      subject password alg key validity
+      #:http-get http-get
+      #:current-time current-time))
+   (receive (response response-body)
+       (endpoint
+        (build-request (string->uri
+                        "https://authorization-endpoint-get-form.scm/authorize"))
+        "")
+     (unless (eq? (response-code response) 400)
+       (exit 3)))))
diff --git a/tests/authorization-endpoint-submit-form.scm b/tests/authorization-endpoint-submit-form.scm
new file mode 100644
index 0000000..156bf4e
--- /dev/null
+++ b/tests/authorization-endpoint-submit-form.scm
@@ -0,0 +1,101 @@
+(use-modules (webid-oidc authorization-endpoint)
+             (webid-oidc authorization-code)
+             (webid-oidc client-manifest)
+             (webid-oidc jwk)
+             (webid-oidc cache)
+             (webid-oidc jti)
+             (webid-oidc testing)
+             (web uri)
+             (web request)
+             (web response)
+             (srfi srfi-19)
+             (web response)
+             (ice-9 optargs)
+             (ice-9 receive))
+
+(with-test-environment
+ "authorization-endpoint-submit-form"
+ (lambda ()
+   (define alg 'RS256)
+   (define key (generate-key #:n-size 2048))
+   (define subject (string->uri "https://authorization-endpoint-submit-form.scm/profile/card#me"))
+   (define client (string->uri "https://authorization-endpoint-submit-form.scm/client/card#app"))
+   (define redirect (string->uri "https://authorization-endpoint-submit-form.scm/client/redirect"))
+   (define password "p4ssw0rd")
+   (define validity 120)
+   (define the-time 0)
+   (define (current-time)
+     (make-time time-utc 0 the-time))
+   (define what-uri-to-expect client)
+   (define served
+     (receive (response response-body)
+         (serve-client-manifest
+          (time-utc->date (make-time time-utc 0 3600))
+          (make-client-manifest client (list redirect)))
+       (cons response response-body)))
+   (define the-response (car served))
+   (define the-response-body (cdr served))
+   (define* (http-get uri #:key (headers '()))
+     (unless (equal? uri what-uri-to-expect)
+       (exit 2))
+     (values the-response the-response-body))
+   (define cached-http-get
+     (with-cache #:http-get http-get
+                 #:current-time current-time))
+   (define jti-list (make-jti-list))
+   (define endpoint
+     (make-authorization-endpoint
+      subject password alg key validity
+      #:http-get cached-http-get
+      #:current-time current-time))
+   (receive (response response-body)
+       ;; The password is fake!
+       (endpoint
+        (build-request (string->uri
+                        (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a"
+                                (uri-encode (uri->string client))
+                                (uri-encode (uri->string redirect))))
+                       #:headers '((content-type application/x-www-form-urlencoded))
+                       #:method 'POST
+                       #:port #t)
+        "password=fake")
+     (when (eq? (response-code response) 302)
+       (exit 3)))
+   (receive (response response-body)
+       (endpoint
+        (build-request (string->uri
+                        (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a"
+                                (uri-encode (uri->string client))
+                                (uri-encode (uri->string redirect))))
+                       #:headers '((content-type application/x-www-form-urlencoded))
+                       #:method 'POST
+                       #:port #t)
+        "password=p4ssw0rd")
+     (unless (eq? (response-code response) 302)
+       (exit 4))
+     (let ((loc (response-location response)))
+       (unless (uri? loc)
+         (exit 5))
+       (let ((loc-scheme (uri-scheme loc))
+             (loc-host (uri-host loc))
+             (loc-path (uri-path loc))
+             (loc-query (uri-query loc)))
+         (unless (eq? loc-scheme 'https)
+           (exit 6))
+         (unless (string=? loc-host "authorization-endpoint-submit-form.scm")
+           (exit 7))
+         (unless (string=? loc-path "/client/redirect")
+           (exit 8))
+         (let* ((kv (string-split loc-query #\&))
+                (args (map (lambda (x)
+                             (map uri-decode (string-split x #\=)))
+                           kv)))
+           (unless (assoc-ref args "code")
+             (exit 9))
+           (let ((parsed (authorization-code-decode
+                          60
+                          jti-list
+                          (car (assoc-ref args "code"))
+                          key)))
+             (unless parsed
+               (exit 10)))))))))