1 files changed, 101 insertions, 0 deletions
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)))))))))