From 8a064915f5940e511aea21055660e363a96a4110 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Mon, 28 Jun 2021 11:58:35 +0200 Subject: Add a full server. --- src/scm/webid-oidc/program.scm | 92 +++++++++++++++-- src/scm/webid-oidc/resource-server.scm | 175 +++++++++++++++++++++++++++++++++ 2 files changed, 259 insertions(+), 8 deletions(-) (limited to 'src') 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") + "")))))))))) -- cgit v1.2.3