Initial commit

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))))