1 files changed, 55 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm
index 3f16888..b29aa1f 100644
--- a/src/scm/webid-oidc/stubs.scm
+++ b/src/scm/webid-oidc/stubs.scm
@@ -120,3 +120,58 @@
 (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 lock-file-name 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 "~")))
+    (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))))))))))
+          leave)))))