diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-07-02 17:28:34 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-07-02 17:38:11 +0200 |
commit | 752baccc78ecfc769c0aa228f1af2e1ec1c30027 (patch) | |
tree | a601dfb8e809f9521386f486648a0b92ef53e0a1 | |
parent | 58530d7e06040d3fe2df946aad7bac8cee224bb4 (diff) |
Fix precondition check with GET
-rw-r--r-- | po/fr.po | 4 | ||||
-rw-r--r-- | po/webid-oidc.pot | 4 | ||||
-rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 101 |
3 files changed, 62 insertions, 47 deletions
@@ -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-07-02 16:26+0200\n" +"POT-Creation-Date: 2021-07-02 17:36+0200\n" "PO-Revision-Date: 2021-07-02 16:26+0200\n" "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n" "Language-Team: French <vivien@planete-kraus.eu>\n" @@ -981,7 +981,7 @@ msgstr "" msgid "~a: authentication failure: ~a\n" msgstr "~a : échec d’authentificationn : ~a\n" -#: src/scm/webid-oidc/resource-server.scm:237 +#: src/scm/webid-oidc/resource-server.scm:254 #, scheme-format msgid "Warning: ~a\n" msgstr "Avertissement : ~a\n" diff --git a/po/webid-oidc.pot b/po/webid-oidc.pot index 9204514..5b1bdbf 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-07-02 16:26+0200\n" +"POT-Creation-Date: 2021-07-02 17:36+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" @@ -939,7 +939,7 @@ msgstr "" msgid "~a: authentication failure: ~a\n" msgstr "" -#: src/scm/webid-oidc/resource-server.scm:237 +#: src/scm/webid-oidc/resource-server.scm:254 #, scheme-format msgid "Warning: ~a\n" msgstr "" diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index 0eda41f..9257a43 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -120,6 +120,43 @@ (lambda () (f return)))))) +(define (serve-get return path if-match if-none-match content-type content etag headers) + (define (respond-normal) + (return + (build-response + #:headers headers) + content)) + (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)) + (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)) + (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) @@ -147,52 +184,30 @@ (read server-uri owner user (uri-path (request-uri request)) #:http-get http-get) - (with-exception-handler - (lambda (error) - (unless (precondition-failed? error) - (raise-exception error)) - (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) - (return - (build-response - #:headers (cons `(content-type ,negociated-content-type) - other-headers)) - (if (eq? method 'GET) - negociated-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 + (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) - (car (assq-ref headers 'etag))) - (return - (build-response - #:code 304 - #:reason-phrase "Not Modified" - #:headers headers) - ""))))) + negociated-content-type + negociated-content + (car (assq-ref headers 'etag)) + (cons `(content-type ,negociated-content-type) + other-headers)))))) ((PUT) (return (build-response |