Implement the token endpoint

4 files changed, 216 insertions, 2 deletions

diff --git a/src/scm/webid-oidc/ChangeLog b/src/scm/webid-oidc/ChangeLog
index 1223e69..8ce40eb 100644
--- a/src/scm/webid-oidc/ChangeLog
+++ b/src/scm/webid-oidc/ChangeLog
@@ -1,3 +1,10 @@
+2021-05-07  Vivien Kraus  <vivien@planete-kraus.eu>
+
+	* token-endpoint.scm (make-token-endpoint): The token endpoint
+	needs to know its public URI, because if it is behind a reverse
+	proxy we can’t rely on (request-uri request); and it will fail
+	DPoP validation.
+
 2021-04-30  Vivien Kraus  <vivien@planete-kraus.eu>
 
 	* reverse-proxy.scm (make-reverse-proxy): Make the auth header
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 0aea0d9..8436089 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -16,7 +16,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/oidc-id-token.scm \
   %reldir%/authorization-page.scm \
   %reldir%/authorization-page-unsafe.scm \
-  %reldir%/authorization-endpoint.scm
+  %reldir%/authorization-endpoint.scm \
+  %reldir%/token-endpoint.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
@@ -36,6 +37,7 @@ webidoidcgo_DATA += \
   %reldir%/oidc-id-token.go \
   %reldir%/authorization-page.go \
   %reldir%/authorization-page-unsafe.go \
-  %reldir%/authorization-endpoint.go
+  %reldir%/authorization-endpoint.go \
+  %reldir%/token-endpoint.go
 
 EXTRA_DIST += %reldir%/ChangeLog
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 714e0be..4b4ba2d 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -788,6 +788,36 @@
    ((record-constructor &unknown-client-locale) web-locale c-locale)
    #:continuable? #t))
 
