03/06: squash! Add '--clear'; clear very old databases.

[guix-commits]

civodul pushed a commit to branch wip-guix-index
in repository guix.

commit 9be277d5d1f761cc5470ab1fdb1c6f211e86124b
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Jun 7 17:56:14 2023 +0200

    squash! Add '--clear'; clear very old databases.
---
 doc/guix.texi           |   8 ++++
 guix/scripts/locate.scm | 118 ++++++++++++++++++++++++++++++------------------
 2 files changed, 83 insertions(+), 43 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 54af104fa7..0719892d9a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4479,6 +4479,14 @@ Update the file database.
 
 By default, the database is automatically updated when it is too old.
 
+@item --clear
+Clear the database and re-populate it.
+
+This option lets you start anew, ensuring old data is removed from the
+database, which also avoids having an endlessly growing database.  By
+default @command{guix locate} automatically does that periodically,
+though infrequently.
+
 @item --datebase=@var{file}
 Use @var{file} as the database, creating it if necessary.
 
diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm
index f1c880c01f..259fc39797 100644
--- a/guix/scripts/locate.scm
+++ b/guix/scripts/locate.scm
@@ -211,6 +211,15 @@ user or system."
                     system-database-file
                     user-database-file))))))
 
+(define (clear-database db)
+  "Drop packages and files from DB."
+  (sqlite-exec db "BEGIN IMMEDIATE;")
+  (sqlite-exec db "DELETE FROM Files;")
+  (sqlite-exec db "DELETE FROM Directories;")
+  (sqlite-exec db "DELETE FROM Packages;")
+  (sqlite-exec db "COMMIT;")
+  (sqlite-exec db "VACUUM;"))
+
 
 ;;;
 ;;; Indexing from local packages.
@@ -342,23 +351,21 @@ for each package to insert."
                     (report))
                   packages)))))
 
-(define (index-packages-from-store-with-db file)
-  "Index local store packages using db at location FILE."
-  (call-with-database file
-    (lambda (db)
-      (with-store store
-        (parameterize ((%graft? #f))
-          (define (insert-package-from-store db package)
-            (run-with-store store (insert-package db package)))
-          (let ((packages (fold-packages
-                           cons
-                           '()
-                           #:select? (lambda (package)
-                                       (and (not (hidden-package? package))
-                                            (not (package-superseded package))
-                                            (supported-package? package))))))
-            (insert-packages-with-progress
-             db packages insert-package-from-store)))))))
+(define (index-packages-from-store-with-db db)
+  "Index local store packages using DB."
+  (with-store store
+    (parameterize ((%graft? #f))
+      (define (insert-package-from-store db package)
+        (run-with-store store (insert-package db package)))
+      (let ((packages (fold-packages
+                       cons
+                       '()
+                       #:select? (lambda (package)
+                                   (and (not (hidden-package? package))
+                                        (not (package-superseded package))
+                                        (supported-package? package))))))
+        (insert-packages-with-progress
+         db packages insert-package-from-store)))))
 
 
 ;;;
@@ -406,13 +413,11 @@ for each package to insert."
                 (list (manifest-entry-output entry))
                 (list (manifest-entry-item entry)))) ;FIXME: outputs?
 
-(define (index-packages-from-manifests-with-db file)
-  "Index packages entries into FILE from the system manifests."
-  (call-with-database file
-    (lambda (db)
-      (info (G_ "traversing local profile manifests...~%"))
-      (let ((entries (profiles->manifest-entries (all-profiles))))
-        (insert-packages-with-progress db entries insert-manifest-entry)))))
+(define (index-packages-from-manifests-with-db db)
+  "Index packages entries into DB from the system manifests."
+  (info (G_ "traversing local profile manifests...~%"))
+  (let ((entries (profiles->manifest-entries (all-profiles))))
+    (insert-packages-with-progress db entries insert-manifest-entry)))
 
 
 
