Add a full server.

2 files changed, 259 insertions, 8 deletions

diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm
index c53be5d..2ab1cbe 100644
--- a/src/scm/webid-oidc/program.scm
+++ b/src/scm/webid-oidc/program.scm
@@ -3,6 +3,8 @@
   #:use-module (webid-oidc reverse-proxy)
   #:use-module (webid-oidc identity-provider)
   #:use-module (webid-oidc client)
+  #:use-module (webid-oidc resource-server)
+  #:use-module (webid-oidc server create)
   #:use-module (webid-oidc jti)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
@@ -145,6 +147,9 @@ Available commands:
     run an identity provider.
   ~a:
     serve the pages for a public application.
+  ~a:
+    run a full server, with identity provider and resource storage
+    facility.
 
 General options:
   -h, --~a:
@@ -162,10 +167,11 @@ General server-side options:
   -n URI, --~a=URI:
     set the public server URI (scheme, userinfo, host, and port).
 
-Options for the reverse proxy:
+Options for the resource server:
   -H HEADER, --~a=HEADER:
     the HEADER field contains the webid of the authenticated user,
-    XXX-Agent by default.
+    XXX-Agent by default. For the full server, disable webid-oidc
+    authentication.
   -b URI, --~a=URI:
     set the backend URI for the reverse proxy, only for the
     reverse-proxy command.
@@ -204,8 +210,9 @@ Environment variables:
 the user is the system administrator).~a
 
   XDG_DATA_HOME: where the program stores persistent data. The
-identity provider stores the refresh tokens. For a system service, it
-is recommended to set it to /var/lib.~a
+identity provider stores the refresh tokens. The full server stores
+the resources there. For a system service, it is recommended to set it
+to /var/lib.~a
 
   XDG_CACHE_HOME: where the program stores and updates the seed file,
 and the web client cache. You can remove this directory at any
@@ -270,6 +277,7 @@ If you find a bug, then please send a report to ~a.
                 (G_ "command-line|command|reverse-proxy")
                 (G_ "command-line|command|identity-provider")
                 (G_ "command-line|command|client-service")
+                (G_ "command-line|command|server")
                 ;; General options
                 ;; help
                 help-sym
@@ -509,7 +517,75 @@ If you find a bug, then please send a report to ~a.
                    (handler-with-log handler)
                    'http
                    (list #:port port)))))
-              (else
-               (format (current-error-port) (G_ "Unknown command ~s\n")
-                       command)
-               (exit 1))))))))))
+             ((equal? command (G_ "command-line|command|server"))
+              (unless server-name
+                (format (current-error-port) (G_ "You must pass --~a to set the server name.\n")
+                        server-name-sym)
+                (exit 1))
+              (unless key-file
+                (format (current-error-port) (G_ "You must pass --~a to set the file where to store the identity provider key.\n")
+                        key-file-sym)
+                (exit 1))
+              (unless subject
+                (format (current-error-port) (G_ "You must pass --~a to set the subject of the identity provider.\n")
+                        subject-sym)
+                (exit 1))
+              (unless password
+                (format (current-error-port) (G_ "You must pass --~a to set the subject’s password.\n")
+                        password-sym)
+                (exit 1))
+              (unless jwks-uri
+                (format (current-error-port) (G_ "You must pass --~a to set the JWKS URI.\n")
+                        jwks-uri-sym)
+                (exit 1))
+              (unless authorization-endpoint-uri
+                (format (current-error-port) (G_ "You must pass --~a to set the authorization endpoint URI.\n")
+                        authorization-endpoint-uri-sym)
+                (exit 1))
+              (unless token-endpoint-uri
+                (format (current-error-port) (G_ "You must pass --~a to set the token endpoint URI.\n")
+                        token-endpoint-uri-sym)
+                (exit 1))
+              (let ((jti-list (make-jti-list)))
+                (let ((resource-handler
+                       (make-resource-server
+                        #:server-uri server-name
+                        #:owner subject
+                        #:authenticator
+                        (if header
+                            (begin
+                              (set! header
+                                    (string->symbol
+                                     (string-downcase
+                                      (symbol->string header))))
+                              (lambda (request request-body)
+                                (let ((value (assq-ref (request-headers request) header)))
+                                  (and value (string->uri value)))))
+                            (make-authenticator
+                             jti-list
+                             #:server-uri server-name
+                             #:http-get cache-http-get))
+                        #:http-get cache-http-get))
+                      (identity-provider-handler
+                       (make-identity-provider
+                        server-name key-file subject password jwks-uri
+                        authorization-endpoint-uri token-endpoint-uri
+                        jti-list
+                        #:current-time current-time
+                        #:http-get cache-http-get)))
+                  (create-root server-name subject)
+                  (run-server
+                   (lambda (request request-body)
+                     (let ((path (uri-path (request-uri request))))
+                       (if (or (equal? path "/.well-known/openid-configuration")
+                               (equal? path (uri-path jwks-uri))
+                               (equal? path (uri-path authorization-endpoint-uri))
+                               (equal? path (uri-path token-endpoint-uri)))
+                           (identity-provider-handler request request-body)
+                           (resource-handler request request-body))))
+                   'http
+                   (list #:port port)))))
+             (else
+              (format (current-error-port) (G_ "Unknown command ~s\n")
+                      command)
+              (exit 1))))))))))
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index cef6a0c..c69bc51 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -4,6 +4,12 @@
   #:use-module (webid-oidc provider-confirmation)
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc dpop-proof)
+  #:use-module (webid-oidc server create)
+  #:use-module (webid-oidc server read)
+  #:use-module (webid-oidc server update)
+  #:use-module (webid-oidc server delete)
+  #:use-module (webid-oidc server precondition)
+  #:use-module (webid-oidc http-link)
   #:use-module ((webid-oidc config) #:prefix cfg:)
   #:use-module (webid-oidc jti)
   #:use-module (webid-oidc access-token)
@@ -17,6 +23,7 @@
   #:use-module (ice-9 i18n)
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 suspendable-ports)
+  #:use-module (ice-9 control)
   #:use-module (sxml simple)
   #:use-module (srfi srfi-19))
 
@@ -84,3 +91,171 @@
                      (confirm-provider subject issuer #:http-get http-get)
                      subject)))
                #:unwind? #t))))))
