unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
From: "Jan (janneke) Nieuwenhuizen" <janneke@gnu.org>
To: 41350@debbugs.gnu.org, Mathieu Othacehe <othacehe@gnu.org>
Subject: [bug#41350] [PATCH v2 1/3] utils: Move 'reset-timestamps' out of database.
Date: Tue, 19 May 2020 09:23:00 +0200	[thread overview]
Message-ID: <20200519072302.9202-1-janneke@gnu.org> (raw)
In-Reply-To: <87mu66q3rt.fsf@gnu.org>

This supports calling reset-timestamps without loading sqlite3.

* guix/store/database.scm (reset-timestamps): Move to...
* guix/utils.scm (reset-timestamps): ... here.
* gnu/build/vm.scm: Include it.
---
 gnu/build/vm.scm        |  1 +
 guix/store/database.scm | 41 +++--------------------------------------
 guix/utils.scm          | 41 ++++++++++++++++++++++++++++++++++++++---
 3 files changed, 42 insertions(+), 41 deletions(-)

diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 433b5a7e8d..c751e6b0e2 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -26,6 +26,7 @@
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
   #:use-module (guix build syscalls)
+  #:use-module ((guix utils) #:select (reset-timestamps))
   #:use-module (guix store database)
   #:use-module (gnu build bootloader)
   #:use-module (gnu build linux-boot)
diff --git a/guix/store/database.scm b/guix/store/database.scm
index ef52036ede..b8fe313c3d 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -24,9 +24,8 @@
   #:use-module (guix store deduplication)
   #:use-module (guix base16)
   #:use-module (guix progress)
-  #:use-module (guix build syscalls)
-  #:use-module ((guix build utils)
-                #:select (mkdir-p executable-file?))
+  #:use-module ((guix build utils) #:select (mkdir-p))
+  #:use-module ((guix utils) #:select (reset-timestamps))
   #:use-module (guix build store-copy)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -42,8 +41,7 @@
             sqlite-register
             register-path
             register-items
-            %epoch
-            reset-timestamps))
+            %epoch))
 
 ;;; Code for working with the store database directly.
 
@@ -227,39 +225,6 @@ Every store item in REFERENCES must already be registered."
 ;;;
 ;;; High-level interface.
 ;;;
