From 1a9c0a9e329f835b53409e9a3f0949e204cf9073 Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Wed, 5 Jul 2023 21:43:03 +0100
Subject: forge: Introduce guix-channel-job-gexp.

* guix/forge/forge.scm: Import guile-bytestructures from (gnu packages
guile), guix from (gnu packages package-management), (guix channels),
guile-git from (forge guile-git), (forge tissue) and (forge web).
(guix-channel-job-gexp): New public function.
---
 guix/forge/forge.scm | 117 +++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 114 insertions(+), 3 deletions(-)

(limited to 'guix')

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."
-- 
cgit v1.2.3