forge: Add derivation jobs to be executed by the Guix daemon.

* forge/forge.scm: Import guile-gcrypt from (gnu packages gnupg),
guile-3.0 and guile-zlib from (gnu packages guile), git-minimal
from (gnu packages version-control), (guix gexp), (guix
modules), (guix packages), and (guix store). Export
forge-derivation-job, forge-derivation-job-name,
forge-derivation-job-run and forge-derivation-job-after.
(<forge-derivation-job>): New type.
(forge-project-configuration-laminar-jobs, import-module?,
gexp-producer->job-script): New function.
(forge-activation, forge-service-type): Call
forge-project-configuration-laminar-jobs instead of
forge-project-configuration-ci-jobs.

1 files changed, 92 insertions, 5 deletions

diff --git a/forge/forge.scm b/forge/forge.scm
index 0ed1ce1..2c79777 100644
--- a/forge/forge.scm
+++ b/forge/forge.scm
@@ -22,8 +22,15 @@
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:use-module (gnu packages ci)
+  #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
+  #:use-module ((gnu packages guile) #:select (guile-3.0 guile-zlib))
+  #:use-module ((gnu packages version-control) #:select (git-minimal))
   #:use-module (gnu services mcron)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix packages)
   #:use-module (guix records)
+  #:use-module (guix store)
   #:use-module (forge laminar)
   #:export (forge-service-type
             forge-configuration
@@ -33,7 +40,11 @@
             forge-project-configuration-repository
             forge-project-configuration-repository-branch
             forge-project-configuration-website-directory
-            forge-project-configuration-ci-jobs))
+            forge-project-configuration-ci-jobs
+            forge-derivation-job
+            forge-derivation-job-name
+            forge-derivation-job-run
+            forge-derivation-job-after))
 
 (define-record-type* <forge-project-configuration>
   forge-project-configuration make-forge-project-configuration
@@ -53,12 +64,41 @@
   (ci-jobs forge-project-configuration-ci-jobs
            (default '())))
 
+(define-record-type* <forge-derivation-job>
+  forge-derivation-job make-forge-derivation-job
+  forge-derivation-job?
+  (name forge-derivation-job-name)
+  (run forge-derivation-job-run)
+  (after forge-derivation-job-after
+         (default #f)))
+
 (define-record-type* <forge-configuration>
   forge-configuration make-forge-configuration
   forge-configuration?
   (projects forge-configuration-projects
             (default '())))
 
+(define (forge-project-configuration-laminar-jobs project)
+  "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."
+  (map (lambda (job)
+         (if (forge-derivation-job? job)
+             (forge-laminar-job
+              (name (forge-derivation-job-name job))
+              (run (gexp-producer->job-script
+                    (forge-project-configuration-repository project)
+                    (forge-project-configuration-repository-branch project)
+                    (forge-derivation-job-run job)
+                    #:git-checkout-name (string-append (forge-project-configuration-name project)
+                                                       "-checkout")
+                    #:derivation-name (string-append (forge-derivation-job-name job)
+                                                     "-derivation")))
+              (after (forge-derivation-job-after job)))
+             job))
+       (forge-project-configuration-ci-jobs project)))
+
 (define (post-receive-hook project-name ci-jobs)
   "Return a git post-receive-hook that triggers CI-JOBS."
   (program-file (string-append project-name "-post-receive-hook")
@@ -82,7 +122,7 @@
                       (post-receive-hook
                        (forge-project-configuration-name project)
                        (map forge-laminar-job-name
-                            (forge-project-configuration-ci-jobs project)))))
+                            (forge-project-configuration-laminar-jobs project)))))
               (forge-configuration-projects config))))
     #~(begin
         (use-modules (rnrs io ports)
@@ -119,6 +159,53 @@
                          (chown website-directory (passwd:uid user) (passwd:gid user))))))
                   '#$projects))))
 
+(define (import-module? name)
+  "Return #t if module NAME may be imported.  Else, return #f."
+  (match name
+    (('forge _ ...) #t)
+    (name (guix-module-name? name))))
+
+(define* (gexp-producer->job-script git-repository git-branch gexp-producer
+                                    #:key git-checkout-name derivation-name)
+  "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
+GIT-REPOSITORY at GIT-BRANCH---and returns a G-expression describing a
+derivation to run."
+  (with-imported-modules (source-module-closure '((forge build git)
+                                                  (guix gexp)
+                                                  (guix profiles))
+                                                #:select? import-module?)
+    (with-extensions (list guile-gcrypt guile-zlib)
+      #~(begin
+          (use-modules (forge build git)
+                       (guix derivations)
+                       (guix gexp)
+                       (guix monads)
+                       (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))))))))))))
+
 (define forge-service-type
   (service-type
    (name 'forge)
@@ -129,11 +216,11 @@
                                         (lambda (config)
                                           (append
                                            ;; jobs
-                                           (append-map forge-project-configuration-ci-jobs
+                                           (append-map forge-project-configuration-laminar-jobs
                                                        (forge-configuration-projects config))
                                            ;; groups
                                            (filter-map (lambda (project)
-                                                         (match (forge-project-configuration-ci-jobs project)
+                                                         (match (forge-project-configuration-laminar-jobs project)
                                                            (() #f)
                                                            ((job) #f)
                                                            (jobs
@@ -155,7 +242,7 @@
                                                                     #$(post-receive-hook
                                                                        (forge-project-configuration-name project)
                                                                        (map forge-laminar-job-name
-                                                                            (forge-project-configuration-ci-jobs project)))
+                                                                            (forge-project-configuration-laminar-jobs project)))
                                                                     #:user "laminar")))
                                                       (forge-configuration-projects config))))))
    (default-value (forge-configuration))))