forge: Return list of built store paths from guix-channel-job-gexp.

* guix/forge/forge.scm (guix-channel-job-gexp): Return list of built
store paths from guix-channel-job-gexp.

1 files changed, 146 insertions, 115 deletions

diff --git a/guix/forge/forge.scm b/guix/forge/forge.scm
index 6e24cbf..f7d89b4 100644
--- a/guix/forge/forge.scm
+++ b/guix/forge/forge.scm
@@ -1,5 +1,5 @@
 ;;; guix-forge --- Guix software forge meta-service
-;;; Copyright © 2021–2023 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2021–2024 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of guix-forge.
 ;;;
@@ -289,122 +289,153 @@ channel are built.
 @var{guix-daemon-uri} is a file name or URI designating the Guix
 daemon endpoint.
 
-When @var{verbose?} is #true, verbose build logs are shown."
-  (with-extensions (list guix guile-bytestructures guile-gcrypt guile-git)
-    #~(begin
-        (use-modules (guix channels)
-                     (guix derivations)
-                     (guix monads)
-                     (guix inferior)
-                     (guix status)
-                     (guix store)
-                     (srfi srfi-1)
-                     (srfi srfi-71)
-                     (srfi srfi-171)
-                     (ice-9 match)
-                     (rnrs exceptions))
-
-        (define (hline)
-          (display (make-string 50 #\=))
-          (newline))
-
-        (define (code->channel code)
-          (eval code (current-module)))
+When @var{verbose?} is #true, verbose build logs are shown.
 
-        (setenv "SSL_CERT_DIR"
-                #$(file-append nss-certs "/etc/ssl/certs"))
-        (setenv "SSL_CERT_FILE"
-                #$(file-append (profile
-                                (content (packages->manifest (list git-minimal nss-certs))))
-                               "/etc/ssl/certs/ca-certificates.crt"))
-
-        (parameterize ((%daemon-socket-uri #$guix-daemon-uri))
-          (list-transduce
-           ;; Build derivations and report success or failure.
-           (compose (tmap read-derivation-from-file)
-                    (tmap (lambda (drv)
-                            (cons drv
-                                  (guard (ex ((store-protocol-error? ex)
-                                              (store-protocol-error-message ex)))
-                                    (with-status-verbosity (if #$verbose? 1 0)
-                                      (with-store store
-                                        (run-with-store store
-                                          (mbegin %store-monad
-                                            (built-derivations (list drv))))))
-                                    #t))))
-                    (tlog (lambda (_ input)
-                            (match input
-                              ((drv . #t)
-                               (format #t "Building ~a SUCCESS~%" (derivation-file-name drv)))
-                              ((drv . error-message)
-                               (format #t "Building ~a FAILED~%" (derivation-file-name drv))
-                               (display error-message)
-                               (newline))))))
-           (case-lambda
-             (() (list))
-             ((result)
-              ;; Print summary.
-              (let ((successes failures (partition (match-lambda
-                                                     ((_ . #t) #t)
-                                                     (_ #f))
-                                                   result)))
-                (newline)
-                (format #t "~a successes, ~a failures~%"
-                        (length successes)
-                        (length failures))
-                (hline)
-                ;; List failures if any.
-                (unless (zero? (length failures))
+The return value of the returned G-expression is a list of store paths
+that were built."
+  (with-extensions (list guix guile-bytestructures guile-gcrypt guile-git)
+    ;; We pull out macros using module-ref and functions using @@
+    ;; instead of using use-modules because this gexp might be
+    ;; substituted into other gexps and use-modules only works at
+    ;; the top-level.
+    #~(let-syntax ((guard (macro-transformer
+                           (module-ref (resolve-module '(rnrs exceptions))
+                                       'guard)))
+                   (let-values (macro-transformer
+                                (module-ref (resolve-module '(srfi srfi-11))
+                                            'let-values)))
+                   (match (macro-transformer
+                           (module-ref (resolve-module '(ice-9 match))
+                                       'match)))
+                   (match-lambda (macro-transformer
+                                  (module-ref (resolve-module '(ice-9 match))
+                                              'match-lambda)))
+                   (with-status-verbosity (macro-transformer
+                                           (module-ref (resolve-module '(guix status))
+                                                       'with-status-verbosity)))
+                   (with-store (macro-transformer
+                                (module-ref (resolve-module '(guix store))
+                                            'with-store)))
+                   (mbegin (macro-transformer
+                            (module-ref (resolve-module '(guix monads))
+                                        'mbegin))))
+        (let ((partition (@@ (srfi srfi-1) partition))
+              (list-transduce (@@ (srfi srfi-171) list-transduce))
+              (tmap (@@ (srfi srfi-171) tmap))
+              (tlog (@@ (srfi srfi-171) tlog))
+              (derivation-file-name (@@ (guix derivations) derivation-file-name))
+              (derivation->output-path (@@ (guix derivations) derivation->output-path))
+              (read-derivation-from-file (@@ (guix derivations) read-derivation-from-file))
+              (built-derivations (@@ (guix derivations) built-derivations))
+              (inferior-eval (@@ (guix inferior) inferior-eval))
+              (inferior-for-channels (@@ (guix inferior) inferior-for-channels))
+              (%daemon-socket-uri (@@ (guix store) %daemon-socket-uri))
+              (run-with-store (@@ (guix store) run-with-store))
+              (store-protocol-error? (@@ (guix store) store-protocol-error?))
+              (store-protocol-error-message (@@ (guix store) store-protocol-error-message))
+              (hline (lambda ()
+                       (display (make-string 50 #\=))
+                       (newline)))
+              (code->channel (lambda (code)
+                               (eval code (resolve-module '(guix channels))))))
+          (setenv "SSL_CERT_DIR"
+                  #$(file-append nss-certs "/etc/ssl/certs"))
+          (setenv "SSL_CERT_FILE"
+                  #$(file-append (profile
+                                  (content (packages->manifest (list git-minimal nss-certs))))
+                                 "/etc/ssl/certs/ca-certificates.crt"))
+          (parameterize ((%daemon-socket-uri #$guix-daemon-uri))
+            (list-transduce
+             ;; Build derivations and report success or failure.
+             (compose (tmap read-derivation-from-file)
+                      (tmap (lambda (drv)
+                              (cons drv
+                                    (guard (ex ((store-protocol-error? ex)
+                                                (store-protocol-error-message ex)))
+                                      (with-status-verbosity (if #$verbose? 1 0)
+                                        (with-store store
+                                          (run-with-store store
+                                            (mbegin %store-monad
+                                              (built-derivations (list drv))))))
+                                      #t))))
+                      (tlog (lambda (_ input)
+                              (match input
+                                ((drv . #t)
+                                 (format #t "Building ~a SUCCESS~%" (derivation-file-name drv)))
+                                ((drv . error-message)
+                                 (format #t "Building ~a FAILED~%" (derivation-file-name drv))
+                                 (display error-message)
+                                 (newline))))))
+             (case-lambda
+               (() (list))
+               ((result)
+                ;; Print summary.
+                (let-values (((successes failures) (partition (match-lambda
+                                                                ((_ . #t) #t)
+                                                                (_ #f))
+                                                              result)))
                   (newline)
-                  (format #t "List of failures:~%")
-                  (for-each (match-lambda
-                              ((drv . _)
-                               (display (derivation-file-name drv))
-                               (newline)))
-                            failures)
-                  (exit #f))))
-             ((result input)
-              (cons input result)))
-           ;; Obtain list of derivations to build from inferior.
-           (let ((inferior (inferior-for-channels
-                            (map code->channel '#$(map channel->code channels)))))
-             (inferior-eval '(use-modules (guix channels)
-                                          (guix describe)
-                                          (srfi srfi-1))
-                            inferior)
-             (inferior-eval '(define (filter-packages pred)
-                               (fold-packages (lambda (pkg result)
-                                                (if (pred pkg)
-                                                    (cons pkg result)
-                                                    result))
-                                              (list)))
-                            inferior)
-             (inferior-eval
-              '(parameterize ((%daemon-socket-uri #$guix-daemon-uri))
-                 (with-store store
-                   (map (compose derivation-file-name
-                                 (match-lambda
-                                   ((? package? pkg)
-                                    (parameterize ((%graft? #false))
-                                      (run-with-store store
-                                        (package->derivation pkg))))
-                                   (item (error "Unknown item" item))))
-                        #$(if variables
-                              #~(map (match-lambda
-                                       ((module-name variable-name)
-                                        (module-ref (resolve-interface module-name)
-                                                    variable-name)))
-                                     '#$(map (lambda (variable)
-                                               (list (variable-specification-module variable)
-                                                     (variable-specification-name variable)))
-                                             variables))
-                              #~(filter-packages
-                                 (lambda (pkg)
-                                   (any (lambda (channel)
-                                          (memq (channel-name channel)
-                                                (list '#$(channel-name (first channels)))))
-                                        (package-channels pkg))))))))
-              inferior)))))))
+                  (format #t "~a successes, ~a failures~%"
+                          (length successes)
+                          (length failures))
+                  (hline)
+                  (match failures
+                    ;; If no failures, return list of output paths.
+                    (() (map (match-lambda
+                               ((drv . #t) (derivation->output-path drv)))
+                             result))
+                    ;; If failures, list them.
+                    (_
+                     (newline)
+                     (format #t "List of failures:~%")
+                     (for-each (match-lambda
+                                 ((drv . _)
+                                  (display (derivation-file-name drv))
+                                  (newline)))
+                               failures)
+                     (error "Failed to build derivations")))))
+               ((result input)
+                (cons input result)))
+             ;; Obtain list of derivations to build from inferior.
+             (let ((inferior (inferior-for-channels
+                              (map code->channel '#$(map channel->code channels)))))
+               (inferior-eval '(use-modules (guix channels)
+                                            (guix describe)
+                                            (srfi srfi-1))
+                              inferior)
+               (inferior-eval '(define (filter-packages pred)
+                                 (fold-packages (lambda (pkg result)
+                                                  (if (pred pkg)
+                                                      (cons pkg result)
+                                                      result))
+                                                (list)))
+                              inferior)
+               (inferior-eval
+                '(parameterize ((%daemon-socket-uri #$guix-daemon-uri))
+                   (with-store store
+                     (map (compose derivation-file-name
+                                   (match-lambda
+                                     ((? package? pkg)
+                                      (parameterize ((%graft? #false))
+                                        (run-with-store store
+                                          (package->derivation pkg))))
+                                     (item (error "Unknown item" item))))
+                          #$(if variables
+                                #~(map (match-lambda
+                                         ((module-name variable-name)
+                                          (module-ref (resolve-interface module-name)
+                                                      variable-name)))
+                                       '#$(map (lambda (variable)
+                                                 (list (variable-specification-module variable)
+                                                       (variable-specification-name variable)))
+                                               variables))
+                                #~(filter-packages
+                                   (lambda (pkg)
+                                     (any (lambda (channel)
+                                            (memq (channel-name channel)
+                                                  (list '#$(channel-name (first channels)))))
+                                          (package-channels pkg))))))))
+                inferior))))))))
 
 (define (forge-ci-jobs config)
   "Return list of CI jobs for forge configuraion @var{config}. Each