From 78ea0acf77b77fc8707deeb5084f2e8f31fff387 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Thu, 11 Jan 2024 16:39:39 +0000 Subject: 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. --- guix/forge/forge.scm | 261 ++++++++++++++++++++++++++++----------------------- 1 file changed, 146 insertions(+), 115 deletions(-) (limited to 'guix/forge') 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 +;;; Copyright © 2021–2024 Arun Isaac ;;; ;;; 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 -- cgit v1.2.3