diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/forge/forge.scm | 117 |
1 files changed, 114 insertions, 3 deletions
diff --git a/guix/forge/forge.scm b/guix/forge/forge.scm index a5445b9..0c6c638 100644 --- a/guix/forge/forge.scm +++ b/guix/forge/forge.scm @@ -1,5 +1,5 @@ ;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2021, 2022 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2021–2023 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of guix-forge. ;;; @@ -25,15 +25,20 @@ #:use-module ((gnu packages certs) #:select (nss-certs)) #:use-module ((gnu packages ci) #:select (laminar)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) - #:use-module ((gnu packages guile) #:select (guile-3.0 guile-zlib)) + #:use-module ((gnu packages guile) #:select (guile-3.0 guile-bytestructures guile-zlib)) + #:use-module ((gnu packages package-management) #:select (guix)) #:use-module ((gnu packages version-control) #:select (git-minimal)) #:use-module (gnu services mcron) + #:use-module (guix channels) #:use-module (guix modules) #:use-module (guix packages) #:use-module (guix records) #:use-module (guix store) + #:use-module ((forge guile-git) #:select (guile-git)) #:use-module (forge laminar) + #:use-module (forge tissue) #:use-module (forge utils) + #:use-module (forge web) #:use-module (forge webhook) #:export (forge-service-type forge-configuration @@ -49,7 +54,8 @@ forge-project-website-directory forge-project-ci-jobs forge-project-ci-jobs-trigger - derivation-job-gexp)) + derivation-job-gexp + guix-channel-job-gexp)) (define-record-type* <forge-project> forge-project make-forge-project @@ -252,6 +258,111 @@ clone and does not include the .git directory." (format (current-error-port) "Built ~a successfully~%" derivation-output) derivation-output))))))) +(define* (guix-channel-job-gexp channels + #:key (guix-daemon-uri %daemon-socket-uri)) + "Return a G-expression that pulls @var{channels} and builds all +packages defined in the first channel. + +@var{guix-daemon-uri} is a file name or URI designating the Guix +daemon endpoint." + (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))) + + (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 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)) + (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 (lambda (pkg) + (derivation-file-name + (parameterize ((%graft? #false)) + (run-with-store store + (package->derivation pkg))))) + (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 value of the returned list is a @code{<forge-laminar-job>} object." |