aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorArun Isaac2024-01-11 16:39:39 +0000
committerArun Isaac2024-01-11 16:40:28 +0000
commit78ea0acf77b77fc8707deeb5084f2e8f31fff387 (patch)
tree22e25d4aa93d10efb65cf9eeb9fe9b59778eb34b
parent151940a342848c768e372ec9f232b898ca2c738d (diff)
downloadguix-forge-78ea0acf77b77fc8707deeb5084f2e8f31fff387.tar.gz
guix-forge-78ea0acf77b77fc8707deeb5084f2e8f31fff387.tar.lz
guix-forge-78ea0acf77b77fc8707deeb5084f2e8f31fff387.zip
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.
-rw-r--r--guix/forge/forge.scm261
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