17/20: squash! Migrate schema when opening.

[guix-commits]

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

commit 4d89890b7afabdd129b203eb3726b978c810c750
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Jun 4 21:33:58 2023 +0200

    squash! Migrate schema when opening.
---
 guix/scripts/locate.scm | 65 +++++++++++++++++++++++++------------------------
 1 file changed, 33 insertions(+), 32 deletions(-)

diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm
index 3fa598f1e9..a8a8f96be5 100644
--- a/guix/scripts/locate.scm
+++ b/guix/scripts/locate.scm
@@ -115,9 +115,41 @@ add column output text;
   (let ((db (sqlite-open file)))
     (dynamic-wind
       (lambda () #t)
-      (lambda () (proc db))
+      (lambda ()
+        (ensure-latest-database-schema db)
+        (proc db))
       (lambda () (sqlite-close db)))))
 
+(define (ensure-latest-database-schema db)
+  "Ensure DB follows the latest known version of the schema."
+  (define (initialize)
+    (sqlite-exec db schema-full)
+    (insert-version db application-version))
+
+  (let ((version (false-if-exception (read-version db))))
+    (cond ((not version)
+           (initialize))
+          ((> version application-version)
+           (initialize))
+          (else
+           (catch #t
+             (lambda ()
+               ;; Migrate from the current version to the full migrated schema.
+               ;; This can raise sqlite-error if the db is not properly 
configured yet
+               (let loop ((current version))
+                 (when (< current application-version)
+                   ;; when the current db version is older than the current 
application
+                   (let* ((next (+ current 1))
+                          (migration (assoc-ref schema-to-migrate next)))
+                     (when migration
+                       (sqlite-exec db migration)
+                       (insert-version db next))
+                     (loop next)))))
+             (lambda _
+               ;; Exception handler in case failure to read an inexisting db:
+               ;; fallback to bootstrap the schema.
+               (initialize)))))))
+
 (define (last-insert-row-id db)        ;XXX: copied from (guix store database)
   ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
   ;; Work around that.
@@ -389,34 +421,6 @@ ON f.basename = :file
   (call-with-database db-file
     (lambda (db) (matching-packages db file))))
 
-(define (read-version-from-db file)
-  (call-with-database file read-version))
-
-(define (migrate-schema-to-version file)
-  (call-with-database file
-    (lambda (db)
-      (catch #t
-        (lambda ()
-          ;; Migrate from the current version to the full migrated schema
-          ;; This can raise sqlite-error if the db is not properly configured 
yet
-          (let* ((current-db-version (read-version db))
-                 (next-db-version (+ 1 current-db-version)))
-            (when (< current-db-version application-version)
-              ;; when the current db version is older than the current 
application
-              (let ((schema-migration-at-version (assoc-ref schema-to-migrate 
next-db-version)))
-                (when schema-migration-at-version
-                  ;; migrate the schema to the next version (if it exists)
-                  (sqlite-exec db schema-migration-at-version)
-                  ;; insert current version
-                  (insert-version db next-db-version)
-                  ;; iterate over the next migration if any
-                  (migrate-schema-to-version db))))))
-        (lambda (key . arg)
-          ;; exception handler in case failure to read an inexisting db
-          ;; Fallback to boostrap the schema
-          (sqlite-exec db schema-full)
-          (insert-version db application-version))))))
-
 (define (print-matching-results matches)
   "Print the MATCHES matching results."
   (for-each (lambda (result)
@@ -530,9 +534,6 @@ Locate FILE and return the package(s) that contain it.\n"))
                                           opts))))
       (define (populate-database database)
         (mkdir-p (dirname database))
-        ;; Migrate/initialize db to schema at version application-version
-        (migrate-schema-to-version database)
-        ;; Finally index packages
         (match method
           ('manifests
            (index-packages-from-manifests-with-db database))