From 4aa4a9208ae6abf3affa3318349be196623fbddf Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Sat, 28 Nov 2020 09:51:15 +0100
Subject: Use a web cache on the file system

---
 src/scm/webid-oidc/stubs.scm | 59 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 59 insertions(+)

(limited to 'src/scm/webid-oidc/stubs.scm')

diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm
index 3f16888..831a88d 100644
--- a/src/scm/webid-oidc/stubs.scm
+++ b/src/scm/webid-oidc/stubs.scm
@@ -120,3 +120,62 @@
 (define fixed:scm->json scm->json)
 
 (export (fixed:scm->json . scm->json))
+
+(define (mkdir-p name)
+  (catch 'system-error
+    (lambda ()
+      (mkdir name))
+    (lambda (key subr message args rest)
+      (case (car rest)
+        ((17) ;; file exists
+         #t)
+        ((2) ;; parent does not exist
+         (let ((parent (dirname name)))
+           (unless (equal? parent name)
+             (mkdir-p parent))
+           (mkdir name)))
+        (else
+         (throw key subr message args rest))))))
+
+(define-public (call-with-output-file* filename . args)
+  (mkdir-p (dirname filename))
+  (apply call-with-output-file filename args))
+
+(define-public (atomically-update-file file f)
+  ;; Call f with an output port. If f returns #f, delete the original
+  ;; file. Otherwise, replace it.
+  (let ((updating-file-name (string-append file "~"))
+        (lock-file-name (string-append file ".lock")))
+    (mkdir-p (dirname updating-file-name))
+    (call-with-output-file lock-file-name
+      (lambda (port)
+        (define (enter)
+          (flock port LOCK_EX))
+        (define (leave)
+          (flock port LOCK_UN))
+        (dynamic-wind
+          enter
+          (lambda ()
+            (call-with-output-file updating-file-name
+              (lambda (port)
+                (truncate-file port 0)
+                (with-exception-handler
+                    (lambda (error)
+                      (false-if-exception (delete-file updating-file-name))
+                      (raise-exception error))
+                  (lambda ()
+                    (let ((ok (f port)))
+                      (fsync port)
+                      (close-port port)
+                      (if ok
+                          (rename-file updating-file-name file)
+                          ;; f asked us to delete the original file
+                          (begin
+                            (false-if-exception
+                             (delete-file file))
+                            (false-if-exception
+                             (delete-file updating-file-name))
+                            (false-if-exception
+                             (delete-file lock-file-name))))
+                      (leave)))))))
+          leave)))))
-- 
cgit v1.2.3