Subject: [bug#47392] [PATCH 2/2] services: Add Laminar.

From: Christopher Baines <[email-masked]>
Date: Thu, 25 Mar 2021 15:26:12 +0000

* gnu/services/ci.scm: New file.
* gnu/tests/ci.scm: New file.
* doc/guix.texi (Laminar): Document the Laminar service.
---
 doc/guix.texi       |  54 ++++++++++++++++++-
 gnu/services/ci.scm | 128 +++++++++++++++++++++++++++++++++++++++++++
 gnu/tests/ci.scm    | 129 ++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 309 insertions(+), 2 deletions(-)
 create mode 100644 gnu/services/ci.scm
 create mode 100644 gnu/tests/ci.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 74f3fbd299..bd087dae05 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -342,7 +342,7 @@ Services
 * DNS Services::                DNS daemons.
 * VPN Services::                VPN daemons.
 * Network File System::         NFS related services.
-* Continuous Integration::      The Cuirass service.
+* Continuous Integration::      Cuirass and Laminar services.
 * Power Management Services::   Extending battery life.
 * Audio Services::              The MPD.
 * Virtualization Services::     Virtualization services.
@@ -14798,7 +14798,7 @@ declaration.
 * DNS Services::                DNS daemons.
 * VPN Services::                VPN daemons.
 * Network File System::         NFS related services.
-* Continuous Integration::      The Cuirass service.
+* Continuous Integration::      Cuirass and Laminar services.
 * Power Management Services::   Extending battery life.
 * Audio Services::              The MPD.
 * Virtualization Services::     Virtualization services.
@@ -27301,6 +27301,56 @@ the store items being published.
 @end table
 @end deftp
 
+@subsubheading Laminar
+
+@uref{https://laminar.ohwg.net/, Laminar} is a lightweight and modular
+Continuous Integration service.  It doesn't have a configuration web UI
+instead uses version-controllable configuration files and scripts.
+
+Laminar encourages the use of existing GNU/Linux tools such as bash and
+cron instead of reinventing them.
+
+@defvr {Scheme Procedure} laminar-service-type
+The type of the Laminar service.  Its value must be a
+@code{laminar-configuration} object, as described below.
+@end defvr
+
+@deftp {Data Type} laminar-configuration
+Data type representing the configuration of Laminar.
+
+@table @asis
+@item @code{laminar} (default: @code{laminar})
+The Laminar package to use.
+
+@item @code{home-directory} (default: @code{"/var/lib/laminar"})
+The directory for job configurations and run directories.
+
+@item @code{bind-http} (default: @code{"*:8080"})
+The interface/port or unix socket on which laminard should listen for
+incoming connections to the web frontend.
+
+@item @code{bind-rpc} (default: @code{"unix-abstract:laminar"})
+The interface/port or unix socket on which laminard should listen for
+incoming commands such as build triggers.
+
+@item @code{title} (default: @code{"Laminar"})
+The page title to show in the web frontend.
+
+@item @code{keep-rundirs} (default: @code{0})
+Set to an integer defining how many rundirs to keep per job.  The
+lowest-numbered ones will be deleted.  The default is 0, meaning all run
+dirs will be immediately deleted.
+
+@item @code{archive-url} (default: @code{#f})
+The web frontend served by laminard will use this URL to form links to
+artefacts archived jobs.
+
+@item @code{base-url} (default: @code{#f})
+Base URL to use for links to laminar itself.
+
+@end table
+@end deftp
+
 @node Power Management Services
 @subsection Power Management Services
 
diff --git a/gnu/services/ci.scm b/gnu/services/ci.scm
new file mode 100644
index 0000000000..400980dcd4
--- /dev/null
+++ b/gnu/services/ci.scm
@@ -0,0 +1,128 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Christopher Baines <[email-masked]>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu services ci)
+  #:use-module (guix gexp)
+  #:use-module (guix records)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu packages ci)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu services admin)
+  #:use-module (gnu system shadow)
+  #:use-module (ice-9 match)
+  #:export (<laminar-configuration>
+            laminar-configuration
+            laminar-configuration?
+            laminar-configuration-home-directory
+            laminar-configuration-bind-http
+            laminar-configuration-bind-rpc
+            laminar-configuration-title
+            laminar-configuration-keep-rundirs
+            laminar-configuration-archive-url
+            laminar-configuration-base-url
+
+            laminar-service-type))
+
+;;;; Commentary:
+;;;
+;;; This module implements a service that to run instances of Laminar, a
+;;; continuous integration tool.
+;;;
+;;;; Code:
+
+(define-record-type* <laminar-configuration>
+  laminar-configuration make-laminar-configuration
+  laminar-configuration?
+  (laminar          laminars-configuration-laminar
+                    (default laminar))
+  (home-directory   laminar-configuration-home-directory
+                    (default "/var/lib/laminar"))
+  (bind-http        laminar-configuration-bind-http
+                    (default "*:8080"))
+  (bind-rpc         laminar-configuration-bind-rpc
+                    (default "unix-abstract:laminar"))
+  (title            laminar-configuration-title
+                    (default "Laminar"))
+  (keep-rundirs     laminar-keep-rundirs
+                    (default 0))
+  (archive-url      laminar-archive-url
+                    (default #f))
+  (base-url         laminar-base-url
+                    (default #f)))
+
+(define laminar-shepherd-service
+  (match-lambda
+    (($ <laminar-configuration> laminar home-directory
+                                bind-http bind-rpc
+                                title keep-rundirs archive-url
+                                base-url)
+     (list (shepherd-service
+            (documentation "Run Laminar.")
+            (provision '(laminar))
+            (requirement '(networking))
+            (start #~(make-forkexec-constructor
+                      (list #$(file-append laminar "/sbin/laminard"))
+                      #:environment-variables
+                      `(,(string-append "LAMINAR_HOME="
+                                        #$home-directory)
+                        ,(string-append "LAMINAR_BIND_HTTP="
+                                        #$bind-http)
+                        ,(string-append "LAMINAR_TITLE="
+                                        #$title)
+                        ,(string-append "LAMINAR_KEEP_RUNDIRS="
+                                        #$(number->string
+                                           keep-rundirs))
+                        ,@(if #$archive-url
+                              (list
+                               (string-append "LAMINAR_ARCHIVE_URL="
+                                              #$archive-url))
+                              '())
+                        ,@(if #$base-url
+                              (list
+                               (string-append "LAMINAR_BASE_URL="
+                                              #$base-url))
+                              '()))
+                      #:user "laminar"
+                      #:group "laminar"))
+            (stop #~(make-kill-destructor)))))))
+
+(define (laminar-account config)
+  "Return the user accounts and user groups for CONFIG."
+  (list (user-group
+         (name "laminar")
+         (system? #t))
+        (user-account
+         (name "laminar")
+         (group "laminar")
+         (system? #t)
+         (comment "Laminar privilege separation user")
+         (home-directory (laminar-configuration-home-directory config))
+         (shell #~(string-append #$shadow "/sbin/nologin")))))
+
+(define laminar-service-type
+  (service-type
+   (name 'laminar)
+   (extensions
+    (list
+     (service-extension shepherd-root-service-type laminar-shepherd-service)
+     (service-extension account-service-type laminar-account)))
+   (default-value (laminar-configuration))
+   (description
+    "Run the Laminar continuous integration service.")))
diff --git a/gnu/tests/ci.scm b/gnu/tests/ci.scm
new file mode 100644
index 0000000000..fe74e73e74
--- /dev/null
+++ b/gnu/tests/ci.scm
@@ -0,0 +1,129 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2017 Christopher Baines <[email-masked]>
+;;; Copyright © 2017, 2018 Clément Lassieur <[email-masked]>
+;;; Copyright © 2018 Pierre-Antoine Rouby <[email-masked]>
+;;; Copyright © 2018 Marius Bakke <[email-masked]>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix 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.
+;;;
+;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu tests ci)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu system vm)
+  #:use-module (gnu services)
+  #:use-module (gnu services ci)
+  #:use-module (gnu services web)
+  #:use-module (gnu services networking)
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:export (%test-laminar))
+
+
+
+(define %laminar-os
+  ;; Operating system under test.
+  (simple-operating-system
+   (service dhcp-client-service-type)
+   (service laminar-service-type)))
+
+(define* (run-laminar-test #:optional (http-port 8080))
+  "Run tests in %LAMINAR-OS, which has laminar running and listening on
+HTTP-PORT."
+  (define os
+    (marionette-operating-system
+     %laminar-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (port-forwardings `((,http-port . 8080)))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (ice-9 match)
+                       (gnu build marionette)
+                       (web uri)
+                       (web client)
+                       (web response))
+
+          (define marionette
+            ;; Forward the guest's HTTP-PORT, where laminar is listening, to
+            ;; port 8080 in the host.
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "laminar")
+
+          (test-assert "service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'laminar))
+             marionette))
+
+          (define* (retry-on-error f #:key times delay)
+            (let loop ((attempt 1))
+              (match (catch
+                      #t
+                      (lambda ()
+                        (cons #t
+                              (f)))
+                      (lambda args
+                        (cons #f
+                              args)))
+                ((#t . return-value)
+                 return-value)
+                ((#f . error-args)
+                 (if (>= attempt times)
+                     error-args
+                     (begin
+                       (sleep delay)
+                       (loop (+ 1 attempt))))))))
+
+          (test-equal "http-get"
+            200
+            (retry-on-error
+             (lambda ()
+               (let-values (((response text)
+                             (http-get #$(format
+                                          #f
+                                          "http://localhost:~A/"
+                                          http-port)
+                                       ;; TODO: Why does decoding fail?
+                                       #:decode-body? #f)))
+                 (response-code response)))
+             #:times 10
+             #:delay 5))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "laminar-test" test))
+
+(define %test-laminar
+  (system-test
+   (name "laminar")
+   (description "Connect to a running Laminar server.")
+   (value (run-laminar-test))))
-- 
2.30.1