From 4a48be393e91c2cd5f59cb549b2085faae9114c7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Wed, 22 Jul 2020 16:36:16 +0200
Subject: Let with-atomic-output-to-file break free.

---
 module/output/vdir.scm | 18 ++++++------------
 module/util/io.scm     | 36 ++++++++++++++++++++++++++++++++++++
 2 files changed, 42 insertions(+), 12 deletions(-)

diff --git a/module/output/vdir.scm b/module/output/vdir.scm
index abe02a9f..5e319248 100644
--- a/module/output/vdir.scm
+++ b/module/output/vdir.scm
@@ -8,8 +8,10 @@
   :use-module (util)
   :use-module (output ical)
   :use-module (vcomponent)
+  :use-module ((util io) :select (with-atomic-output-to-file))
   )
 
+
 (define / file-name-separator-string)
 
 (define-public (save-event event)
@@ -19,19 +21,11 @@
      (error "Importing into direct calendar files not supported")]
 
     [(vdir)
-     (let* ((uid (or (prop event 'UID) (uuidgen)))
-            ;; copy to enusre writable string
-            (tmpfile (string-copy (string-append (prop calendar 'X-HNH-DIRECTORY)
-                                                 / ".calp-" uid "XXXXXX")))
-            (port (mkstemp! tmpfile)))
+     (let* ((uid (or (prop event 'UID) (uuidgen))))
        (set! (prop event 'UID) uid)
-       (with-output-to-port port
-         (lambda () (print-components-with-fake-parent (list event))))
-       ;; does close flush?
-       (force-output port)
-       (close-port port)
-       (rename-file tmpfile (string-append (prop calendar 'X-HNH-DIRECTORY)
-                                           / uid ".ics"))
+       (with-atomic-output-to-file
+        (string-append (prop calendar 'X-HNH-DIRECTORY) / uid ".ics")
+        (lambda () (print-components-with-fake-parent (list event))))
        uid)]
 
     [else
diff --git a/module/util/io.scm b/module/util/io.scm
index a9da7ea6..1652f042 100644
--- a/module/util/io.scm
+++ b/module/util/io.scm
@@ -19,3 +19,39 @@
       (let loop ((line (read-line)))
         (if (eof-object? line)
             '() (cons line (loop (read-line))))))))
+
+;; Same functionality as the regular @var{with-output-to-file}, but
+;; with the difference that either everything is written, or nothing
+;; is written, and if anything is written it's all written atomicaly at
+;; once (the original file will never contain an intermidiate state).
+;; Does NOT handle race conditions between threads.
+;; Return #f on failure, something truthy otherwise
+(define-public (with-atomic-output-to-file filename thunk)
+  ;; copy to enusre writable string
+  (define tmpfile (string-copy (string-append
+                                (dirname filename)
+                                file-name-separator-string
+                                "." (basename filename)
+                                "XXXXXX")))
+  (define port #f)
+  (dynamic-wind
+    (lambda () (set! port (mkstemp! tmpfile)))
+    (lambda ()
+      (with-output-to-port port thunk)
+      ;; (force-output port)
+      ;; TODO check buffereing, might throw exception?
+      (close-port port)
+      (rename-file tmpfile filename))
+    (lambda ()
+      ;; (force-output port)
+      ;; TODO check buffereing, might throw exception?
+      ;; tmpfile still existing means that we never hit the
+      ;; rename above, clean up the file and note that we failed.
+      (when (access? tmpfile F_OK)
+        (close-port port)
+        (delete-file tmpfile)
+        ;; `when' defaults to the truthy `()', see (util)
+        ;; (note that #<unspecified> is thruthy, but shouldn't be
+        ;; counted on, since anything with an unspecified return
+        ;; value might as well return #f)
+        #f))))
-- 
cgit v1.2.3