diff options
Diffstat (limited to 'guix/forge/forge.scm')
| -rw-r--r-- | guix/forge/forge.scm | 88 |
1 files changed, 76 insertions, 12 deletions
diff --git a/guix/forge/forge.scm b/guix/forge/forge.scm index bad6b8b..d60298f 100644 --- a/guix/forge/forge.scm +++ b/guix/forge/forge.scm @@ -26,6 +26,7 @@ #: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 guile-xyz) #:select (guile-lib)) + #:use-module ((gnu packages mail) #:select (msmtp)) #:use-module ((gnu packages nss) #:select (nss-certs)) #:use-module ((gnu packages package-management) #:select (guix)) #:use-module ((gnu packages version-control) #:select (git-minimal)) @@ -49,10 +50,12 @@ #:export (forge-service-type forge-configuration forge-configuration? + this-forge-configuration forge-configuration-web-domain forge-configuration-tissue-web-domain forge-configuration-websites-directory forge-configuration-web-root + forge-configuration-mailer-address forge-configuration-projects forge-project forge-project? @@ -66,6 +69,7 @@ forge-project-website-ci-job forge-project-ci-jobs forge-project-ci-jobs-trigger + forge-project-ci-notify-addresses forge-project-parallel-ci-job-runs derivation-job-gexp variable-specification @@ -93,7 +97,6 @@ (tissue? forge-project-tissue? (default #f)) (website-ci-job forge-project-website-ci-job - ;; TODO: Add default website builder. (default #f) (thunked)) (ci-jobs forge-project-ci-jobs @@ -106,6 +109,8 @@ ;; 'cron for remote repositories (else 'cron))) (thunked)) + (ci-notify-addresses forge-project-ci-notify-addresses + (default '())) (parallel-ci-job-runs forge-project-parallel-ci-job-runs (default 1))) @@ -122,6 +127,10 @@ (default (computed-file "forge-web-root" (forge-web-root-gexp this-forge-configuration))) (thunked)) + (mailer-address forge-configuration-mailer-address + (default (string-append "mail@" + (forge-configuration-web-domain this-forge-configuration))) + (thunked)) (projects forge-configuration-projects (default '()))) @@ -139,14 +148,21 @@ `(html (body ,@(map (match-lambda - ((name description) - `((h2 ,name) + ((name description website-link) + `((h2 ,(if website-link + `(a (@ (href ,website-link)) + ,name) + name)) ,@(if description `((p ,description)) '())))) '#$(map (lambda (project) (list (forge-project-name project) - (forge-project-description project))) + (forge-project-description project) + (and (forge-project-website-ci-job project) + (if (forge-project-web-domain project) + (string-append "https://" (forge-project-web-domain project)) + (string-append "/" (forge-project-name project) "/"))))) (forge-configuration-projects config)))))))) (call-with-output-file (string-append #$output "/index.html") (cut put-string <> html)))))) @@ -194,7 +210,7 @@ (string-append (forge-project-name project) "-post-receive-hook") (ci-jobs-trigger-gexp - (forge-project-ci-jobs project) + (forge-project-all-ci-jobs project config) #:reason "post-receive hook")) (forge-project-ci-jobs-trigger project))) (forge-configuration-projects config)))) @@ -560,15 +576,63 @@ forge configuration @var{config}." projects)))) (list)))) +(define (ci-notify-by-email from to) + "Return a G-expression that emails @var{to} addresses from @var{from} address +about the status of a laminar CI job. The returned G-expression is intended to +be used as the @code{after} field of a @code{<forge-laminar-job>} object." + #~(begin + (use-modules (ice-9 popen) + (srfi srfi-26)) + + (define (call-with-output-pipe command proc) + (let ((port #f)) + (dynamic-wind + (cut set! port (apply open-pipe* OPEN_WRITE command)) + (cut proc port) + (lambda () + (unless (zero? (status:exit-val (close-pipe port))) + (error "Command invocation failed" command)))))) + + (let ((job (getenv "JOB")) + (run (getenv "RUN")) + (result (getenv "RESULT")) + (last-result (getenv "LAST_RESULT"))) + (unless (string=? result last-result) + (call-with-output-pipe (list #$(file-append msmtp "/bin/msmtp") + "--host=localhost" + "--port=587" + "--read-recipients") + (cut format + <> + "From: ~a +To: ~a +Subject: Laminar ~a #~a: ~a + +See https://ci.systemreboot.net/jobs/~a/~a for details. +" + #$from + #$(string-join to ",") + job run result job run)))))) + (define (forge-project-all-ci-jobs project config) "Return list of all CI jobs for @var{project} in forge configuration @var{config}." - ;; Add project context to CI jobs. (map (lambda (job) (forge-laminar-job (inherit job) + ;; Add project context to job. (contexts (cons (forge-project-name project) - (forge-laminar-job-contexts job))))) + (forge-laminar-job-contexts job))) + ;; Add CI email notification to job. + (after #~(begin + #$@(cond + ((forge-laminar-job-after job) => list) + (else (list))) + #$(match (forge-project-ci-notify-addresses project) + (() #f) + (addresses + (ci-notify-by-email (forge-configuration-mailer-address config) + addresses))))))) ;; Prepend website CI job to the other CI jobs. (if (forge-project-website-ci-job project) (cons (forge-laminar-job @@ -602,7 +666,7 @@ value of the returned list is a @code{<forge-laminar-job>} object." @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) + (match (forge-project-all-ci-jobs project config) (() #f) ((job) #f) (jobs @@ -631,13 +695,13 @@ mcron job specification." (and (eq? (forge-project-ci-jobs-trigger project) 'cron) (any forge-laminar-job-trigger? - (forge-project-ci-jobs project)) + (forge-project-all-ci-jobs project config)) #~(job '(next-day) #$(program-file (string-append (forge-project-name project) "-cron-job") (ci-jobs-trigger-gexp - (forge-project-ci-jobs project) + (forge-project-all-ci-jobs project config) #:reason "Cron job")) #:user "laminar"))) (forge-configuration-projects config))) @@ -649,11 +713,11 @@ value is a list of @code{<webhook-hook>} objects." (and (eq? (forge-project-ci-jobs-trigger project) 'webhook) (any forge-laminar-job-trigger? - (forge-project-ci-jobs project)) + (forge-project-all-ci-jobs project config)) (webhook-hook (id (forge-project-name project)) (run (ci-jobs-trigger-gexp - (forge-project-ci-jobs project) + (forge-project-all-ci-jobs project config) #:reason "Webhook"))))) (forge-configuration-projects config))) |