+(define-public &unsupported-grant-type
+  (make-exception-type
+   '&unsupported-grant-type
+   &external-error
+   '(value)))
+
+(define-public (raise-unsupported-grant-type value)
+  (raise-exception
+   ((record-constructor &unsupported-grant-type) value)))
+
+(define-public &no-authorization-code
+  (make-exception-type
+   '&no-authorization-code
+   &external-error
+   '(value)))
+
+(define-public (raise-no-authorization-code)
+  (raise-exception
+   ((record-constructor &no-authorization-code))))
+
+(define-public &no-refresh-token
+  (make-exception-type
+   '&no-refresh-token
+   &external-error
+   '(value)))
+
+(define-public (raise-no-refresh-token)
+  (raise-exception
+   ((record-constructor &no-refresh-token))))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -1089,6 +1119,13 @@
           ((&cannot-encode-id-token)
            (format #f (G_ "I cannot encode ~s as an ID token (because ~a)")
                    (get 'value) (recurse (get 'cause))))
+          ((&unsupported-grant-type)
+           (format #f (G_ "the grant type ~s is not supported")
+                   (get 'value)))
+          ((&no-authorization-code)
+           (format #f (G_ "there is no authorization code in the request")))
+          ((&no-refresh-token)
+           (format #f (G_ "there is no refresh token in the request")))
           ((&not-an-id-token)
            (format #f (G_ "~s is not an ID token (because ~a)")
                    (get 'value) (recurse (get 'cause))))
diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm
new file mode 100644
index 0000000..422bac6
--- /dev/null
+++ b/src/scm/webid-oidc/token-endpoint.scm
@@ -0,0 +1,168 @@
+(define-module (webid-oidc token-endpoint)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc authorization-code)
+  #:use-module (webid-oidc dpop-proof)
+  #:use-module (webid-oidc jws)
+  #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc oidc-id-token)
+  #:use-module (webid-oidc access-token)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-19)
+  #:use-module (rnrs bytevectors))
+
+(define (try-handle-web-failure thunk)
+  (define (error->str err)
+    (if (record? err)
+        (let* ((type (record-type-descriptor err))
+               (get
+                (lambda (slot)
+                  ((record-accessor type slot) err)))
+               (recurse
+                (lambda (err)
+                  (error->str err))))
+          (case (record-type-name type)
+            ((&cannot-decode-dpop-proof)
+             (format #f "the DPoP proof is invalid"))
+            ((&no-authorization-code)
+             (format #f "there is no authorization code in the request"))
+            ((&no-refresh-token)
+             (format #f "there is no refresh token in the request"))
+            ((&cannot-decode-authorization-code)
+             (format #f "the authorization code is invalid"))
+            ((&invalid-refresh-token)
+             (format #f "the refresh token is invalid"))
+            ((&invalid-key-for-refresh-token)
+             (format #f "the refresh token is bound to another key"))
+            ((&unsupported-grant-type)
+             (format #f "the grant type ~s is not supported" (get 'value)))
+            (else
+             (raise-exception err))))
+        (throw err)))
+  (with-exception-handler
+      (lambda (error)
+        (values
+         (build-response
+          #:code 400
+          #:reason-phrase (string-append "Bad Request: " (error->str error)))
+         (error->str error)))
+    thunk
+    #:unwind? #t))
+
+(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity jti-list
+                                     #:key
+                                     (refresh-token-dir refresh:default-dir)
+                                     (current-time current-time))
+  (lambda* (request request-body)
+    (try-handle-web-failure
+     (lambda ()
+       (when (bytevector? request-body)
+         (set! request-body (utf8->string request-body)))
+       (let ((current-time
+              (let ((t current-time))
+                (when (thunk? t)
+                  (set! t (t)))
+                (when (integer? t)
+                  (set! t (make-time time-utc 0 t)))
+                (when (time? t)
+                  (set! t (time-utc->date t)))
+                t))
+             (form-args
+              (if (and (request-content-type request)
+                       (eq? (car (request-content-type request))
+                            'application/x-www-form-urlencoded))
+                  (filter
+                   (lambda (x) x)
+                   (map (lambda (kv)
+                          (let ((parsed
+                                 (list->vector
+                                  (map (lambda (x)
+                                         (uri-decode x #:decode-plus-to-space? #t))
+                                       (string-split kv #\=)))))
+                            (if (eq? (vector-length parsed) 2)
+                                `(,(vector-ref parsed 0) . ,(vector-ref parsed 1))
+                                #f)))
+                        (string-split request-body #\&)))
+                  '()))
+             (method (request-method request))
+             ;; Maybe we’re behind a reverse proxy, so the authority of
+             ;; (request-uri request) is meaningless.
+             (uri (build-uri (uri-scheme token-endpoint-uri)
+                             #:userinfo (uri-userinfo token-endpoint-uri)
+                             #:host (uri-host token-endpoint-uri)
+                             #:port (uri-port token-endpoint-uri)
+                             #:path (uri-path (request-uri request))
+                             #:query (uri-query (request-uri request)))))
+         (let ((grant-type (assoc-ref form-args "grant_type"))
+               (dpop (dpop-proof-decode
+                      current-time jti-list method uri
+                      (assq-ref (request-headers request) 'dpop)
+                      (lambda (jkt) #t))))
+           (unless (and grant-type (string? grant-type))
+             (raise-unsupported-grant-type #f))
+           (receive (webid client-id)
+               (case (string->symbol grant-type)
+                 ((authorization_code)
+                  (let ((code
+                         (let ((str (assoc-ref form-args "code")))
+                           (unless str
+                             (raise-no-authorization-code))
+                           (authorization-code-decode
+                            current-time jti-list str jwk))))
+                    (values (authorization-code-webid code)
+                            (authorization-code-client-id code))))
+                 ((refresh_token)
+                  (let ((refresh-token (assoc-ref form-args "refresh_token")))
+                    (unless refresh-token
+                      (raise-no-refresh-token))
+                    (refresh:with-refresh-token
+                     refresh-token
+                     (dpop-proof-jwk dpop)
+                     values
+                     #:dir refresh-token-dir)))
+                 (else
+                  (raise-unsupported-grant-type grant-type)))
+             (let* ((iat (time-second (date->time-utc current-time)))
+                    (exp (+ iat validity)))
+               (let ((id-token
+                      (issue-id-token
+                       jwk
+                       #:alg alg
+                       #:webid (uri->string webid)
+                       #:sub (uri->string webid)
+                       #:iss (uri->string iss)
+                       #:aud (uri->string client-id)
+                       #:exp exp
+                       #:iat iat))
+                     (access-token
+                      (issue-access-token
+                       jwk
+                       #:alg alg
+                       #:webid (uri->string webid)
+                       #:iss (uri->string iss)
+                       #:exp exp
+                       #:iat iat
+                       #:client-key (dpop-proof-jwk dpop)
+                       #:client-id (uri->string client-id)))
+                     (refresh-token
+                      (if (equal? grant-type "refresh_token")
+                          (assoc-ref form-args "refresh_token")
+                          (refresh:issue-refresh-token webid client-id
+                                                       (jkt (dpop-proof-jwk dpop))
+                                                       #:dir refresh-token-dir))))
+                 (values
+                  (build-response #:headers '((content-type application/json)
+                                              (cache-control (no-cache no-store)))
+                                  #:port #f)
+                  (stubs:scm->json-string
+                   `((id_token . ,id-token)
+                     (access_token . ,access-token)
+                     (token_type . "DPoP")
+                     (expires_in . ,validity)
+                     (refresh_token . ,refresh-token)))))))))))))