diff options
| -rw-r--r-- | forge/forge.scm | 154 | ||||
| -rw-r--r-- | forge/laminar.scm | 124 |
2 files changed, 278 insertions, 0 deletions
diff --git a/forge/forge.scm b/forge/forge.scm new file mode 100644 index 0000000..66113c9 --- /dev/null +++ b/forge/forge.scm @@ -0,0 +1,154 @@ +;;; guix-forge --- Guix software forge meta-service +;;; Copyright © 2021 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 (ice-9 match) + #:use-module (gnu services mcron) + #:use-module (guix records) + #:use-module (forge laminar) + #:export (forge-service-type + forge-configuration + forge-configuration-projects + forge-project-configuration + forge-project-configuration-user + forge-project-configuration-repository + forge-project-configuration-website-directory + forge-project-configuration-ci-jobs)) + +(define-record-type* <forge-project-configuration> + forge-project-configuration make-forge-project-configuration + forge-project-configuration? + (name forge-project-configuration-name) + (user forge-project-configuration-user) + (repository forge-project-configuration-repository) + (description forge-project-configuration-description + (default #f)) + (website-directory forge-project-configuration-website-directory + (default #f)) + (ci-jobs forge-project-configuration-ci-jobs + (default '()))) + +(define-record-type* <forge-configuration> + forge-configuration make-forge-configuration + forge-configuration? + (projects forge-configuration-projects + (default '()))) + +(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") + (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)) + (apply invoke + #$(file-append laminar "/bin/laminarc") + "queue" '#$ci-jobs))))) + +(define (forge-activation config) + (let ((projects + (map (lambda (project) + (list (forge-project-configuration-user project) + (forge-project-configuration-repository project) + (forge-project-configuration-description project) + (forge-project-configuration-website-directory project) + (post-receive-hook + (forge-project-configuration-name project) + (map guix-laminar-job-name + (forge-project-configuration-ci-jobs 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 post-receive-hook) + ;; For local repositories only + (when (string-prefix? "/" repository) + ;; Set description. + (when description + (call-with-output-file (string-append repository "/description") + (cut put-string <> description))) + ;; Install post receive hook. + (let ((hook-link (string-append repository "/hooks/post-receive"))) + (when (file-exists? hook-link) + (delete-file hook-link)) + (symlink post-receive-hook hook-link)) + ;; 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)))) + ;; Set ownership of website directory. + (when website-directory + (let ((user (getpw "laminar"))) + (chown website-directory (passwd:uid user) (passwd:gid user)))))) + '#$projects)))) + +(define forge-service-type + (service-type + (name 'forge) + (description "Run guix-forge.") + (extensions (list (service-extension activation-service-type + forge-activation) + (service-extension guix-laminar-service-type + (lambda (config) + (append + ;; jobs + (append-map forge-project-configuration-ci-jobs + (forge-configuration-projects config)) + ;; groups + (filter-map (lambda (project) + (match (forge-project-configuration-ci-jobs project) + (() #f) + ((job) #f) + (jobs + (guix-laminar-group + (name (forge-project-configuration-name project)) + (regex (string-join (map guix-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 (not (string-prefix? + "/" (forge-project-configuration-repository project))) + #~(job '(next-day) + #$(post-receive-hook + (forge-project-configuration-name project) + (map guix-laminar-job-name + (forge-project-configuration-ci-jobs project))) + #:user "laminar"))) + (forge-configuration-projects config)))))) + (default-value (forge-configuration)))) diff --git a/forge/laminar.scm b/forge/laminar.scm new file mode 100644 index 0000000..9cfb3d1 --- /dev/null +++ b/forge/laminar.scm @@ -0,0 +1,124 @@ +;;; guix-forge --- Guix software forge meta-service +;;; Copyright © 2021 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 laminar) + #:use-module (gnu) + #:use-module (srfi srfi-1) + #:use-module (gnu packages ci) + #:use-module (guix records) + #:export (guix-laminar-service-type + guix-laminar-configuration + guix-laminar-configuration-state-directory + guix-laminar-configuration-jobs + guix-laminar-job + guix-laminar-job? + guix-laminar-job-name + guix-laminar-job-run + guix-laminar-job-after + guix-laminar-group + guix-laminar-group? + guix-laminar-group-name + guix-laminar-group-regex)) + +(define-record-type* <guix-laminar-configuration> + guix-laminar-configuration make-guix-laminar-configuration + guix-laminar-configuration? + (state-directory guix-laminar-configuration-state-directory + (default "/var/lib/laminar")) + (jobs guix-laminar-configuration-jobs + (default '())) + (groups guix-laminar-configuration-groups + (default '()))) + +(define-record-type* <guix-laminar-job> + guix-laminar-job make-guix-laminar-job + guix-laminar-job? + (name guix-laminar-job-name) + (run guix-laminar-job-run) + (after guix-laminar-job-after + (default #f))) + +(define-record-type* <guix-laminar-group> + guix-laminar-group make-guix-laminar-group + guix-laminar-group? + (name guix-laminar-group-name) + (regex guix-laminar-group-regex)) + +(define (guix-laminar-activation config) + (let* ((state-directory (guix-laminar-configuration-state-directory config)) + (groups-configuration (string-append state-directory "/cfg/groups.conf")) + (jobs-directory (string-append state-directory "/cfg/jobs"))) + #~(begin + (use-modules (srfi srfi-26)) + + ;; Configure groups. + (when (file-exists? #$groups-configuration) + (delete-file #$groups-configuration)) + (symlink + #$(plain-file "laminar-groups" + (string-join (map (lambda (group) + (string-append (guix-laminar-group-name group) + "=" + (guix-laminar-group-regex group))) + (guix-laminar-configuration-groups config)) + "\n")) + #$groups-configuration) + ;; Create jobs directory and populate with job scripts. + (mkdir-p #$(dirname jobs-directory)) + (when (file-exists? #$jobs-directory) + (delete-file #$jobs-directory)) + (symlink + #$(file-union "laminar-jobs" + (append-map (lambda (job) + (let ((name (guix-laminar-job-name job)) + (run (guix-laminar-job-run job)) + (after (guix-laminar-job-after job))) + (cons (list (string-append name ".run") + (program-file name run)) + (if after + (list (list (string-append name ".after") + (program-file name after))) + (list))))) + (guix-laminar-configuration-jobs config))) + #$jobs-directory) + ;; Set permissions for laminar directory. + (for-each (lambda (file) + (let ((user (getpw "laminar"))) + (chown file (passwd:uid user) (passwd:gid user)))) + (find-files #$state-directory + (lambda (file stat) + (memq (stat:type stat) + '(regular directory))) + #:directories? #t))))) + +(define guix-laminar-service-type + (service-type + (name 'guix-laminar) + (description "Run guix-laminar.") + (extensions (list (service-extension activation-service-type + guix-laminar-activation))) + (compose concatenate) + (extend (lambda (config extended-values) + (guix-laminar-configuration + (inherit config) + (jobs (append (guix-laminar-configuration-jobs config) + (filter guix-laminar-job? extended-values))) + (groups (append (guix-laminar-configuration-groups config) + (filter guix-laminar-group? extended-values)))))) + (default-value (guix-laminar-configuration)))) |