branch master updated: Fix single checkout update.

[Mathieu Othacehe]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch master
in repository guix-cuirass.

The following commit(s) were added to refs/heads/master by this push:
     new f5a2eea  Fix single checkout update.
f5a2eea is described below

commit f5a2eeae18ec02043107199047ddffd83e76d620
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Thu Mar 25 17:42:09 2021 +0100

    Fix single checkout update.
    
    When a new evaluation is triggered by a single channel update, the
    matching specification can have other channels that are not updated. In that
    case, "db-get-checkouts" will only return the checkout corresponding to the
    channel update.
    
    This cause "channel-instances->profile" to fail this way:
    
    In guix/channels.scm:
       911:32  3 (channel-instances->derivation _)
       871:36  2 (channel-instances->manifest (#<<channel-instance> cha?>))
        759:6  1 (channel-instance-derivations (#<<channel-instance> ch?>))
    In ice-9/boot-9.scm:
      1669:16  0 (raise-exception _ #:continuable? _)
    
    ice-9/boot-9.scm:1669:16: In procedure raise-exception:
    ERROR:
      1. &message: "'guix' channel is lacking"
      2. &fix-hint: "Make sure your list of channels\ncontains one channel 
named @code{guix} providing the core of Guix."
      3. &error-location: #<<location> file: "guix/channels.scm" line: 557 
column: 18>
    
    Introduce a db-get-latest-checkout procedure that returns the last checkout 
of
    a given channel. Use it to request the checkouts of all the channels before
    creating the profile.
    
    * src/cuirass/database.scm (db-get-latest-checkout): New procedure.
    * tests/database.scm ("db-get-latest-checkout"): New test.
    * src/cuirass/scripts/evaluate.scm (latest-checkouts): New procedure.
    (cuirass-evaluate): Use it.
---
 src/cuirass/database.scm         | 16 ++++++++++++++++
 src/cuirass/scripts/evaluate.scm | 12 +++++++++++-
 tests/database.scm               |  6 ++++++
 3 files changed, 33 insertions(+), 1 deletion(-)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 0cb3cf9..2c77a6a 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -83,6 +83,7 @@
             db-delete-events-with-ids-<=-to
             db-get-pending-derivations
             db-get-checkouts
+            db-get-latest-checkout
             db-get-evaluation
             db-get-evaluations
             db-get-evaluations-build-summary
@@ -1180,6 +1181,21 @@ WHERE evaluation =" eval-id " ORDER BY channel ASC;"))
                        (#:directory . ,directory))
                      checkouts)))))))
 
+(define (db-get-latest-checkout spec channel eval-id)
+  "Return the first checkout for the CHANNEL channel, part of SPEC
+specification with an evaluation id inferior or equal to EVAL-ID."
+  (with-db-worker-thread db
+    (match (expect-one-row
+            (exec-query/bind
+             db " SELECT channel, revision, directory FROM Checkouts
+ WHERE specification = " spec " AND channel = " (symbol->string channel)
+ " AND evaluation <= " eval-id "ORDER BY evaluation DESC LIMIT 1;"))
+      (() #f)
+      ((channel revision directory)
+       `((#:commit . ,revision)
+         (#:channel . ,(string->symbol channel))
+         (#:directory . ,directory))))))
+
 (define (parse-evaluation evaluation)
   (match evaluation
     ((id specification status timestamp checkouttime evaltime)
diff --git a/src/cuirass/scripts/evaluate.scm b/src/cuirass/scripts/evaluate.scm
index 82ca5ff..188f3f3 100644
--- a/src/cuirass/scripts/evaluate.scm
+++ b/src/cuirass/scripts/evaluate.scm
@@ -90,6 +90,16 @@ of channel instances."
           (built-derivations (list profile))
           (return (derivation->output-path profile)))))))
 
+(define (latest-checkouts spec eval-id)
+  "Return the latest checkouts for the EVAL-ID evaluation of the SPEC
+specification."
+  (let ((name (specification-name spec))
+        (channels (specification-channels spec)))
+    (map (lambda (channel)
+           (let ((channel (channel-name channel)))
+             (db-get-latest-checkout name channel eval-id)))
+         channels)))
+
 (define (cuirass-evaluate args)
   "This procedure spawns an inferior on the given channels.  An evaluation
 procedure is called within that inferior, it returns a list of jobs that are
@@ -101,7 +111,7 @@ registered in database."
            (let* ((eval-id (with-input-from-string eval-str read))
                   (name (db-get-evaluation-specification eval-id))
                   (spec (db-get-specification name))
-                  (checkouts (db-get-checkouts eval-id))
+                  (checkouts (latest-checkouts spec eval-id))
                   (instances (checkouts->channel-instances checkouts))
                   (profile (channel-instances->profile instances))
                   (build (specification-build spec))
diff --git a/tests/database.scm b/tests/database.scm
index 8f8015a..f139638 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -146,6 +146,12 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 
0, 0);")
      (db-add-evaluation "guix"
                         (make-dummy-instances "fakesha3" "fakesha4"))))
 
+  (test-equal "db-get-latest-checkout"
+    '("fakesha3" "fakesha4")
+    (map (cut assq-ref <> #:commit)
+         (list (db-get-latest-checkout "guix" 'guix 3)
+               (db-get-latest-checkout "guix" 'my-channel 3))))
+
   (test-assert "db-set-evaluation-status"
     (db-set-evaluation-status 2 (evaluation-status started)))