From 752baccc78ecfc769c0aa228f1af2e1ec1c30027 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Fri, 2 Jul 2021 17:28:34 +0200
Subject: Fix precondition check with GET

---
 src/scm/webid-oidc/resource-server.scm | 101 +++++++++++++++++++--------------
 1 file changed, 58 insertions(+), 43 deletions(-)

(limited to 'src')

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
-- 
cgit v1.2.3