forge: Support explicit specification of Guix daemon URI.

* forge/forge.scm: Import (srfi srfi-26). Export
forge-configuration-guix-daemon-uri.
(<forge-configuration>)[guix-daemon-uri]: New field.
(forge-project-configuration-laminar-jobs): Accept forge configuration
as argument and pass on guix-daemon-uri to gexp-producer->job-script.
(forge-activation, forge-service-type): Pass forge configuration to
forge-project-configuration-laminar-jobs.
(gexp-producer->job-script): Accept guix-daemon-uri as argument and
parameterize store accesses with it.

1 files changed, 37 insertions, 30 deletions

diff --git a/forge/forge.scm b/forge/forge.scm
index 2c79777..c21ac48 100644
--- a/forge/forge.scm
+++ b/forge/forge.scm
@@ -20,6 +20,7 @@
 (define-module (forge forge)
   #:use-module (gnu)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (gnu packages ci)
   #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
@@ -34,6 +35,7 @@
   #:use-module (forge laminar)
   #:export (forge-service-type
             forge-configuration
+            forge-configuration-guix-daemon-uri
             forge-configuration-projects
             forge-project-configuration
             forge-project-configuration-user
@@ -75,14 +77,17 @@
 (define-record-type* <forge-configuration>
   forge-configuration make-forge-configuration
   forge-configuration?
+  (guix-daemon-uri forge-configuration-guix-daemon-uri
+                   (default (%daemon-socket-uri)))
   (projects forge-configuration-projects
             (default '())))
 
-(define (forge-project-configuration-laminar-jobs project)
+(define (forge-project-configuration-laminar-jobs project config)
   "Return CI jobs of PROJECT as a list of <forge-laminar-job>
-objects. PROJECT is a <forge-project-configuration> object. If PROJECT
-has jobs described by <forge-derivation-job> objects, transform them
-to <forge-laminar-job> objects."
+objects. PROJECT is a <forge-project-configuration> object that is
+part of CONFIG, a <forge-configuration> object. If PROJECT has jobs
+described by <forge-derivation-job> objects, transform them to
+<forge-laminar-job> objects."
   (map (lambda (job)
          (if (forge-derivation-job? job)
              (forge-laminar-job
@@ -94,7 +99,8 @@ to <forge-laminar-job> objects."
                     #:git-checkout-name (string-append (forge-project-configuration-name project)
                                                        "-checkout")
                     #:derivation-name (string-append (forge-derivation-job-name job)
-                                                     "-derivation")))
+                                                     "-derivation")
+                    #:guix-daemon-uri (forge-configuration-guix-daemon-uri config)))
               (after (forge-derivation-job-after job)))
              job))
        (forge-project-configuration-ci-jobs project)))
@@ -122,7 +128,7 @@ to <forge-laminar-job> objects."
                       (post-receive-hook
                        (forge-project-configuration-name project)
                        (map forge-laminar-job-name
-                            (forge-project-configuration-laminar-jobs project)))))
+                            (forge-project-configuration-laminar-jobs project config)))))
               (forge-configuration-projects config))))
     #~(begin
         (use-modules (rnrs io ports)
@@ -166,7 +172,7 @@ to <forge-laminar-job> objects."
     (name (guix-module-name? name))))
 
 (define* (gexp-producer->job-script git-repository git-branch gexp-producer
-                                    #:key git-checkout-name derivation-name)
+                                    #:key git-checkout-name derivation-name guix-daemon-uri)
   "Return a G-expression describing a laminar job script.
 GEXP-PRODUCER is a G-expression that expands to a lambda function.
 The lambda function takes one argument---the latest git checkout of
@@ -185,26 +191,27 @@ derivation to run."
                        (guix store)
                        (rnrs exceptions))
 
-          (with-store store
-            (guard (condition ((store-protocol-error? condition)
-                               (exit #f)))
-              (format (current-error-port)
-                      "Built ~a successfully~%"
-                      (run-with-store store
-                        (mlet* %store-monad ((git-checkout (latest-git-checkout #$git-checkout-name
-                                                                                #$git-repository
-                                                                                #$git-branch
-                                                                                #:git-command #$(file-append git-minimal "/bin/git")))
-                                             (tests-drv (gexp->derivation #$derivation-name
-                                                          (#$gexp-producer git-checkout)
-                                                          #:guile-for-build (read-derivation-from-file
-                                                                             #$(raw-derivation-file
-                                                                                (with-store store
-                                                                                  (package-derivation store guile-3.0))))
-                                                          #:substitutable? #f)))
-                          (mbegin %store-monad
-                            (built-derivations (list tests-drv))
-                            (return (derivation->output-path tests-drv))))))))))))
+          (parameterize ((%daemon-socket-uri #$guix-daemon-uri))
+            (with-store store
+              (guard (condition ((store-protocol-error? condition)
+                                 (exit #f)))
+                (format (current-error-port)
+                        "Built ~a successfully~%"
+                        (run-with-store store
+                          (mlet* %store-monad ((git-checkout (latest-git-checkout #$git-checkout-name
+                                                                                  #$git-repository
+                                                                                  #$git-branch
+                                                                                  #:git-command #$(file-append git-minimal "/bin/git")))
+                                               (tests-drv (gexp->derivation #$derivation-name
+                                                            (#$gexp-producer git-checkout)
+                                                            #:guile-for-build (read-derivation-from-file
+                                                                               #$(raw-derivation-file
+                                                                                  (with-store store
+                                                                                    (package-derivation store guile-3.0))))
+                                                            #:substitutable? #f)))
+                            (mbegin %store-monad
+                              (built-derivations (list tests-drv))
+                              (return (derivation->output-path tests-drv)))))))))))))
 
 (define forge-service-type
   (service-type
@@ -216,11 +223,11 @@ derivation to run."
                                         (lambda (config)
                                           (append
                                            ;; jobs
-                                           (append-map forge-project-configuration-laminar-jobs
+                                           (append-map (cut forge-project-configuration-laminar-jobs <> config)
                                                        (forge-configuration-projects config))
                                            ;; groups
                                            (filter-map (lambda (project)
-                                                         (match (forge-project-configuration-laminar-jobs project)
+                                                         (match (forge-project-configuration-laminar-jobs project config)
                                                            (() #f)
                                                            ((job) #f)
                                                            (jobs
@@ -242,7 +249,7 @@ derivation to run."
                                                                     #$(post-receive-hook
                                                                        (forge-project-configuration-name project)
                                                                        (map forge-laminar-job-name
-                                                                            (forge-project-configuration-laminar-jobs project)))
+                                                                            (forge-project-configuration-laminar-jobs project config)))
                                                                     #:user "laminar")))
                                                       (forge-configuration-projects config))))))
    (default-value (forge-configuration))))