server: add an authenticator endpoint

3 files changed, 202 insertions, 62 deletions

diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index 77c0a81..65d64f0 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -28,6 +28,8 @@
   #:use-module ((webid-oidc server resource path) #:prefix ldp:)
   #:use-module ((webid-oidc server resource content) #:prefix ldp:)
   #:use-module (webid-oidc server precondition)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc server endpoint authentication)
   #:use-module (webid-oidc http-link)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
@@ -47,6 +49,8 @@
   #:use-module (ice-9 exceptions)
   #:use-module (sxml simple)
   #:use-module (srfi srfi-19)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
   #:declarative? #t
   #:export
   (
@@ -54,69 +58,31 @@
    make-resource-server
    ))
 
+(define-class <stub-endpoint> (<endpoint>))
+
+(define return
+  (make-parameter #f))
+
+(define-method (handle (endpoint <stub-endpoint>) request request-body)
+  ((return) (assq-ref (request-meta request) 'user)))
+
 (define* (make-authenticator #:key (server-uri #f))
   (unless (and server-uri (uri? server-uri))
     (fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri).")))
-  (lambda (request request-body)
-    (let ((headers (request-headers request))
-          (uri (request-uri request))
-          (method (request-method request))
-          (current-time ((p:current-date))))
-      (parameterize ((web-locale request)
-                     (p:current-date current-time)) ;; fix the date
-        (let ((authz (assoc-ref headers 'authorization))
-              (dpop (assoc-ref headers 'dpop))
-              (full-uri (build-uri (uri-scheme server-uri)
-                                   #:userinfo (uri-userinfo server-uri)
-                                   #:host (uri-host server-uri)
-                                   #:port (uri-port server-uri)
-                                   #:path (string-append
-                                           "/"
-                                           (encode-and-join-uri-path
-                                            (append
-                                             (split-and-decode-uri-path (uri-path server-uri))
-                                             (split-and-decode-uri-path
-                                              (uri-path uri))))))))
-          (and authz dpop
-               (eq? (car authz) 'dpop)
-               (with-exception-handler
-                   (lambda (error)
-                     (if (exception-with-message? error)
-                         (format (current-error-port)
-                                 (G_ "~a: authentication failure: ~a\n")
-                                 (date->string current-time)
-                                 (exception-message error))
-                         (format (current-error-port)
-                                 (G_ "~a: authentication failure\n")
-                                 (date->string current-time)))
-                     #f)
-                 (lambda ()
-                   ;; Sometimes the access is the cadr as a symbol,
-                   ;; sometimes it is the cdr as a string. It depends
-                   ;; whether the response has been written and read,
-                   ;; or preserved as a guile object.
-                   (let* ((lit-access-token
-                           (match authz
-                             ;; That’s when the request is parsed:
-                             (('dpop (? symbol? symbol-value))
-                              (symbol->string symbol-value))
-                             ;; That’s when it’s not:
-                             (('dpop . (? string? string-value))
-                              string-value)))
-                          (access-token
-                           (decode <access-token> lit-access-token))
-                          (cnf/jkt (cnf/jkt access-token))
-                          (dpop-proof
-                           (decode <dpop-proof> dpop
-                                   #:method method
-                                   #:uri full-uri
-                                   #:cnf/check cnf/jkt
-                                   #:access-token lit-access-token)))
-                     (let ((subject (webid access-token))
-                           (issuer (iss access-token)))
-                       (confirm-provider subject issuer)
-                       subject)))
-                 #:unwind? #t)))))))
+  (let* ((backend (make <stub-endpoint>))
+         (endpoint (make <authenticator>
+                     #:backend backend
+                     #:server-uri server-uri)))
+    (lambda (request request-body)
+      (parameterize ((web-locale request))
+        (with-exception-handler
+            (lambda (error)
+              #f)
+          (lambda ()
+            (let/ec ret
+              (parameterize ((return ret))
+                (handle endpoint request request-body))))
+          #:unwind? #t)))))
 
 (define (handle-errors f g)
   (call/ec
diff --git a/src/scm/webid-oidc/server/endpoint/Makefile.am b/src/scm/webid-oidc/server/endpoint/Makefile.am
index ba4799a..51dee79 100644
--- a/src/scm/webid-oidc/server/endpoint/Makefile.am
+++ b/src/scm/webid-oidc/server/endpoint/Makefile.am
@@ -15,7 +15,9 @@
 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 dist_endpointserverwebidoidcmod_DATA += \
-  %reldir%/reverse-proxy.scm
+  %reldir%/reverse-proxy.scm \
+  %reldir%/authentication.scm
 
 endpointserverwebidoidcgo_DATA += \
-  %reldir%/reverse-proxy.go
+  %reldir%/reverse-proxy.go \
+  %reldir%/authentication.go
diff --git a/src/scm/webid-oidc/server/endpoint/authentication.scm b/src/scm/webid-oidc/server/endpoint/authentication.scm
new file mode 100644
index 0000000..5a22f48
--- /dev/null
+++ b/src/scm/webid-oidc/server/endpoint/authentication.scm
@@ -0,0 +1,172 @@
+;; disfluid, implementation of the Solid specification
+;; Copyright (C) 2021  Vivien Kraus
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (webid-oidc server endpoint authentication)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc access-token)
+  #:use-module (webid-oidc dpop-proof)
+  #:use-module (webid-oidc provider-confirmation)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module ((webid-oidc config) #:prefix cfg:)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (web server)
+  #:use-module (web client)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module (ice-9 getopt-long)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:use-module (sxml simple)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
+  #:declarative? #t
+  #:export
+  (
+   <authenticator>
+   backend
+   server-uri
+   ))
+
+(define-class <authenticator> (<endpoint>)
+  (backend #:init-keyword #:backend #:getter backend)
+  (server-uri #:init-keyword #:server-uri #:getter server-uri))
+
+(define-method (initialize (endpoint <authenticator>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((backend #f)
+    (server-uri #f))
+   (unless (is-a? backend <endpoint>)
+     (scm-error 'wrong-type-arg "make <authenticator>"
+                (G_ "#:backend should be an endpoint")
+                '()
+                (list backend)))
+   (match server-uri
+     ((? string? (= string->uri (? uri? the-server-uri)))
+      (set! server-uri the-server-uri)
+      (slot-set! endpoint 'server-uri the-server-uri))
+     (else #t))
+   (unless (and server-uri (uri? server-uri))
+     (scm-error 'wrong-type-arg "make <authenticator>"
+                (G_ "#:server-uri should be an URI")
+                '()
+                (list server-uri)))))
+
+(define-method (handle (endpoint <authenticator>) request request-body)
+  (define accumulated-error '())
+  (let ((headers (request-headers request))
+        (uri (request-uri request))
+        (method (request-method request)))
+    (let ((authz (assq-ref headers 'authorization))
+          (dpop (assq-ref headers 'dpop))
+          (full-uri
+           (let ((server-uri (server-uri endpoint)))
+             (build-uri (uri-scheme server-uri)
+                        #:userinfo (uri-userinfo server-uri)
+                        #:host (uri-host server-uri)
+                        #:port (uri-port server-uri)
+                        #:path
+                        (string-append
+                         (if (and (equal? (uri-path server-uri) "")
+                                  (equal? (uri-path uri) ""))
+                             ""
+                             ;; It must start with a / then
+                             "/")
+                         (encode-and-join-uri-path
+                          (append
+                           (split-and-decode-uri-path (uri-path server-uri))
+                           (split-and-decode-uri-path (uri-path uri))))
+                         (if (string-suffix? (uri-path uri) "/")
+                             "/"
+                             ""))))))
+      (let ((user
+             (and authz dpop
+                  (eq? (car authz) 'dpop)
+                  (with-exception-handler
+                      (lambda (error)
+                        (if (exception-with-message? error)
+                            (format (current-error-port)
+                                    (G_ "~a: authentication failure: ~a\n")
+                                    (date->string ((p:current-date)))
+                                    (exception-message error))
+                            (format (current-error-port)
+                                    (G_ "~a: authentication failure\n")
+                                    (date->string ((p:current-date)))))
+                        (set! accumulated-error
+                              (make-exception
+                               (make-user-message
+                                (call-with-input-string
+                                    (format #f (W_ "<p>There is an access token and a DPoP proof, but one or both is invalid.</p>"))
+                                  xml->sxml))
+                               error))
+                        #f)
+                    (lambda ()
+                      ;; Sometimes the access is the cadr as a symbol,
+                      ;; sometimes it is the cdr as a string. It depends
+                      ;; whether the response has been written and read,
+                      ;; or preserved as a guile object.
+                      (let* ((lit-access-token
+                              (match authz
+                                ;; That’s when the request is parsed:
+                                (('dpop (? symbol? symbol-value))
+                                 (symbol->string symbol-value))
+                                ;; That’s when it’s not:
+                                (('dpop . (? string? string-value))
+                                 string-value)))
+                             (access-token
+                              (decode <access-token> lit-access-token))
+                             (cnf/jkt (cnf/jkt access-token))
+                             (dpop-proof
+                              (decode <dpop-proof> dpop
+                                      #:method method
+                                      #:uri full-uri
+                                      #:cnf/check cnf/jkt
+                                      #:access-token lit-access-token)))
+                        (let ((subject (webid access-token))
+                              (issuer (iss access-token)))
+                          (confirm-provider subject issuer)
+                          subject)))
+                    #:unwind? #t))))
+        (with-exception-handler
+            (lambda (exn)
+              ;; Since a 401 might be returned normally or raised as
+              ;; an exception, we won’t add the header to authenticate
+              ;; with DPoP in this layer.
+              (raise-exception
+               (apply make-exception
+                      exn
+                      (make-caused-by-user user)
+                      accumulated-error)))
+          (lambda ()
+            (receive (response response-body meta)
+                (handle (backend endpoint)
+                        (build-request (request-uri request)
+                                       #:method (request-method request)
+                                       #:headers (request-headers request)
+                                       #:port (request-port request)
+                                       #:meta `((user . ,user)
+                                                ,@(request-meta request)))
+                        request-body)
+              (values response response-body `((user . ,user) ,@meta)))))))))