Implement the resource server verification code

8 files changed, 242 insertions, 9 deletions

diff --git a/doc/manual.html b/doc/manual.html
index 51d524b..d010685 100644
--- a/doc/manual.html
+++ b/doc/manual.html
@@ -981,6 +981,60 @@
       generator. You can safely delete this directory, but you need to
       restart the program to actually change the seed.
     </p>
+    <h1>Running a Resource Server</h1>
+    <p>
+      A Solid server is the server that manages your data. It needs to
+      check that the proofs of possession are correct, and the
+      possessed key is signed by the identity provider.
+    </p>
+    <h2>The authenticator</h2>
+    <p>
+      In <emph>(webid-oidc&#160;jws)</emph>, the following function
+      gives a simple API for a web server:
+    </p>
+    <info:deffn type="function"
+                name="make-authenticator"
+                arguments="jti-list [#server-uri] [#current-time] [#http-get]">
+      <p>
+        Create an authenticator, i.e. a function that takes a request
+        and request body and returns the webid of the authenticated
+        user, or <pre>#f</pre> if it is not authenticated.
+      </p>
+      <p>
+        To prevent replay attacks, each request is signed by the
+        client with a different unique padding value. If such a value
+        has already been seen, then the request must fail.
+      </p>
+      <p>
+        The authenticator expects the client to demonstrate the
+        possession of a key that the identity provider knows. So the
+        client creates a DPoP proof, targetted to a specific URI. In
+        order to check that the URI is correct, the authenticator
+        needs the public URI of the service.
+      </p>
+      <p>
+        The JTIs are checked within a small time frame. By default,
+        the system time will be used. Otherwise, you can customize the
+        <pre>current-time</pre> optional keyword argument, to pass a
+        thunk returning a time from <emph>(srfi srfi-19)</emph>.
+      </p>
+      <p>
+        You may want to customize the <info:var>http-get</info:var>
+        optional keyword argument to pass a function to replace
+        <pre>http-get</pre> from <emph>(http client)</emph>. This
+        function takes an URI and optional <pre>#:headers</pre>
+        arguments, makes the request, and return two values: the
+        response, and the response body.
+      </p>
+      <p>
+        This function, in
+        <emph>(webid-oidc&#160;resource-server)</emph>, returns a web
+        request handler, taking the request and request body, and
+        returning the subject of the access token. If an error
+        happens, it is thrown; the function always returns a valid
+        URI.
+      </p>
+    </info:deffn>
 
     <h1 type="appendix">GNU Free Documentation License</h1>
     <info:gfdl />
diff --git a/po/POTFILES.in b/po/POTFILES.in
index ed66784..97cf2cf 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -9,3 +9,4 @@ src/hash/libwebidoidc-hash.c
 src/scm/webid-oidc/errors.scm
 src/scm/webid-oidc/identity-provider.scm
 src/scm/webid-oidc/authorization-page-unsafe.scm
+src/scm/webid-oidc/resource-server.scm
\ No newline at end of file
diff --git a/po/fr.po b/po/fr.po
index b85be49..ae64e42 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -2,7 +2,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: webid-oidc 0.0.0\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-05-10 22:58+0200\n"
+"POT-Creation-Date: 2021-05-10 22:59+0200\n"
 "PO-Revision-Date: 2021-05-10 14:31+0200\n"
 "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n"
 "Language-Team: French <vivien@planete-kraus.eu>\n"
@@ -1087,6 +1087,11 @@ msgstr ""
 "<a href=~s>~a</a> peut maintenant s'identifier en votre nom. Vous devez "
 "toujours ajuster ses permissions."
 
+#: src/scm/webid-oidc/resource-server.scm:68
+#, scheme-format
+msgid "~a: authentication failure: ~a\n"
+msgstr "~a : échec d’authentificationn : ~a\n"
+
 #, scheme-format
 #~ msgid ""
 #~ "~a is neither an identity provider (because ~a) nor a webid (because ~a)"
@@ -1116,10 +1121,6 @@ msgstr ""
 #~ msgid ", "
 #~ msgstr ", "
 
-#, scheme-format
-#~ msgid "~a: authentication failure: ~a\n"
-#~ msgstr "~a : échec d’authentificationn : ~a\n"
-
 #~ msgid "command-line|help"
 #~ msgstr "aide"
 
diff --git a/po/webid-oidc.pot b/po/webid-oidc.pot
index 2aafbac..87f9f50 100644
--- a/po/webid-oidc.pot
+++ b/po/webid-oidc.pot
@@ -8,7 +8,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: webid-oidc SNAPSHOT\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-05-10 22:58+0200\n"
+"POT-Creation-Date: 2021-05-10 22:59+0200\n"
 "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
 "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
 "Language-Team: LANGUAGE <LL@li.org>\n"
@@ -990,3 +990,8 @@ msgid ""
 "<a href=~s>~a</a> can now log in on your behalf. You still need to adjust "
 "permissions."
 msgstr ""
+
+#: src/scm/webid-oidc/resource-server.scm:68
+#, scheme-format
+msgid "~a: authentication failure: ~a\n"
+msgstr ""
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 42c65b6..061af17 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -19,7 +19,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/authorization-endpoint.scm \
   %reldir%/token-endpoint.scm \
   %reldir%/identity-provider.scm \
-  %reldir%/provider-confirmation.scm
+  %reldir%/provider-confirmation.scm \
+  %reldir%/resource-server.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
@@ -42,6 +43,7 @@ webidoidcgo_DATA += \
   %reldir%/authorization-endpoint.go \
   %reldir%/token-endpoint.go \
   %reldir%/identity-provider.go \
-  %reldir%/provider-confirmation.go
+  %reldir%/provider-confirmation.go \
+  %reldir%/resource-server.go
 
 EXTRA_DIST += %reldir%/ChangeLog
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
new file mode 100644
index 0000000..25523ac
--- /dev/null
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -0,0 +1,85 @@
+(define-module (webid-oidc resource-server)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc oidc-configuration)
+  #:use-module (webid-oidc provider-confirmation)
+  #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc dpop-proof)
+  #:use-module ((webid-oidc config) #:prefix cfg:)
+  #:use-module (webid-oidc jti)
+  #:use-module (webid-oidc access-token)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (web server)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 i18n)
+  #:use-module (ice-9 getopt-long)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module (sxml simple)
+  #:use-module (srfi srfi-19))
+
+(define (G_ text)
+  (let ((out (gettext text)))
+    (if (string=? out text)
+        ;; No translation, disambiguate
+        (car (reverse (string-split text #\|)))
+        out)))
+
+(define*-public (make-authenticator jti-list
+                                    #:key
+                                    (server-uri #f)
+                                    (current-time current-time)
+                                    (http-get http-get))
+  (unless (and server-uri (uri? server-uri))
+    (error "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
+           (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)))
+      (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)
+                   (format (current-error-port)
+                           (G_ "~a: authentication failure: ~a\n")
+                           (date->string current-time)
+                           (error->str error))
+                   #f)
+               (lambda ()
+                 (let* ((access-token
+                         (access-token-decode
+                          (symbol->string (cadr authz))
+                          #:http-get http-get))
+                        (cnf/jkt (access-token-cnf/jkt access-token))
+                        (dpop-proof
+                         (dpop-proof-decode
+                          current-time jti-list method full-uri
+                          dpop cnf/jkt)))
+                   (let ((subject (access-token-webid access-token))
+                         (issuer (access-token-iss access-token)))
+                     (confirm-provider subject issuer #:http-get http-get)
+                     subject)))
+               #:unwind? #t))))))
diff --git a/tests/Makefile.am b/tests/Makefile.am
index ba64f00..0ea5390 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -36,7 +36,8 @@ TESTS = %reldir%/load-library.scm \
   %reldir%/authorization-endpoint-submit-form.scm \
   %reldir%/token-endpoint-issue.scm \
   %reldir%/token-endpoint-refresh.scm \
-  %reldir%/provider-confirmation.scm
+  %reldir%/provider-confirmation.scm \
+  %reldir%/resource-server.scm
 
 EXTRA_DIST += $(TESTS) %reldir%/ChangeLog
 
diff --git a/tests/resource-server.scm b/tests/resource-server.scm
new file mode 100644
index 0000000..52a08b7
--- /dev/null
+++ b/tests/resource-server.scm
@@ -0,0 +1,84 @@
+(use-modules (webid-oidc provider-confirmation)
+             (webid-oidc jti)
+             (webid-oidc jwk)
+             (webid-oidc jws)
+             (webid-oidc oidc-configuration)
+             (webid-oidc access-token)
+             (webid-oidc dpop-proof)
+             (webid-oidc resource-server)
+             (webid-oidc testing)
+             (web uri)
+             (web request)
+             (srfi srfi-19)
+             (web response)
+             (ice-9 optargs)
+             (ice-9 receive))
+
+(with-test-environment
+ "resource-server"
+ (lambda ()
+   (define jti (make-jti-list))
+   (define client-key (generate-key #:n-size 2048))
+   (define idp-key (generate-key #:n-size 2048))
+   (define jwks (make-jwks (list idp-key)))
+   (define jwks-uri (string->uri "https://identity.provider/keys"))
+   (define oidc-config
+     (make-oidc-configuration
+      jwks-uri
+      (string->uri "https://identity.provider/authorize")
+      (string->uri "https://identity.provider/token")))
+   (define oidc-config-uri
+     (string->uri
+      "https://identity.provider/.well-known/openid-configuration"))
+   (define subject (string->uri "https://identity.provider/subject#me"))
+   (define* (http-get uri #:key (headers '()))
+     (define exp (time-utc->date (make-time time-utc 0 3600)))
+     (cond ((equal? uri oidc-config-uri)
+            (serve-oidc-configuration exp oidc-config))
+           ((equal? uri jwks-uri)
+            (serve-jwks exp jwks))
+           (else (exit 1))))
+   (define access-token
+     (issue-access-token
+      idp-key
+      #:alg 'RS256
+      #:webid subject
+      #:iss "https://identity.provider"
+      #:iat 10
+      #:exp 3610
+      #:client-key client-key
+      #:client-id "https://client"))
+   (define uri (string->uri "https://resource.server/resource"))
+   (define server-uri (string->uri "https://resource.server/"))
+   (define method 'GET)
+   (define dpop-proof
+     (issue-dpop-proof
+      client-key
+      #:alg 'RS256
+      #:htm method
+      #:htu uri
+      #:iat (time-utc->date (make-time time-utc 0 15))))
+   (define rq
+     (call-with-input-string
+         (format #f "GET /resource HTTP/1.1\r\n\
+Host: resource.server\r\n\
+User-Agent: Test Suite\r\n\
+Upgrade-Insecure-Requests: 1\r\n\
+Cache-Control: max-age=0\r\n\
+Authorization: DPoP ~a\r\n\
+DPoP: ~a\r\n\r\n"
+                 access-token
+                 dpop-proof)
+       read-request))
+   (define rq-body "")
+   (define authenticator
+     (make-authenticator
+      jti
+      #:server-uri server-uri
+      #:current-time (lambda () (make-time time-utc 0 20))
+      #:http-get http-get))
+   (define parsed (authenticator rq rq-body))
+   (unless (uri? parsed)
+     (exit 2))
+   (unless (equal? parsed subject)
+     (exit 3))))