[bug#74837] [PATCH 1/2] gnu: services: Add resize-fs-service.

[Richard Sent]

* gnu/services/admin.scm (resize-fs-configuration): New configuration
type.
(resize-fs-shepherd-service): New procedure.
(resize-fs-service-type): New variable.
* doc/guix.texi (Miscallaneous Services): Document it.

Change-Id: Icae2fefc9a8d936d4c3add47520258b341f689a4
---
 doc/guix.texi          |  50 +++++++++++++++
 gnu/services/admin.scm | 135 ++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 184 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index a2915de954..5636eb23fb 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -41891,6 +41891,56 @@ Miscellaneous Services
 
 @c End of auto-generated fail2ban documentation.
 
+@cindex resize-fs
+@subsubheading Resize File System service
+
+This service type lets you resize a live file system during boot, which
+can be convenient if a Guix image is flashed on an SD Card (e.g. for an
+embedded device) or uploaded to a VPS.  In both cases the medium the
+image will reside upon may be larger than the image you want to produce.
+
+For an embedded device booting from an SD card you may use something like:
+@lisp
+(service resize-fs-service-type
+  (resize-fs-configuration
+    (file-system
+     (device (file-system-label "root"))
+     (type "ext4"))))
+@end lisp
+
+Be extra cautious to use the correct device and type.  The service has
+little error handling of its own and relies on the underlying tools.
+Wrong use could end in loss of data or the corruption of the operating
+system.
+
+Partitions and file systems are grown to the maximum size available.
+File systems can only grow when they are on the last partition on a
+device and have empty space available.
+
+This service supports the ext2, ext3, ext4, btrfs, and bcachefs file
+systems.
+
+@table @asis
+
+@item @code{file-system} (default: @code{#f}) (type: file-system)
+The file-system object to resize.  This object must have the device and
+type fields set.  The others are ignored.
+
+@item @code{cloud-utils} (default: @code{cloud-utils}) (type: file-like)
+The cloud-utils package to use.
+
+@item @code{e2fsprogs} (default: @code{e2fsprogs}) (type: file-like)
+The e2fsprogs package to use, used for resizing ext2, ext3, and ext4
+file systems.
+
+@item @code{btrfs-progs} (default: @code{btrfs-progs}) (type: file-like)
+The btrfs-progs package to use, used for resizing the btrfs file system.
+
+@item @code{bcachefs-tools} (default: @code{bcachefs-tools}) (type: file-like)
+The bcachefs-tools package to use, used for resizing the bcachefs file system.
+
+@end table
+
 @cindex Backup
 @subsubheading Backup Services
 
diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm
index 24ff659a01..f754012e1e 100644
--- a/gnu/services/admin.scm
+++ b/gnu/services/admin.scm
@@ -3,6 +3,8 @@
 ;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
 ;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
+;;; Copyright © 2024 Gabriel Wicki <gabriel@erlikon.ch>
+;;; Copyright © 2024 Richard Sent <richard@freakingpenguin.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,11 +22,15 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu services admin)
+  #:use-module (gnu system file-systems)
   #:use-module (gnu packages admin)
   #:use-module ((gnu packages base)
                 #:select (canonical-package findutils coreutils sed))
+  #:use-module (gnu packages file-systems)
   #:use-module (gnu packages certs)
+  #:use-module (gnu packages disk)
   #:use-module (gnu packages package-management)
+  #:use-module (gnu packages linux)
   #:use-module (gnu services)
   #:use-module (gnu services configuration)
   #:use-module (gnu services mcron)
@@ -93,7 +99,18 @@ (define-module (gnu services admin)
             unattended-upgrade-configuration-services-to-restart
             unattended-upgrade-configuration-system-expiration
             unattended-upgrade-configuration-maximum-duration
-            unattended-upgrade-configuration-log-file))
+            unattended-upgrade-configuration-log-file
+
+            unattended-upgrade-configuration-log-file
+
+            resize-fs-configuration
+            resize-fs-configuration?
+            resize-fs-configuration-parted
+            resize-fs-configuration-e2fsprogs
+            resize-fs-configuration-device
+            resize-fs-configuration-partition
+            resize-fs-configuration-end
+            resize-fs-service-type))
 
 ;;; Commentary:
 ;;;
@@ -550,4 +567,120 @@ (define unattended-upgrade-service-type
     "Periodically upgrade the system from the current configuration.")
    (default-value (unattended-upgrade-configuration))))
 
