path: root/guix/forge/forge.scm

;;; 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 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* (derivation-job-gexp project job gexp-producer
                              #:key (guix-daemon-uri (%daemon-socket-uri)) deep-clone?)
  "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))))