;;; guix-forge --- Guix software forge meta-service
;;; Copyright © 2021–2024 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of guix-forge.
;;;
;;; guix-forge is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; guix-forge is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with guix-forge. If not, see
;;; <https://www.gnu.org/licenses/>.
(define-module (forge forge)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#: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-bytestructures guile-zlib))
#:use-module ((gnu packages package-management) #:select (guix))
#:use-module ((gnu packages version-control) #:select (git-minimal))
#:use-module (gnu services)
#:use-module (gnu services mcron)
#:use-module (guix channels)
#:use-module (guix deprecation)
#:use-module (guix gexp)
#:use-module (guix modules)
#:use-module (guix packages)
#:use-module (guix profiles)
#: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 webhook)
#:export (forge-service-type
forge-configuration
forge-configuration?
forge-configuration-projects
forge-project
forge-project?
this-forge-project
forge-project-name
forge-project-user
forge-project-repository
forge-project-repository-branch
forge-project-website-directory
forge-project-ci-jobs
forge-project-ci-jobs-trigger
derivation-job-gexp
variable-specification
variable-specification?
variable-specification-module
variable-specification-name
guix-channel-job-gexp))
(define-record-type* <forge-project>
forge-project make-forge-project
forge-project?
this-forge-project
(name forge-project-name)
;; The user field is optional because the repository may be remote
;; and not need to be owned by any user.
(user forge-project-user
(default #f))
(repository forge-project-repository)
(repository-branch forge-project-repository-branch
(default "main"))
(description forge-project-description
(default #f))
(website-directory forge-project-website-directory
(default #f))
(ci-jobs forge-project-ci-jobs
(default '()) (thunked))
(ci-jobs-trigger forge-project-ci-jobs-trigger ; one of 'post-receive-hook, 'cron, 'webhook
(default (cond
;; 'post-receive-hook for local repositories
((string-prefix? "/" (forge-project-repository this-forge-project))
'post-receive-hook)
;; 'cron for remote repositories
(else 'cron)))
(thunked))
(parallel-ci-job-runs forge-project-parallel-ci-job-runs
(default 1)))
(define-record-type* <forge-configuration>
forge-configuration make-forge-configuration
forge-configuration?
(projects forge-configuration-projects
(default '())))
(define* (ci-jobs-trigger-gexp ci-jobs #:key reason)
"Return a G-expression that triggers CI-JOBS. CI-JOBS is a list of
<forge-laminar-job> objects."
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
(ice-9 match))
;; TODO: Only trigger on updates to the main/master branch.
;; Trigger jobs if there are jobs that need to be
;; triggered.
;;
;; Even if there are none, we still need to manage the
;; post-receive-hook to ensure that it does not go
;; stale. Suppose that in one generation the user configures
;; CI jobs, but removes them in the next generation. If we did
;; not write to the post-receive-hook in the second
;; generation, it would still retain its previous contents and
;; trigger the jobs from the first generation.
(match '#$(filter-map (lambda (job)
(and (forge-laminar-job-trigger? job)
(forge-laminar-job-name job)))
ci-jobs)
(() #t)
(job-names
(display "Triggering continuous integration jobs..." (current-error-port))
(newline (current-error-port))
(when #$reason
(setenv "LAMINAR_REASON" #$reason))
(apply invoke
#$(file-append laminar "/bin/laminarc")
"queue" job-names))))))
(define (forge-activation config)
(let ((projects
(map (lambda (project)
(list (forge-project-user project)
(forge-project-repository project)
(forge-project-description project)
(forge-project-website-directory project)
(program-file
(string-append (forge-project-name project)
"-post-receive-hook")
(ci-jobs-trigger-gexp
(forge-project-ci-jobs project)
#:reason "post-receive hook"))
(forge-project-ci-jobs-trigger project)))
(forge-configuration-projects config))))
#~(begin
(use-modules (rnrs io ports)
(srfi srfi-26)
(ice-9 match))
(define (find-regular-files dir)
(find-files dir (lambda (file stat)
(memq (stat:type stat)
'(regular directory)))
#:directories? #t))
(for-each (match-lambda
((username repository description website-directory ci-jobs-trigger ci-jobs-trigger-type)
;; For local repositories only
(when (string-prefix? "/" repository)
;; Set description.
(when description
(call-with-output-file (string-append repository "/description")
(cut put-string <> description)))
;; Set ownership of repository files when the
;; user field is set. This enables setups where
;; ownership is manually managed. TODO: Rethink
;; this when we move to repositories owned and
;; operated on by virtual users.
(when username
(for-each (lambda (file)
(let ((user (getpw username)))
(chown file (passwd:uid user) (passwd:gid user))))
(append (find-regular-files repository)))))
;; Install post receive hook.
(when (eq? ci-jobs-trigger-type 'post-receive-hook)
(let ((hook-link (string-append repository "/hooks/post-receive")))
(when (file-exists? hook-link)
(delete-file hook-link))
(symlink ci-jobs-trigger hook-link)))
;; Set ownership of website directory.
(when website-directory
(let ((user (getpw "laminar")))
(chown (dirname 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-deprecated (derivation-job-gexp project job gexp-producer
#:key (guix-daemon-uri (%daemon-socket-uri)) deep-clone?)
guix-channel-job-gexp
"Return a G-expression that builds another G-expression as a
derivation and returns its output path. GEXP-PRODUCER is a
G-expression that expands to a lambda function. The lambda function
takes one argument---the latest git checkout of PROJECT, a
<forge-project> object---and returns a G-expression describing a
derivation to run. JOB is a <forge-laminar-job> object representing
the job that this derivation will be part of.
GUIX_DAEMON_URI is a file name or URI designating the Guix daemon
endpoint.
If DEEP-CLONE? is #t, the git checkout is a deep clone of the
repository that includes the .git directory. Else, it is a shallow
clone and does not include the .git directory."
(with-imported-modules (source-module-closure '((forge build git)
(guix gexp)
(guix profiles))
#:select? import-module?)
(with-extensions (list guile-gcrypt guile-zlib)
(with-packages (list git-minimal nss-certs)
#~(begin
;; 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)))
(mbegin (macro-transformer
(module-ref (resolve-module '(guix monads))
'mbegin)))
(mlet* (macro-transformer
(module-ref (resolve-module '(guix monads))
'mlet*)))
(with-store (macro-transformer
(module-ref (resolve-module '(guix store))
'with-store)))
(return (identifier-syntax ((@@ (guix store) %store-monad)
%return))))
(let* ((latest-git-checkout (@@ (forge build git) latest-git-checkout))
(built-derivations (@@ (guix derivations) built-derivations))
(derivation->output-path (@@ (guix derivations) derivation->output-path))
(read-derivation-from-file (@@ (guix derivations) read-derivation-from-file))
(gexp->derivation (@@ (guix gexp) gexp->derivation))
(%daemon-socket-uri (@@ (guix store) %daemon-socket-uri))
(%store-monad (@@ (guix store) %store-monad))
(store-protocol-error? (@@ (guix store) store-protocol-error?))
(run-with-store (@@ (guix store) run-with-store))
(derivation-output
(parameterize ((%daemon-socket-uri #$guix-daemon-uri))
(with-store store
(guard (condition ((store-protocol-error? condition)
(exit #f)))
(run-with-store store
(mlet* %store-monad ((git-checkout (latest-git-checkout
#$(string-append (forge-project-name project)
"-checkout")
#$(forge-project-repository project)
#:deep-clone? #$deep-clone?
#:show-commit? #t))
(drv (gexp->derivation #$(string-append
(forge-laminar-job-name job)
"-derivation")
(#$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 drv))
(return (derivation->output-path drv))))))))))
(format (current-error-port) "Built ~a successfully~%" derivation-output)
derivation-output)))))))
(define-record-type* <variable-specification>
variable-specification make-variable-specification
variable-specification?
(module variable-specification-module)
(name variable-specification-name))
(define* (guix-channel-job-gexp channels
#:key
variables
(guix-daemon-uri %daemon-socket-uri)
(verbose? #true))
"Return a G-expression that pulls @var{channels} and builds
@var{variables}, a list of @code{<variable-specification>} objects. If
@var{variables} is @code{#f}, all packages defined in the first
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.
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 "~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 (lambda (item)
(derivation-file-name
(parameterize ((%graft? #false))
(run-with-store store
(lower-object item)))))
#$(if variables
#~(map (match-lambda
((module-name variable-name)
(module-ref (resolve-module 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
value of the returned list is a @code{<forge-laminar-job>} object."
(append-map (lambda (project)
;; Add project context to CI jobs.
(map (lambda (job)
(forge-laminar-job
(inherit job)
(contexts (cons (forge-project-name project)
(forge-laminar-job-contexts job)))))
(forge-project-ci-jobs project)))
(forge-configuration-projects config)))
(define (forge-ci-job-contexts config)
"Return list of CI job contexts for forge configuration
@var{config}. Each element of the returned list is a
@code{<forge-laminar-context>} object."
(filter-map (lambda (project)
(forge-laminar-context
(name (forge-project-name project))
(executors (forge-project-parallel-ci-job-runs project))))
(forge-configuration-projects config)))
(define (forge-ci-job-groups config)
"Return list of CI job groups for forge configuration
@var{config}. Each element of the returned list is a
@code{<forge-laminar-group>} object."
(filter-map (lambda (project)
(match (forge-project-ci-jobs project)
(() #f)
((job) #f)
(jobs
(forge-laminar-group
(name (forge-project-name project))
(regex (string-append "^(?:"
(string-join (map forge-laminar-job-name jobs)
"|")
")$"))))))
(forge-configuration-projects config)))
(define (forge-ci-jobs+contexts+groups config)
"Return list of CI jobs and job groups for forge configuration
@var{config}. Each element of the returned list is either a
@code{<forge-laminar-job>}, @code{<forge-laminar-context>} or
@code{<forge-laminar-group>} object."
(append (forge-ci-jobs config)
(forge-ci-job-contexts config)
(forge-ci-job-groups config)))
(define (forge-cron-jobs config)
"Return list of cron jobs for forge configuration @var{config}. Each
element of the returned list is a G-expression corresponding to an
mcron job specification."
(filter-map (lambda (project)
(and (eq? (forge-project-ci-jobs-trigger project)
'cron)
(any forge-laminar-job-trigger?
(forge-project-ci-jobs project))
#~(job '(next-day)
#$(program-file
(string-append (forge-project-name project)
"-cron-job")
(ci-jobs-trigger-gexp
(forge-project-ci-jobs project)
#:reason "Cron job"))
#:user "laminar")))
(forge-configuration-projects config)))
(define (forge-webhooks config)
"Return list of webhooks for forge configuration @var{config}. Return
value is a list of @code{<webhook-hook>} objects."
(filter-map (lambda (project)
(and (eq? (forge-project-ci-jobs-trigger project)
'webhook)
(any forge-laminar-job-trigger?
(forge-project-ci-jobs project))
(webhook-hook
(id (forge-project-name project))
(run (ci-jobs-trigger-gexp
(forge-project-ci-jobs project)
#:reason "Webhook")))))
(forge-configuration-projects config)))
(define forge-service-type
(service-type
(name 'forge)
(description "Run guix-forge.")
(extensions (list (service-extension activation-service-type
forge-activation)
(service-extension forge-laminar-service-type
forge-ci-jobs+contexts+groups)
;; TODO: Run CI job only if there are new commits
;; in the remote repository.
(service-extension mcron-service-type
forge-cron-jobs)
(service-extension webhook-service-type
forge-webhooks)))
(compose concatenate)
(extend (lambda (config projects)
(forge-configuration
(inherit config)
(projects (append (forge-configuration-projects config)
projects)))))
(default-value (forge-configuration))))
