utils: Add `with-atomic-file-replacement'.

* guix/build/utils.scm (with-atomic-file-replacement): New procedure.
  (substitute): Use it.

1 files changed, 42 insertions, 30 deletions

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 148f62ec51..20e8cdf3e8 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -32,6 +32,7 @@
             alist-cons-before
             alist-cons-after
             alist-replace
+            with-atomic-file-replacement
             substitute
             substitute*
             dump-port
@@ -157,45 +158,55 @@ An error is raised when no such pair exists."
 ;;; Text substitution (aka. sed).
 ;;;
 
-(define (substitute file pattern+procs)
-  "PATTERN+PROCS is a list of regexp/two-argument procedure.  For each line
-of FILE, and for each PATTERN that it matches, call the corresponding PROC
-as (PROC LINE MATCHES); PROC must return the line that will be written as a
-substitution of the original line."
-  (let* ((rx+proc  (map (match-lambda
-                         (((? regexp? pattern) . proc)
-                          (cons pattern proc))
-                         ((pattern . proc)
-                          (cons (make-regexp pattern regexp/extended)
-                                proc)))
-                        pattern+procs))
-         (template (string-append file ".XXXXXX"))
+(define (with-atomic-file-replacement file proc)
+  "Call PROC with two arguments: an input port for FILE, and an output
+port for the file that is going to replace FILE.  Upon success, FILE is
+atomically replaced by what has been written to the output port, and
+PROC's result is returned."
+  (let* ((template (string-append file ".XXXXXX"))
          (out      (mkstemp! template))
          (mode     (stat:mode (stat file))))
     (with-throw-handler #t
       (lambda ()
         (call-with-input-file file
           (lambda (in)
-            (let loop ((line (read-line in 'concat)))
-              (if (eof-object? line)
-                  #t
-                  (let ((line (fold (lambda (r+p line)
-                                      (match r+p
-                                        ((regexp . proc)
-                                         (match (list-matches regexp line)
-                                           ((and m+ (_ _ ...))
-                                            (proc line m+))
-                                           (_ line)))))
-                                    line
-                                    rx+proc)))
-                    (display line out)
-                    (loop (read-line in 'concat)))))))
-        (close out)
-        (chmod template mode)
-        (rename-file template file))
+            (let ((result (proc in out)))
+              (close out)
+              (chmod template mode)
+              (rename-file template file)
+              result))))
       (lambda (key . args)
         (false-if-exception (delete-file template))))))
 
+(define (substitute file pattern+procs)
+  "PATTERN+PROCS is a list of regexp/two-argument procedure.  For each line
+of FILE, and for each PATTERN that it matches, call the corresponding PROC
+as (PROC LINE MATCHES); PROC must return the line that will be written as a
+substitution of the original line."
+  (let ((rx+proc  (map (match-lambda
+                        (((? regexp? pattern) . proc)
+                         (cons pattern proc))
+                        ((pattern . proc)
+                         (cons (make-regexp pattern regexp/extended)
+                               proc)))
+                       pattern+procs)))
+    (with-atomic-file-replacement file
+      (lambda (in out)
+        (let loop ((line (read-line in 'concat)))
+          (if (eof-object? line)
+              #t
+              (let ((line (fold (lambda (r+p line)
+                                  (match r+p
+                                    ((regexp . proc)
+                                     (match (list-matches regexp line)
+                                       ((and m+ (_ _ ...))
+                                        (proc line m+))
+                                       (_ line)))))
+                                line
+                                rx+proc)))
+                (display line out)
+                (loop (read-line in 'concat)))))))))
+
 
 (define-syntax let-matches
   ;; Helper macro for `substitute*'.
@@ -329,4 +340,5 @@ patched, #f otherwise."
 ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
 ;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
 ;;; eval: (put 'let-matches 'scheme-indent-function 3)
+;;; eval: (put 'with-atomic-file-replacement 'scheme-indent-function 1)
 ;;; End: