From cb7cecae3f6152052bdaf601eb1f6fcb2727b6b9 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 2 Mar 2022 17:55:27 +0530 Subject: Move channel modules into subdirectory. We don't want the scm files in doc to be picked up on `guix pull'. * .guix-channel: New file. * forge: Move to guix/forge. --- forge/forge.scm | 287 -------------------------------------------------------- 1 file changed, 287 deletions(-) delete mode 100644 forge/forge.scm (limited to 'forge/forge.scm') diff --git a/forge/forge.scm b/forge/forge.scm deleted file mode 100644 index e88edb0..0000000 --- a/forge/forge.scm +++ /dev/null @@ -1,287 +0,0 @@ -;;; guix-forge --- Guix software forge meta-service -;;; Copyright © 2021, 2022 Arun Isaac -;;; -;;; 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 -;;; . - -(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 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 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 - 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 - object---and returns a G-expression describing a -derivation to run. JOB is a 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)))) -- cgit v1.2.3