+
+(define (handle-errors f g)
+  (call/ec
+   (lambda (do-return)
+     (define (return . args)
+       (apply do-return args))
+     (with-exception-handler
+         (lambda (error)
+           (g return error))
+       (lambda ()
+         (f return))))))
+
+(define*-public (make-resource-server
+                 #:key
+                 (server-uri #f)
+                 (owner #f)
+                 (authenticator #f)
+                 (current-time current-time)
+                 (http-get http-get))
+  (unless owner
+    (error "The owner is not defined."))
+  (declare-link-header!)
+  (unless authenticator
+    (set! authenticator
+          (make-authenticator (make-jti-list)
+                              #:server-uri server-uri
+                              #:current-time current-time
+                              #:http-get http-get)))
+  (lambda (request request-body)
+    (let ((user (authenticator request request-body)))
+      (handle-errors
+       (lambda (return)
+         (let ((method (request-method request)))
+           (case method
+             ((GET HEAD OPTIONS)
+              (receive (headers content)
+                  (read server-uri owner user
+                        (uri-path (request-uri request))
+                        #:http-get http-get)
+                (with-exception-handler
+                    (lambda (error)
+                      (return
+                       (build-response
+                        #:headers headers)
+                       (if (eq? method 'GET)
+                           content
+                           "")))
+                  (lambda ()
+                    (unless (or (request-if-match request)
+                                (request-if-none-match request))
+                      ;; Act as if the precondition failed
+                      (raise-exception
+                       (make-precondition-failed
+                        (uri-path (request-uri request))
+                        (request-if-match request)
+                        (request-if-none-match request)
+                        (car (assq-ref headers 'etag)))))
+                    (check-precondition
+                     (uri-path (request-uri request))
+                     (request-if-match request)
+                     (request-if-none-match request)
+                     (car (assq-ref headers 'etag)))
+                    (return
+                     (build-response
+                      #:code 304
+                      #:reason-phrase "Not Modified"
+                      #:headers headers)
+                     "")))))
+             ((PUT)
+              (return
+               (build-response
+                #:headers
+                `((etag . (,(update server-uri owner user
+                                    (uri-path (request-uri request))
+                                    (request-if-match request)
+                                    (request-if-none-match request)
+                                    (request-content-type request)
+                                    request-body
+                                    #:http-get http-get)
+                           . #f))))
+               ""))
+             ((POST)
+              (let ((types
+                     (map car
+                          (filter
+                           (lambda (link)
+                             (equal? (assq-ref link 'rel) "type"))
+                           (request-links request)))))
+                (return
+                 (build-response
+                  #:headers
+                  `((location . ,(create server-uri owner user
+                                         (uri-path (request-uri request))
+                                         types
+                                         (assq-ref (request-headers request) 'slug)
+                                         (request-content-type request)
+                                         request-body
+                                         #:http-get http-get))))
+                 "")))
+             ((DELETE)
+              (delete server-uri owner user
+                      (uri-path (request-uri request))
+                      (request-if-match request)
+                      (request-if-none-match request)
+                      #:http-get http-get)
+              (return
+               (build-response)
+               "")))))
+       (lambda (return error)
+         (if (cannot-fetch-group? error)
+             (format (current-error-port) (G_ "Warning: ~a\n")
+                     (error->str error))
+             (begin
+               (format (current-error-port) (G_ "Error: ~a\n")
+                       (error->str error))
+               (cond
+                ((uri-slash-semantics-error? error)
+                 (return
+                  (build-response
+                   #:code 301
+                   #:reason-phrase "Found"
+                   #:headers
+                   `((location
+                      . ,(build-uri
+                          (uri-scheme server-uri)
+                          #:userinfo (uri-userinfo server-uri)
+                          #:host (uri-host server-uri)
+                          #:port (uri-port server-uri)
+                          #:path (uri-slash-semantics-error-expected-path error)))))
+                  ""))
+                ((or (path-not-found? error)
+                     (auxiliary-resource-absent? error)
+                     (forbidden? error))
+                 (if user
+                     ;; That’s a forbidden
+                     (return
+                      (build-response #:code 403 #:reason-phrase "Forbidden")
+                      "")
+                     (return
+                      (build-response #:code 401 #:reason-phrase "Unauthorized"
+                                      #:headers `((www-authenticate . ((DPoP)))))
+                      "")))
+                ((or (cannot-delete-root? error))
+                 (return
+                  (build-response
+                   #:code 405
+                   #:reason-phrase "Method Not Allowed")
+                  ""))
+                ((or (container-not-empty? error)
+                     (incorrect-containment-triples? error)
+                     (path-is-auxiliary? error))
+                 (return
+                  (build-response
+                   #:code 409
+                   #:reason-phrase "Conflict")
+                  ""))
+                ((unsupported-media-type? error)
+                 (return
+                  (build-response
+                   #:code 415
+                   #:reason-phrase "Unsupported Media Type")
+                  ""))
+                ((precondition-failed? error)
+                 (return
+                  (build-response
+                   #:code 412
+                   #:reason-phrase "Precondition Failed")
+                  ""))))))))))