Implement the resource server verification code

8 files changed, 238 insertions, 9 deletions

diff --git a/doc/webid-oidc.texi b/doc/webid-oidc.texi
index 850e2be..6a0e633 100644
--- a/doc/webid-oidc.texi
+++ b/doc/webid-oidc.texi
@@ -50,6 +50,7 @@ Free Documentation License''
 * The Json Web Token::
 * Caching on server side::
 * Running an Identity Provider::
+* Running a Resource Server::
 * Exceptional conditions::
 * GNU Free Documentation License::
 * Index::
@@ -433,6 +434,54 @@ starts to require the random number generator. You can safely delete
 this directory, but you need to restart the program to actually change
 the seed.
 
+@node Running a Resource Server
+@chapter Running a Resource Server
+
+@menu
+* The authenticator::
+@end menu
+
+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.
+
+@node The authenticator
+@section The authenticator
+
+In @emph{(webid-oidc jws)}, the following function gives a simple API
+for a web server:
+
+@deffn function make-authenticator @var{jti-list} @var{[#server-uri]} @var{[#current-time]} @var{[#http-get]}
+Create an authenticator, i.e. a function that takes a request and
+request body and returns the webid of the authenticated user, or
+@code{#f} if it is not authenticated.
+
+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.
+
+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.
+
+The JTIs are checked within a small time frame. By default, the system
+time will be used. Otherwise, you can customize the
+@code{current-time} optional keyword argument, to pass a thunk
+returning a time from @emph{(srfi srfi-19)}.
+
+You may want to customize the @var{http-get} optional keyword argument
+to pass a function to replace @code{http-get} from @emph{(http
+client)}. This function takes an URI and optional @code{#:headers}
+arguments, makes the request, and return two values: the response, and
+the response body.
+
+This function, in @emph{(webid-oidc resource-server)}, 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.
+@end deffn
+
 @node Exceptional conditions
 @chapter Exceptional conditions
 
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 d1b20d9..0ccfc49 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-06-05 16:18+0200\n"
+"POT-Creation-Date: 2021-06-05 16:19+0200\n"
 "PO-Revision-Date: 2021-06-05 11:07+0200\n"
 "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n"
 "Language-Team: French <vivien@planete-kraus.eu>\n"
@@ -1089,6 +1089,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)"
@@ -1172,10 +1177,6 @@ msgstr ""
 #~ msgid "there is an external error"
 #~ msgstr "il y a une erreur externe"
 
-#, 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 def4d61..59c3286 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-06-05 16:18+0200\n"
+"POT-Creation-Date: 2021-06-05 16:19+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..cef6a0c
--- /dev/null
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -0,0 +1,86 @@
+(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 (web client)
+  #: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))))