Merge branch 'master' into emacs-team

5 files changed, 270 insertions, 13 deletions

diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm
index 1c10cfb1f6..edd8ce59da 100644
--- a/gnu/services/admin.scm
+++ b/gnu/services/admin.scm
@@ -21,16 +21,23 @@
 
 (define-module (gnu services admin)
   #:use-module (gnu packages admin)
+  #:use-module ((gnu packages base)
+                #:select (canonical-package findutils))
   #:use-module (gnu packages certs)
   #:use-module (gnu packages package-management)
   #:use-module (gnu services)
+  #:use-module (gnu services configuration)
   #:use-module (gnu services mcron)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu system accounts)
+  #:use-module ((gnu system shadow) #:select (account-service-type))
+  #:use-module ((guix store) #:select (%store-prefix))
   #:use-module (guix gexp)
   #:use-module (guix modules)
   #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:export (%default-rotations
             %rotated-files
@@ -55,6 +62,23 @@
             log-cleanup-configuration-expiry
             log-cleanup-configuration-schedule
 
+            file-database-service-type
+            file-database-configuration
+            file-database-configuration?
+            file-database-configuration-package
+            file-database-configuration-schedule
+            file-database-configuration-excluded-directories
+            %default-file-database-update-schedule
+            %default-file-database-excluded-directories
+
+            package-database-service-type
+            package-database-configuration
+            package-database-configuration?
+            package-database-configuration-package
+            package-database-configuration-schedule
+            package-database-configuration-method
+            package-database-configuration-channels
+
             unattended-upgrade-service-type
             unattended-upgrade-configuration
             unattended-upgrade-configuration?
@@ -257,6 +281,118 @@ Old log files are removed or compressed according to the configuration.")
 
 
 ;;;
+;;; File databases.
+;;;
+
+(define %default-file-database-update-schedule
+  ;; Default mcron schedule for the periodic 'updatedb' job: once every
+  ;; Sunday.
+  "10 23 * * 0")
+
+(define %default-file-database-excluded-directories
+  ;; Directories excluded from the 'locate' database.
+  (list (%store-prefix)
+        "/tmp" "/var/tmp" "/var/cache" ".*/\\.cache"
+        "/run/udev"))
+
+(define (string-or-gexp? obj)
+  (or (string? obj) (gexp? obj)))
+
+(define string-list?
+  (match-lambda
+    (((? string?) ...) #t)
+    (_ #f)))
+
+(define-configuration/no-serialization file-database-configuration
+  (package
+    (file-like (let-system (system target)
+                 ;; Unless we're cross-compiling, avoid pulling a second copy
+                 ;; of findutils.
+                 (if target
+                     findutils
+                     (canonical-package findutils))))
+    "The GNU@tie{}Findutils package from which the @command{updatedb} command
+is taken.")
+  (schedule
+   (string-or-gexp %default-file-database-update-schedule)
+   "String or G-exp denoting an mcron schedule for the periodic
+@command{updatedb} job (@pxref{Guile Syntax,,, mcron, GNU@tie{}mcron}).")
+  (excluded-directories
+   (string-list %default-file-database-excluded-directories)
+   "List of directories to ignore when building the file database.  By
+default, this includes @file{/tmp} and @file{/gnu/store}, which should instead
+be indexed by @command{guix locate} (@pxref{Invoking guix locate}).  This list
+is passed to the @option{--prunepaths} option of
+@command{updatedb} (@pxref{Invoking updatedb,,, find, GNU@tie{}Findutils})."))
+
+(define (file-database-mcron-jobs configuration)
+  (match-record configuration <file-database-configuration>
+    (package schedule excluded-directories)
+    (let ((updatedb (program-file
+                     "updatedb"
+                     #~(execl #$(file-append package "/bin/updatedb")
+                              "updatedb"
+                              #$(string-append "--prunepaths="
+                                               (string-join
+                                                excluded-directories))))))
+      (list #~(job #$schedule #$updatedb)))))
+
+(define file-database-service-type
+  (service-type
+   (name 'file-database)
+   (extensions (list (service-extension mcron-service-type
+                                        file-database-mcron-jobs)))
+   (description
+    "Periodically update the file database used by the @command{locate} command,
+which lets you search for files by name.  The database is created by running
+the @command{updatedb} command.")
+   (default-value (file-database-configuration))))
+
+(define %default-package-database-update-schedule
+  ;; Default mcron schedule for the periodic 'guix locate --update' job: once
+  ;; every Monday.
+  "10 23 * * 1")
+
+(define-configuration/no-serialization package-database-configuration
+  (package (file-like guix)
+           "The Guix package to use.")
+  (schedule (string-or-gexp
+             %default-package-database-update-schedule)
+            "String or G-exp denoting an mcron schedule for the periodic
+@command{guix locate --update} job (@pxref{Guile Syntax,,, mcron,
+GNU@tie{}mcron}).")
+  (method    (symbol 'store)
+             "Indexing method for @command{guix locate}.  The default value,
+@code{'store}, yields a more complete database but is relatively expensive in
+terms of CPU and input/output.")
+  (channels (gexp #~%default-channels)
+            "G-exp denoting the channels to use when updating the database
+(@pxref{Channels})."))
+
+(define (package-database-mcron-jobs configuration)
+  (match-record configuration <package-database-configuration>
+    (package schedule method channels)
+    (let ((channels (scheme-file "channels.scm" channels)))
+      (list #~(job #$schedule
+                   ;; XXX: The whole thing's running as "root" just because it
+                   ;; needs write access to /var/cache/guix/locate.
+                   (string-append #$(file-append package "/bin/guix")
+                                  " time-machine -C " #$channels
+                                  " -- locate --update --method="
+                                  #$(symbol->string method)))))))
+
+(define package-database-service-type
+  (service-type
+   (name 'package-database)
+   (extensions (list (service-extension mcron-service-type
+                                        package-database-mcron-jobs)))
+   (description
+    "Periodically update the package database used by the @code{guix locate} command,
+which lets you search for packages that provide a given file.")
+   (default-value (package-database-configuration))))
+
+
+;;;
 ;;; Unattended upgrade.
 ;;;
 
diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm
index e8e42d3b7b..7148971c1d 100644
--- a/gnu/services/databases.scm
+++ b/gnu/services/databases.scm
@@ -363,7 +363,15 @@ and stores the database cluster in @var{data-directory}."
   (permissions      postgresql-role-permissions
                     (default '(createdb login))) ;list
   (create-database? postgresql-role-create-database?  ;boolean
-                    (default #f)))
+                    (default #f))
+  (encoding postgresql-role-encoding ;string
+            (default "UTF8"))
+  (collation postgresql-role-collation ;string
+             (default "en_US.utf8"))
+  (ctype postgresql-role-ctype ;string
+         (default "en_US.utf8"))
+  (template postgresql-role-template ;string
+            (default "template1")))
 
 (define-record-type* <postgresql-role-configuration>
   postgresql-role-configuration make-postgresql-role-configuration
@@ -392,7 +400,8 @@ and stores the database cluster in @var{data-directory}."
            (append-map
             (lambda (role)
               (match-record role <postgresql-role>
-                (name permissions create-database?)
+                (name permissions create-database? encoding collation ctype
+                      template)
                 `("SELECT NOT(EXISTS(SELECT 1 FROM pg_catalog.pg_roles WHERE \
 rolname = '" ,name "')) as not_exists;\n"
 "\\gset\n"
@@ -402,7 +411,11 @@ rolname = '" ,name "')) as not_exists;\n"
 ";\n"
 ,@(if create-database?
       `("CREATE DATABASE \"" ,name "\""
-        " OWNER \"" ,name "\";\n")
+        " OWNER \"" ,name "\"\n"
+        " ENCODING '" ,encoding "'\n"
+        " LC_COLLATE '" ,collation "'\n"
+        " LC_CTYPE '" ,ctype "'\n"
+        " TEMPLATE " ,template ";")
       '())
 "\\endif\n")))
             roles)))
diff --git a/gnu/services/docker.scm b/gnu/services/docker.scm
index 741bab5a8c..c2023d618c 100644
--- a/gnu/services/docker.scm
+++ b/gnu/services/docker.scm
@@ -116,12 +116,7 @@ loop-back communications.")
            (requirement '(containerd
                           dbus-system
                           elogind
-                          file-system-/sys/fs/cgroup/blkio
-                          file-system-/sys/fs/cgroup/cpu
-                          file-system-/sys/fs/cgroup/cpuset
-                          file-system-/sys/fs/cgroup/devices
-                          file-system-/sys/fs/cgroup/memory
-                          file-system-/sys/fs/cgroup/pids
+                          file-system-/sys/fs/cgroup
                           networking
                           udev))
            (start #~(make-forkexec-constructor
diff --git a/gnu/services/pam-mount.scm b/gnu/services/pam-mount.scm
index 21c34ddd61..dbb9d0285f 100644
--- a/gnu/services/pam-mount.scm
+++ b/gnu/services/pam-mount.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
+;;; Copyright © 2023 Brian Cully <bjc@spork.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,9 +24,15 @@
   #:use-module (gnu system pam)
   #:use-module (guix gexp)
   #:use-module (guix records)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:export (pam-mount-configuration
             pam-mount-configuration?
-            pam-mount-service-type))
+            pam-mount-service-type
+
+            pam-mount-volume
+            pam-mount-volume?
+            pam-mount-volume-service-type))
 
 (define %pam-mount-default-configuration
   `((debug (@ (enable "0")))
@@ -102,6 +109,11 @@
                              (list optional-pam-mount))))
            pam))))))
 
+(define (extend-pam-mount-configuration initial extensions)
+  "Extends INITIAL with EXTENSIONS."
+  (pam-mount-configuration (rules (append (pam-mount-configuration-rules
+                                           initial) extensions))))
+
 (define pam-mount-service-type
   (service-type
    (name 'pam-mount)
@@ -109,6 +121,106 @@
                                         pam-mount-etc-service)
                      (service-extension pam-root-service-type
                                         pam-mount-pam-service)))
+   (compose concatenate)
+   (extend extend-pam-mount-configuration)
    (default-value (pam-mount-configuration))
    (description "Activate PAM-Mount support.  It allows mounting volumes for
 specific users when they log in.")))
+
+(define (field-name->tag field-name)
+  "Convert FIELD-NAME to its tag used by the configuration XML."
+  (match field-name
+    ('user-name 'user)
+    ('user-id 'uid)
+    ('primary-group 'pgrp)
+    ('group-id 'gid)
+    ('secondary-group 'sgrp)
+    ('file-system-type 'fstype)
+    ('no-mount-as-root? 'noroot)
+    ('file-name 'path)
+    ('mount-point 'mountpoint)
+    ('ssh? 'ssh)
+    ('file-system-key-cipher 'fskeycipher)
+    ('file-system-key-hash 'fskeyhash)
+    ('file-system-key-file-name 'fskeypath)
+    (_ field-name)))
+
+(define-maybe string)
+
+(define (serialize-string field-name value)
+  (list (field-name->tag field-name) value))
+
+(define (integer-or-range? value)
+  (match value
+    ((start . end) (and (integer? start)
+                        (integer? end)))
+    (_ (number? value))))
+
+(define-maybe integer-or-range)
+
+(define (serialize-integer-or-range field-name value)
+  (let ((value-string (match value
+                        ((start . end) (format #f "~a-~a" start end))
+                        (_ (number->string value)))))
+    (list (field-name->tag field-name) value-string)))
+
+(define-maybe boolean)
+
+(define (serialize-boolean field-name value)
+  (let ((value-string (if value "1" "0")))
+    (list (field-name->tag field-name) value-string)))
+
+(define-configuration pam-mount-volume
+  (user-name maybe-string "User name to match.")
+  (user-id maybe-integer-or-range
+   "User ID, or range of user IDs, in the form of @code{(start . end)} to\nmatch.")
+  (primary-group maybe-string "Primary group name to match.")
+  (group-id maybe-integer-or-range
+   "Group ID, or range of group IDs, in the form of @code{(start . end)} to\nmatch.")
+  (secondary-group maybe-string
+   "Match users who belong to this group name as either a primary or secondary\ngroup.")
+  (file-system-type maybe-string "File system type of volume being mounted.")
+  (no-mount-as-root? maybe-boolean
+                     "Do not use super user privileges to mount this volume.")
+  (server maybe-string "Remote server this volume resides on.")
+  (file-name maybe-string "Location of the volume to be mounted.")
+  (mount-point maybe-string
+               "Where to mount the volume in the local file system.")
+  (options maybe-string "Options to pass to the underlying mount program.")
+  (ssh? maybe-boolean "Whether to pass the login password to SSH.")
+  (cipher maybe-string "Cryptsetup cipher named used by volume.")
+  (file-system-key-cipher maybe-string
+                          "Cipher name used by the target volume.")
+  (file-system-key-hash maybe-string
+                        "SSL hash name used by the target volume.")
+  (file-system-key-file-name maybe-string
+   "File name for the file system key used by the target volume."))
+
+(define (pam-mount-volume->sxml volume)
+  ;; Convert a list of configuration fields into an SXML-compatible attribute
+  ;; list.
+  (define xml-attrs
+    (filter-map (lambda (field)
+                  (let* ((accessor (configuration-field-getter field))
+                         (value (accessor volume)))
+                    (and (not (eq? value %unset-value))
+                         (list (field-name->tag (configuration-field-name
+                                                 field)) value))))
+                pam-mount-volume-fields))
+
+  `(volume (@ ,@xml-attrs)))
+
+(define (pam-mount-volume-rules volumes)
+  (map pam-mount-volume->sxml volumes))
+
+(define pam-mount-volume-service-type
+  (service-type (name 'pam-mount-volume)
+                (extensions (list (service-extension pam-mount-service-type
+                                                     pam-mount-volume-rules)))
+                (compose concatenate)
+                (extend append)
+                (default-value '())
+                (description
+                 "Mount remote volumes such as CIFS shares @i{via}
+@acronym{PAM, Pluggable Authentication Modules} when logging in, using login
+credentials.")))
diff --git a/gnu/services/syncthing.scm b/gnu/services/syncthing.scm
index 7c3d5b027d..c1a0cdd81f 100644
--- a/gnu/services/syncthing.scm
+++ b/gnu/services/syncthing.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2023 Justin Veilleux <terramorpha@cock.li>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -60,9 +61,9 @@
        (requirement '(loopback))
        (start #~(make-forkexec-constructor
                  (append (list (string-append #$syncthing "/bin/syncthing")
-                               "-no-browser"
-                               "-no-restart"
-                               (string-append "-logflags=" (number->string #$logflags)))
+                               "--no-browser"
+                               "--no-restart"
+                               (string-append "--logflags=" (number->string #$logflags)))
                          '#$arguments)
                  #:user #$user
                  #:group #$group