summaryrefslogtreecommitdiff
path: root/guix/forge/forge.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/forge/forge.scm')
-rw-r--r--guix/forge/forge.scm287
1 files changed, 287 insertions, 0 deletions
diff --git a/guix/forge/forge.scm b/guix/forge/forge.scm
new file mode 100644
index 0000000..e88edb0
--- /dev/null
+++ b/guix/forge/forge.scm
@@ -0,0 +1,287 @@
+;;; guix-forge --- Guix software forge meta-service
+;;; Copyright © 2021, 2022 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 (gnu)
+ #: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)
+ #: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 modules)
+ #:use-module (guix packages)
+ #:use-module (guix records)
+ #:use-module (guix store)
+ #:use-module (forge laminar)
+ #: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))
+
+(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)))
+
+(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))
+ ;; TODO: Only trigger on updates to the main/master branch.
+ (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" '#$(map forge-laminar-job-name ci-jobs)))))
+
+(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
+ (forge-project-name project)
+ (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.
+ (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 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* (derivation-job-gexp project job gexp-producer
+ #:key (guix-daemon-uri (%daemon-socket-uri)))
+ "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."
+ (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)
+ #: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 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
+ (lambda (config)
+ (append
+ ;; jobs
+ (append-map forge-project-ci-jobs
+ (forge-configuration-projects config))
+ ;; group jobs by project
+ (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)))))
+ ;; Set up cron jobs to trigger CI jobs for remote
+ ;; repositories.
+ ;; TODO: Run CI job only if there are new commits
+ ;; in the remote repository.
+ (service-extension mcron-service-type
+ (lambda (config)
+ (filter-map (lambda (project)
+ (and (eq? (forge-project-ci-jobs-trigger project)
+ 'cron)
+ #~(job '(next-day)
+ #$(program-file
+ (forge-project-name project)
+ (ci-jobs-trigger-gexp
+ (forge-project-ci-jobs project)
+ #:reason "Cron job"))
+ #:user "laminar")))
+ (forge-configuration-projects config))))
+ (service-extension webhook-service-type
+ (lambda (config)
+ (filter-map (lambda (project)
+ (and (eq? (forge-project-ci-jobs-trigger project)
+ 'webhook)
+ (webhook-hook
+ (id (forge-project-name project))
+ (run (ci-jobs-trigger-gexp
+ (forge-project-ci-jobs project)
+ #:reason "Webhook")))))
+ (forge-configuration-projects config))))))
+ (compose concatenate)
+ (extend (lambda (config projects)
+ (forge-configuration
+ (inherit config)
+ (projects (append (forge-configuration-projects config)
+ projects)))))
+ (default-value (forge-configuration))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-11-22 23:20:43 +0000