+;;;
+;;; Resize file system.
+;;;
+
+(define-record-type* <resize-fs-configuration>
+  resize-fs-configuration make-resize-fs-configuration
+  resize-fs-configuration?
+  (file-system    resize-fs-file-system
+                  (default #f))
+  (cloud-utils    resize-fs-cloud-utils
+                  (default cloud-utils))
+  (e2fsprogs      resize-fs-e2fsprogs
+                  (default e2fsprogs))
+  (btrfs-progs    resize-fs-btrfs-progs
+                  (default btrfs-progs))
+  (bcachefs-tools resize-fs-bcachefs-tools
+                  (default bcachefs-tools)))
+
+(define (resize-fs-shepherd-service config)
+  "Returns a <shepherd-service> for resize-fs-service for CONFIG."
+  (match-record config <resize-fs-configuration>
+                (file-system cloud-utils e2fsprogs btrfs-progs
+                             bcachefs-tools)
+    (let ((fs-spec (file-system->spec file-system)))
+      (shepherd-service
+       (documentation "Resize a file system. Intended for Guix Systems that
+are booted from a system image flashed onto a larger medium.")
+       ;; XXX: This could be extended with file-system info.
+       (provision '(resize-fs))
+       (requirement '(user-processes))
+       (one-shot? #t)
+       (respawn? #f)
+       (modules '((guix build utils)
+                  (gnu build file-systems)
+                  (gnu system file-systems)
+                  (ice-9 control)
+                  (ice-9 match)
+                  (ice-9 ftw)
+                  (ice-9 rdelim)
+                  (srfi srfi-34)))
+       (start (with-imported-modules (source-module-closure
+                                      '((guix build utils)
+                                        (gnu build file-systems)
+                                        (gnu system file-systems)))
+                #~(lambda _
+                    (use-modules (guix build utils)
+                                 (gnu build file-systems)
+                                 (gnu system file-systems)
+                                 (ice-9 control)
+                                 (ice-9 match)
+                                 (ice-9 ftw)
+                                 (ice-9 rdelim)
+                                 (srfi srfi-34))
+
+                    (define file-system
+                      (spec->file-system '#$fs-spec))
+
+                    ;; Shepherd recommends the start constructor takes <1
+                    ;; minute, canonicalize-device-spec will hang for up to
+                    ;; max-trials seconds (20 seconds) if an invalid device is
+                    ;; connected. Revisit this if max-trials increases.
+                    (define device (canonicalize-device-spec
+                                    (file-system-device file-system)))
+
+                    (define grow-partition-command
+                      (let* ((sysfs-device
+                              (string-append "/sys/class/block/"
+                                             (basename device)))
+                             (partition-number
+                              (with-input-from-file
+                                  (string-append sysfs-device
+                                                 "/partition")
+                                read-line))
+                             (parent (string-append
+                                      "/dev/"
+                                      (basename (dirname (readlink 
sysfs-device))))))
+                        (list #$(file-append cloud-utils "/bin/growpart")
+                              parent partition-number)))
+
+                    (define grow-filesystem-command
+                      (match (file-system-type file-system)
+                        ((or "ext2" "ext3" "ext4")
+                         (list #$(file-append e2fsprogs "/sbin/resize2fs") 
device))
+                        ("btrfs"
+                         (list #$(file-append btrfs-progs "/bin/btrfs")
+                               "filesystem" "resize" device))
+                        ("bcachefs"
+                         (list #$(file-append bcachefs-tools "/sbin/bcachefs")
+                               "device" "resize" device))
+                        (e (error "Unsupported filesystem type" e))))
+
+                    (let/ec return
+                      (guard (c ((and (invoke-error? c)
+                                      ;; growpart NOCHANGE exits with 1. It is
+                                      ;; unlikely the partition was resized
+                                      ;; while the file system was not. Just
+                                      ;; exit.
+                                      (equal? (invoke-error-exit-status c) 1))
+                                 (format (current-error-port)
+                                         "The device ~a is already resized.~%" 
device)
+                                 ;; Must return something or Shepherd considers
+                                 ;; the service perpetually starting.
+                                 (return 0)))
+                        (apply invoke grow-partition-command))
+                      (apply invoke grow-filesystem-command)))))))))
+
+(define resize-fs-service-type
+  (service-type
+   (name 'resize-fs)
+   (description "Resize a partition during boot.")
+   (extensions
+    (list
+     (service-extension shepherd-root-service-type
+                        (compose list resize-fs-shepherd-service))))
+   (default-value (resize-fs-configuration))))
+
 ;;; admin.scm ends here
-- 
2.46.0