-
-(define* (reset-timestamps file #:key preserve-permissions?)
-  "Reset the modification time on FILE and on all the files it contains, if
-it's a directory.  Canonicalize file permissions unless PRESERVE-PERMISSIONS?
-is true."
-  ;; Note: We're resetting to one second after the Epoch like 'guix-daemon'
-  ;; has always done.
-  (let loop ((file file)
-             (type (stat:type (lstat file))))
-    (case type
-      ((directory)
-       (unless preserve-permissions?
-         (chmod file #o555))
-       (utime file 1 1 0 0)
-       (let ((parent file))
-         (for-each (match-lambda
-                     (("." . _) #f)
-                     ((".." . _) #f)
-                     ((file . properties)
-                      (let ((file (string-append parent "/" file)))
-                        (loop file
-                              (match (assoc-ref properties 'type)
-                                ((or 'unknown #f)
-                                 (stat:type (lstat file)))
-                                (type type))))))
-                   (scandir* parent))))
-      ((symlink)
-       (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW))
-      (else
-       (unless preserve-permissions?
-         (chmod file (if (executable-file? file) #o555 #o444)))
-       (utime file 1 1 0 0)))))
-
 (define* (register-path path
                         #:key (references '()) deriver prefix
                         state-directory (deduplicate? #t)
diff --git a/guix/utils.scm b/guix/utils.scm
index d7b197fa44..812617dd61 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -35,8 +35,10 @@
   #:use-module (rnrs io ports)                    ;need 'port-position' etc.
   #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
   #:use-module (guix memoization)
-  #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively))
-  #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
+  #:use-module ((guix build utils)
+                #:select (dump-port mkdir-p delete-file-recursively
+                                    executable-file?))
+  #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync scandir*))
   #:use-module (ice-9 format)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
@@ -109,7 +111,8 @@
             call-with-decompressed-port
             compressed-output-port
             call-with-compressed-output-port
-            canonical-newline-port))
+            canonical-newline-port
+            reset-timestamps))
 
 \f
 ;;;
@@ -843,6 +846,38 @@ a location object."
   fix-hint?
   (hint condition-fix-hint))                      ;string
 
+(define* (reset-timestamps file #:key preserve-permissions?)
+  "Reset the modification time on FILE and on all the files it contains, if
+it's a directory.  Canonicalize file permissions unless PRESERVE-PERMISSIONS?
+is true."
+  ;; Note: We're resetting to one second after the Epoch like 'guix-daemon'
+  ;; has always done.
+  (let loop ((file file)
+             (type (stat:type (lstat file))))
+    (case type
+      ((directory)
+       (unless preserve-permissions?
+         (chmod file #o555))
+       (utime file 1 1 0 0)
+       (let ((parent file))
+         (for-each (match-lambda
+                     (("." . _) #f)
+                     ((".." . _) #f)
+                     ((file . properties)
+                      (let ((file (string-append parent "/" file)))
+                        (loop file
+                              (match (assoc-ref properties 'type)
+                                ((or 'unknown #f)
+                                 (stat:type (lstat file)))
+                                (type type))))))
+                   (scandir* parent))))
+      ((symlink)
+       (utime file 1 1 0 0 AT_SYMLINK_NOFOLLOW))
+      (else
+       (unless preserve-permissions?
+         (chmod file (if (executable-file? file) #o555 #o444)))
+       (utime file 1 1 0 0)))))
+
 ;;; Local Variables:
 ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
 ;;; End:
-- 
2.26.2





  parent reply	other threads:[~2020-05-19  7:24 UTC|newest]

Thread overview: 50+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2020-05-17 10:01 [bug#41350] [PATCH 0/3] Use native qemu to build vm-image Jan Nieuwenhuizen
2020-05-17 10:03 ` [bug#41350] [PATCH 1/3] utils: Move 'reset-timestamps' out of database Jan (janneke) Nieuwenhuizen
2020-05-17 10:03   ` [bug#41350] [PATCH 2/3] system: vm: Do not register-closures when cross-building Jan (janneke) Nieuwenhuizen
2020-05-17 10:03   ` [bug#41350] [PATCH 3/3] system: vm: Build vm-image using native qemu Jan (janneke) Nieuwenhuizen
2020-05-18  9:10 ` [bug#41350] [PATCH 0/3] Use native qemu to build vm-image Mathieu Othacehe
2020-05-19  7:22   ` Jan Nieuwenhuizen
2020-05-19 10:02     ` Mathieu Othacehe
2020-05-20 14:03       ` Mathieu Othacehe
2020-05-20 15:09         ` Jan Nieuwenhuizen
2020-05-19  7:23 ` Jan (janneke) Nieuwenhuizen [this message]
2020-05-19  7:23   ` [bug#41350] [PATCH v2 2/3] system: vm: Do not register-closures when cross-building to the Hurd Jan (janneke) Nieuwenhuizen
2020-05-19  7:23   ` [bug#41350] [PATCH v2 3/3] system: vm: Build vm-image using native qemu, for " Jan (janneke) Nieuwenhuizen
2020-05-19  9:14     ` Mathieu Othacehe
2020-05-20 21:49       ` Ludovic Courtès
2020-05-23  9:28       ` Jan Nieuwenhuizen
2020-05-23 17:45         ` Mathieu Othacehe
2020-05-23 19:07           ` Jan Nieuwenhuizen
2020-05-24  9:18             ` Mathieu Othacehe
2020-05-27  9:30               ` Ludovic Courtès
2020-05-28  7:00                 ` Mathieu Othacehe
2020-05-24 11:19             ` Jan Nieuwenhuizen
2020-05-24 12:07               ` Mathieu Othacehe
2020-05-24 14:20                 ` Jan Nieuwenhuizen
2020-05-24 16:36             ` Ludovic Courtès
2020-05-20 21:58     ` Ludovic Courtès
2020-05-22 19:24 ` Mathieu Othacehe
2020-05-27 22:54   ` Ludovic Courtès
2020-05-28  6:36     ` Mathieu Othacehe
2020-05-28 12:29       ` Jan Nieuwenhuizen
2020-05-28 15:39         ` Ludovic Courtès
2020-05-28 17:07           ` Jan Nieuwenhuizen
2020-05-28 17:10           ` Mathieu Othacehe
2020-05-28 18:19             ` Jan Nieuwenhuizen
2020-05-29  8:18             ` Ludovic Courtès
2020-05-29  9:06               ` Jan Nieuwenhuizen
2020-05-30 10:08                 ` Jan Nieuwenhuizen
2020-05-30 13:54                   ` Ludovic Courtès
2022-09-28 20:18                     ` [bug#41350] [PATCH 0/3] Use native qemu to build vm-image Maxim Cournoyer
2022-09-29 14:17                       ` bug#41350: " Mathieu Othacehe
2020-05-23  9:30 ` [bug#41350] [PATCH v3 1/3] utils: Move 'reset-timestamps' out of database Jan (janneke) Nieuwenhuizen
2020-05-23  9:30   ` [bug#41350] [PATCH v3 2/3] system: vm: Do not register-closures when cross-building to the Hurd Jan (janneke) Nieuwenhuizen
2020-05-27  8:45     ` Ludovic Courtès
2020-05-27  9:13       ` Jan Nieuwenhuizen
2020-05-23  9:30   ` [bug#41350] [PATCH v3 3/3] system: vm: Build vm-image using native qemu, for " Jan (janneke) Nieuwenhuizen
2020-05-27  8:43   ` [bug#41350] [PATCH v3 1/3] utils: Move 'reset-timestamps' out of database Ludovic Courtès
2020-05-27  8:59     ` Ludovic Courtès
2020-05-27  9:10     ` Jan Nieuwenhuizen
2020-05-24 18:11 ` [bug#41350] [PATCH v2 3/3] system: vm: Build vm-image using native qemu, for the Hurd Mathieu Othacehe
2020-05-24 18:40   ` Jan Nieuwenhuizen
2020-05-25 15:46     ` Jan Nieuwenhuizen

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://guix.gnu.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20200519072302.9202-1-janneke@gnu.org \
    --to=janneke@gnu.org \
    --cc=41350@debbugs.gnu.org \
    --cc=othacehe@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).