;; disfluid, 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 resource wac) #:prefix wac:) #:use-module ((webid-oidc server resource path) #: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 (webid-oidc web-i18n) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) #:use-module (ice-9 control) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) #:use-module (sxml simple) #:use-module (srfi srfi-19) #:declarative? #t #:export ( make-authenticator make-resource-server )) (define* (make-authenticator #:key (server-uri #f) (http-get http-get)) (unless (and server-uri (uri? server-uri)) (fail (G_ "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 ((web-locale request) (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) (if (exception-with-message? error) (format (current-error-port) (G_ "~a: authentication failure: ~a\n") (date->string current-time) (exception-message error)) (format (current-error-port) (G_ "~a: authentication failure\n") (date->string current-time))) #f) (lambda () ;; Sometimes the access is the cadr as a symbol, ;; sometimes it is the cdr as a string. It depends ;; whether the response has been written and read, ;; or preserved as a guile object. (let* ((lit-access-token (match authz ;; That’s when the request is parsed: (('dpop (? symbol? symbol-value)) (symbol->string symbol-value)) ;; That’s when it’s not: (('dpop . (? string? string-value)) string-value))) (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 (W_ "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 (W_ "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* (make-resource-server #:key (server-uri #f) (owner #f) (authenticator #f) (http-get http-get)) (unless owner (fail (G_ "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 (web-locale request)) (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 (W_ "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 (wac:cannot-fetch-group? error) (if (exception-with-message? error) (format (current-error-port) (G_ "~a: ignoring a group that cannot be fetched: ~a\n") (date->string ((p:current-date))) (exception-message error)) (format (current-error-port) (G_ "~a: ignoring a group that cannot be fetched\n") (date->string ((p:current-date))))) (cond ((ldp:uri-slash-semantics-error? error) (return (build-response #:code 301 #:reason-phrase (W_ "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 (ldp:path-not-found? error) (ldp:auxiliary-resource-absent? error) (wac:forbidden? error)) (if user ;; That’s a forbidden (return (build-response #:code 403 #:reason-phrase (W_ "reason-phrase|Forbidden")) #f user) (return (build-response #:code 401 #:reason-phrase (W_ "reason-phrase|Unauthorized") #:headers `((www-authenticate . ((DPoP))))) #f user))) ((ldp:cannot-delete-root? error) (return (build-response #:code 405 #:reason-phrase (W_ "reason-phrase|Method Not Allowed")) #f user)) ((or (ldp:container-not-empty? error) (ldp:incorrect-containment-triples? error) (ldp:path-is-auxiliary? error)) (return (build-response #:code 409 #:reason-phrase (W_ "reason-phrase|Conflict")) #f user)) ((ldp:unsupported-media-type? error) (return (build-response #:code 415 #:reason-phrase (W_ "reason-phrase|Unsupported Media Type")) #f user)) ((precondition-failed? error) (return (build-response #:code 412 #:reason-phrase (W_ "reason-phrase|Precondition Failed")) #f user)) ((not-acceptable? error) (return (build-response #:code 406 #:reason-phrase (W_ "reason-phrase|Not Acceptable")) #f user)) (else (raise-exception error))))))))))