;; webid-oidc, implementation of the Solid specification ;; Copyright (C) 2020, 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 . (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 serve) #:use-module ((webid-oidc server create) #:prefix ldp:) #:use-module ((webid-oidc server read) #:prefix ldp:) #:use-module ((webid-oidc server update) #:prefix ldp:) #:use-module ((webid-oidc server delete) #:prefix ldp:) #:use-module (webid-oidc server precondition) #:use-module (webid-oidc http-link) #:use-module ((webid-oidc parameters) #:prefix p:) #: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 (ice-9 control) #: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 #: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 ((p:current-date)))) (parameterize ((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) (format (current-error-port) (G_ "~a: authentication failure: ~a\n") (date->string current-time) (error->str error)) #f) (lambda () (let* ((lit-access-token (symbol->string (cadr authz))) (access-token (access-token-decode lit-access-token #:http-get http-get)) (cnf/jkt (access-token-cnf/jkt access-token)) (dpop-proof (dpop-proof-decode method full-uri dpop cnf/jkt #:access-token lit-access-token))) (let ((subject (access-token-webid access-token)) (issuer (access-token-iss access-token))) (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 (nonrdf-or-turtle server-uri request request-body) ;; If the request is an exotic RDF serialization ;; format, we want to convert it to Turtle, ;; otherwise we will consider it non-rdf. (convert '(text/turtle */*) server-uri (uri-path (request-uri request)) (request-content-type request) request-body)) (define (serve-get return path if-match if-none-match content-type content etag headers user) (define (respond-normal) (return (build-response #:headers headers) content user)) (if if-match ;; If the precondition failed, then we should respond with 412 (with-exception-handler (lambda (error) (unless (precondition-failed? error) (raise-exception error)) (return (build-response #:code 412 #:reason-phrase "Precondition Failed") #f user)) (lambda () (check-precondition path if-match if-none-match etag) (respond-normal))) ;; If the precondition succeeds (if-none-match is effectively ;; invalid), we return 200 (with-exception-handler (lambda (error) (unless (precondition-failed? error) (raise-exception error)) (return (build-response #:code 304 #:reason-phrase "Not Modified" #:headers headers) #f user)) (lambda () (when if-none-match (check-precondition path if-match if-none-match etag)) (respond-normal))))) (define*-public (make-resource-server #:key (server-uri #f) (owner #f) (authenticator #f) (http-get http-get)) (unless owner (error "The owner is not defined.")) (declare-link-header!) (unless authenticator (set! authenticator (make-authenticator #:server-uri server-uri #:http-get http-get))) (lambda (request request-body) (parameterize ((p:current-date ((p:current-date)))) ;; Fix the date (let ((user (authenticator request request-body))) (handle-errors (lambda (return) (let ((method (request-method request))) (case method ((GET HEAD OPTIONS) (receive (headers content) (ldp:read server-uri owner user (uri-path (request-uri request)) #:http-get http-get) (let ((true-content-type (car (assq-ref headers 'content-type))) (other-headers (filter (lambda (h) (not (eq? (car h) 'content-type))) headers))) (receive (negociated-content-type negociated-content) (convert (request-accept request #f) server-uri (uri-path (request-uri request)) true-content-type content) (serve-get return (uri-path (request-uri request)) (request-if-match request) (request-if-none-match request) negociated-content-type negociated-content (car (assq-ref headers 'etag)) (cons `(content-type ,negociated-content-type) other-headers) user))))) ((PUT) (receive (content-type content) (nonrdf-or-turtle server-uri request request-body) (return (build-response #:headers `((etag . (,(ldp:update server-uri owner user (uri-path (request-uri request)) (request-if-match request) (request-if-none-match request) content-type content #:http-get http-get) . #f)))) "" user))) ((POST) (receive (content-type content) (nonrdf-or-turtle server-uri request request-body) (let ((types (map car (filter (lambda (link) (equal? (assq-ref link 'rel) "type")) (request-links request))))) (return (build-response #:code 201 #:reason-phrase "Created" #:headers `((location . ,(ldp:create server-uri owner user (uri-path (request-uri request)) types (assq-ref (request-headers request) 'slug) content-type content #:http-get http-get)))) "" user)))) ((DELETE) (ldp: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) "" user))))) (lambda (return error) (if (cannot-fetch-group? error) (format (current-error-port) (G_ "Warning: ~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))))) #f user)) ((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") #f user) (return (build-response #:code 401 #:reason-phrase "Unauthorized" #:headers `((www-authenticate . ((DPoP))))) #f user))) ((or (cannot-delete-root? error)) (return (build-response #:code 405 #:reason-phrase "Method Not Allowed") #f user)) ((or (container-not-empty? error) (incorrect-containment-triples? error) (path-is-auxiliary? error)) (return (build-response #:code 409 #:reason-phrase "Conflict") #f user)) ((unsupported-media-type? error) (return (build-response #:code 415 #:reason-phrase "Unsupported Media Type") #f user)) ((precondition-failed? error) (return (build-response #:code 412 #:reason-phrase "Precondition Failed") #f user)) ((not-acceptable? error) (return (build-response #:code 406 #:reason-phrase "Not Acceptable") #f user)) (else (raise-exception error))))))))))