@@ -482,12 +487,16 @@ ON f.basename = :file
 
 (define (show-help)
   (display (G_ "Usage: guix locate [OPTIONS...] FILE...
-Locate FILE and return the package(s) that contain it.\n"))
+Locate FILE and return the list of packages that contain it.\n"))
+  (display (G_ "
+  -u, --update        force a database update"))
+  (display (G_ "
+      --clear         clear the database"))
   (display (G_ "
-  --database=FILE     store the database in FILE"))
+      --database=FILE store the database in FILE"))
   (newline)
   (display (G_ "
-  --method=METHOD     use METHOD to select packages to index; METHOD can
+      --method=METHOD use METHOD to select packages to index; METHOD can
                       be 'manifests' (fast) or 'store' (slower)"))
   (newline)
   (display (G_ "
@@ -511,6 +520,9 @@ Locate FILE and return the package(s) that contain it.\n"))
    (option '(#\u "update") #f #f
            (lambda (opt name arg result)
              (alist-cons 'update? #t result)))
+   (option '("clear") #f #f
+           (lambda (opt name arg result)
+             (alist-cons 'clear? #t result)))
 
    ;; index data out of the method (store or package)
    (option '(#\m "method") #f #t
@@ -535,10 +547,19 @@ Locate FILE and return the package(s) that contain 
it.\n"))
   (category packaging)
   (synopsis "search for packages providing a given file")
 
-  (define (old? time)
+  (define age-update-threshold
+    ;; Time since database modification after which an update is triggered.
+    (* 2 30 (* 24 60 60)))
+
+  (define age-cleanup-threshold
+    ;; Time since database modification after which it is cleared.  This is to
+    ;; avoid having stale info in the database and an endlessly growing
+    ;; database.
+    (* 9 30 (* 24 60 60)))
+
+  (define (file-age stat)
     ;; Return true if TIME denotes an "old" time.
-    (>= (- (current-time) time)
-        (* 2 30 (* 24 60 60))))
+    (- (current-time) (stat:mtime stat)))
 
   (with-error-handling
     (let* ((opts     (parse-command-line args %options
@@ -546,7 +567,9 @@ Locate FILE and return the package(s) that contain it.\n"))
                                          #:build-options? #f
                                          #:argument-handler
                                          (lambda (arg result)
-                                           (alist-cons 'argument arg result))))
+                                           (alist-cons 'argument arg
+                                                       result))))
+           (clear?   (assoc-ref opts 'clear?))
            (update?  (assoc-ref opts 'update?))
            (database ((assoc-ref opts 'database) update?))
            (method   (assoc-ref opts 'method))
@@ -554,23 +577,32 @@ Locate FILE and return the package(s) that contain 
it.\n"))
                                             (('argument . arg) arg)
                                             (_ #f))
                                           opts))))
-      (define (populate-database database)
+      (define* (populate-database database clear?)
         (mkdir-p (dirname database))
-        (match method
-          ('manifests
-           (index-packages-from-manifests-with-db database))
-          ('store
-           (index-packages-from-store-with-db database))
-          (_
-           (leave (G_ "~a: unknown indexing method~%") method))))
+        (call-with-database database
+          (lambda (db)
+            (when clear?
+              (clear-database db))
+            (match method
+              ('manifests
+               (index-packages-from-manifests-with-db db))
+              ('store
+               (index-packages-from-store-with-db db))
+              (_
+               (leave (G_ "~a: unknown indexing method~%") method))))))
 
       ;; Populate the database if needed.
-      (let ((stat (stat database #f)))
-        (when (or update?
+      (let* ((stat   (stat database #f))
+             (age    (and stat (file-age stat)))
+             (clear? (or clear?
+                         (and age (>= age age-cleanup-threshold)))))
+        (when (or update? clear?
                   (not stat)
-                  (old? (stat:mtime stat)))
+                  (>= age age-update-threshold))
+          (when clear?
+            (info (G_ "clearing database...~%")))
           (info (G_ "indexing files from ~a...~%") (%store-prefix))
-          (populate-database database)))
+          (populate-database database clear?)))
 
       (match (append-map (lambda (file)
                            (matching-packages-with-db database file))