;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016-2026 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2023 Giacomo Leidi <therewasa@fishinthecalculator.me>
;;; Copyright © 2024 Gabriel Wicki <gabriel@erlikon.ch>
;;; Copyright © 2024 Richard Sent <richard@freakingpenguin.com>
;;; Copyright © 2025 Luis Guilherme Coelho <lgcoelho@disroot.org>
;;;
;;; 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/>.

;;; Commentary:
;;;
;;; This module provides basic system administration tools: log rotation,
;;; unattended upgrades, etc.
;;;
;;; Code:

(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 nss)
  #: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)
  #: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 deprecation)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (gnu system privilege)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:export (log-rotation-configuration
            log-rotation-configuration?
            log-rotation-configuration-provision
            log-rotation-configuration-requirement
            log-rotation-configuration-calendar-event
            log-rotation-configuration-external-log-files
            log-rotation-configuration-compression
            log-rotation-configuration-expiry
            log-rotation-configuration-size-threshold
            log-rotation-service-type

            log-cleanup-service-type
            log-cleanup-configuration
            log-cleanup-configuration?
            log-cleanup-configuration-directory
            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?
            unattended-upgrade-configuration-operating-system-file
            unattended-upgrade-configuration-operating-system-expression
            unattended-upgrade-configuration-channels
            unattended-upgrade-configuration-schedule
            unattended-upgrade-configuration-services-to-restart
            unattended-upgrade-configuration-system-expiration
            unattended-upgrade-configuration-maximum-duration
            unattended-upgrade-configuration-log-file

            opendoas-service-type
            opendoas-configuration
            opendoas-configuration-opendoas
            opendoas-configuration-rules
            opendoas-permit-rule
            opendoas-deny-rule

            resize-file-system-service-type
            resize-file-system-configuration
            resize-file-system-configuration?
            resize-file-system-configuration-file-system
            resize-file-system-configuration-cloud-utils
            resize-file-system-configuration-e2fsprogs
            resize-file-system-configuration-btrfs-progs
            resize-file-system-configuration-bcachefs-tools))


;;;
;;; Shepherd's log rotation service.
;;;

(define %default-log-rotation-calendar-event
  ;; Default calendar event when log rotation is triggered.
  #~(calendar-event #:minutes '(0)
                    #:hours '(22)
                    #:days-of-week '(sunday)))

(define (gexp-or-integer? x)
  (or (gexp? x) (integer? x)))

(define (gexp-or-symbol? x)
  (or (gexp? x) (symbol? x)))

(define-configuration log-rotation-configuration
  (provision
   (list-of-symbols '(log-rotation))
   "The name(s) of the log rotation Shepherd service."
   empty-serializer)
  (requirement
   (list-of-symbols (if for-home? '() '(user-processes)))
   "Dependencies of the log rotation Shepherd service."
   empty-serializer)
  (calendar-event
   (gexp %default-log-rotation-calendar-event)
   "Gexp containing the @dfn{calendar event} when log rotation occurs.
@xref{Timers,,, shepherd, The GNU Shepherd Manual}, for more information on
calendar events."
   empty-serializer)
  (external-log-files
   (list-of-strings '())
   "List of file names, external log files that should also be
rotated."
   empty-serializer)
  (compression
   (gexp-or-symbol 'zstd)
   "The compression method used for rotated log files, one of @code{'none},
@code{'gzip}, and @code{'zstd}. Alternatively, it can be a gexp that evaluates
to a procedure; that procedure gets called with the file to be rotated."
   empty-serializer)
  (expiry
   (gexp-or-integer #~(%default-log-expiry))
   "Age in seconds after which a log file is deleted."
   empty-serializer)
  (size-threshold
   (gexp-or-integer #~(%default-rotation-size-threshold))
   "Size in bytes below which a log file is @emph{not} rotated."
   empty-serializer))

(define (log-rotation-shepherd-services config)
  (let* ((compression-raw (log-rotation-configuration-compression config))
         (compression
           (if (symbol? compression-raw)
             #~'#$compression-raw
             compression-raw)))
    (list (shepherd-service
           (provision (log-rotation-configuration-provision config))
           (requirement (log-rotation-configuration-requirement config))
           (modules '((shepherd service timer)      ;for 'calendar-event'
                      (shepherd service log-rotation)))
           (free-form #~(log-rotation-service
                         #$(log-rotation-configuration-calendar-event config)
                         #:provision
                         '#$(log-rotation-configuration-provision config)
                         #:requirement
                         '#$(log-rotation-configuration-requirement config)
                         #:external-log-files
                         '#$(log-rotation-configuration-external-log-files
                             config)
                         #:compression
                         #$compression
                         #:expiry
                         #$(log-rotation-configuration-expiry config)
                         #:rotation-size-threshold
                         #$(log-rotation-configuration-size-threshold
                            config)))))))

(define log-rotation-service-type
  (service-type
   (name 'log-rotation)
   (description
    "Periodically rotate log files using the Shepherd's log rotation service.
Run @command{herd status log-rotation} to view its status, @command{herd files
log-rotation} to list files subject to log rotation.")
   (extensions (list (service-extension shepherd-root-service-type
                                        log-rotation-shepherd-services)))
   (compose concatenate)
   (extend (lambda (config log-files)
             (log-rotation-configuration
              (inherit config)
              (external-log-files
               (append (log-rotation-configuration-external-log-files config)
                       log-files)))))
   (default-value (log-rotation-configuration))))


;;;
;;; Build log removal.
;;;

(define-record-type* <log-cleanup-configuration>
  log-cleanup-configuration make-log-cleanup-configuration
  log-cleanup-configuration?
  (directory log-cleanup-configuration-directory) ;string
  (expiry    log-cleanup-configuration-expiry     ;integer (seconds)
             (default (* 6 30 24 3600)))
  (schedule  log-cleanup-configuration-schedule   ;string or gexp
             (default "30 12 01,08,15,22 * *")))

(define (log-cleanup-program directory expiry)
  (program-file "delete-old-logs"
                (with-imported-modules '((guix build utils))
                  #~(begin
                      (use-modules (guix build utils))
                      (let* ((now  (car (gettimeofday)))
                             (logs (find-files #$directory
                                               (lambda (file stat)
                                                 (> (- now (stat:mtime stat))
                                                    #$expiry)))))
                        (format #t "deleting ~a log files from '~a'...~%"
                                (length logs) #$directory)
                        (for-each delete-file logs))))))

(define (log-cleanup-shepherd-services configuration)
  (match-record configuration <log-cleanup-configuration>
                (directory expiry schedule)
    (let ((program (log-cleanup-program directory expiry)))
      (list (shepherd-service
             (provision '(log-cleanup))
             (requirement '(user-processes))
             (modules '((shepherd service timer)))
             (start #~(make-timer-constructor
                       #$(if (string? schedule)
                             #~(cron-string->calendar-event #$schedule)
                             schedule)
                       (command '(#$program))))
             (stop #~(make-timer-destructor))
             (actions (list shepherd-trigger-action))
             (documentation "Periodically delete old log files."))))))

(define log-cleanup-service-type
  (service-type
   (name 'log-cleanup)
   (extensions
    (list (service-extension shepherd-root-service-type
                             log-cleanup-shepherd-services)))
   (description
    "Periodically delete old log files.")))


;;;
;;; 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
  ;; Regexps of directories excluded from the 'locate' database.
  (list (%store-prefix)
        "/tmp" "/var/tmp" "/var/cache" ".*/\\.cache"
        "/run/udev" "/dev"))

(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 package from which the @command{updatedb} command is taken.
Examples of such packages are GNU@tie{}Findutils and Plocate.")
  (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 regular expressions of directories to ignore when building the
file database.  By default, this includes @file{/tmp} and @file{/gnu/store};
the latter 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-shepherd-services configuration)
  (match-record configuration <file-database-configuration>
    (package schedule excluded-directories)
    (let ((updatedb (program-file
                     "updatedb"
                     #~(begin
                         (define updatedb
                           (let ((try (lambda (file)
                                        (and (file-exists? file) file))))
                             (or (try #$(file-append package "/bin/updatedb"))
                                 (try #$(file-append package "/sbin/updatedb")))))
                         ;; 'updatedb' is a shell script that expects various
                         ;; commands in $PATH.
                         (setenv "PATH"
                                 (string-append (dirname updatedb) ":"
                                                #$(canonical-package coreutils)
                                                "/bin:"
                                                #$(canonical-package sed)
                                                "/bin"))
                         (execl updatedb
                                "updatedb"
                                #$(string-append "--prunepaths="
                                                 (string-join
                                                  excluded-directories)))))))
      (list (shepherd-service
             (provision '(file-database-update))
             (requirement '(user-processes))
             (modules '((shepherd service timer)))
             (start #~(make-timer-constructor
                       #$(if (string? schedule)
                             #~(cron-string->calendar-event #$schedule)
                             schedule)
                       (command '(#$updatedb))
                       #:wait-for-termination? #t))
             (stop #~(make-timer-destructor))
             (documentation
              "Periodically update the system-wide file database that can be
queried by the 'locate' command.")
             (actions (list shepherd-trigger-action)))))))

(define file-database-service-type
  (service-type
   (name 'file-database)
   (extensions (list (service-extension shepherd-root-service-type
                                        file-database-shepherd-services)))
   (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-file
  ;; System-wide package database used by 'guix locate'.
  ;; See 'system-database-file' in (guix scripts locate).
  "/var/cache/guix/locate/db.sqlite")

(define %package-database-accounts
  (list (user-account
          (name "guix-locate")
          (group "guix-locate")
          (system? #t)
          (comment "Account running 'guix locate'")
          (home-directory "/var/run/guix-locate"))
        (user-group
          (name "guix-locate")
          (system? #t))))

(define %package-database-activation
  ;; Create the package database directory at activation time.  Make it
  ;; writable by 'guix-locate' and world-readable.
  #~(begin
      (use-modules (guix build utils))
      (let ((directory #$(dirname %package-database-file))
            (owner (getpwnam "guix-locate")))
        (mkdir-p/perms directory owner #o755))))

(define (package-database-shepherd-services configuration)
  (match-record configuration <package-database-configuration>
    (package schedule method channels)
    (let ((channels (scheme-file "channels.scm" channels)))
      (list (shepherd-service
             (provision '(package-database-update))
             (requirement '(user-processes guix-daemon))
             (modules '((shepherd service timer)))
             (start #~(make-timer-constructor
                       #$(if (string? schedule)
                             #~(cron-string->calendar-event #$schedule)
                             schedule)
                       (command '(#$(file-append package "/bin/guix")
                                  "time-machine" "-C" #$channels
                                  "--" "locate" "--update"
                                  #$(string-append "--database="
                                                   %package-database-file)
                                  #$(string-append
                                     "--method=" (symbol->string method)))
                                #:user "guix-locate"
                                #:group "guix-locate")
                       #:log-file "/var/log/guix-locate.log"
                       #:wait-for-termination? #t))
             (stop #~(make-timer-destructor))
             (documentation
              "Periodically update the system-wide package database that can
be queried by the 'guix locate' command.")
             (actions (list shepherd-trigger-action)))))))

(define package-database-service-type
  (service-type
   (name 'package-database)
   (extensions (list (service-extension shepherd-root-service-type
                                        package-database-shepherd-services)
                     (service-extension activation-service-type
                                        (const %package-database-activation))
                     (service-extension account-service-type
                                        (const %package-database-accounts))))
   (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.
;;;

(define-record-type* <unattended-upgrade-configuration>
  unattended-upgrade-configuration make-unattended-upgrade-configuration
  unattended-upgrade-configuration?
  (operating-system-file unattended-upgrade-operating-system-file
                         (default "/run/current-system/configuration.scm"))
  (operating-system-expression unattended-upgrade-operating-system-expression
                               (default #f))
  (schedule             unattended-upgrade-configuration-schedule
                        (default "30 01 * * 0"))
  (channels             unattended-upgrade-configuration-channels
                        (default #~%default-channels))
  (reboot?              unattended-upgrade-configuration-reboot?
                        (default #f))
  (services-to-restart  unattended-upgrade-configuration-services-to-restart
                        (default '(unattended-upgrade)))
  (system-expiration    unattended-upgrade-system-expiration
                        (default (* 3 30 24 3600)))
  (maximum-duration     unattended-upgrade-maximum-duration
                        (default 3600))
  (log-file             unattended-upgrade-configuration-log-file
                        (default %unattended-upgrade-log-file)))

(define %unattended-upgrade-log-file
  "/var/log/unattended-upgrade.log")

(define (unattended-upgrade-shepherd-services config)
  (define channels
    (scheme-file "channels.scm"
                 (unattended-upgrade-configuration-channels config)))

  (define log
    (unattended-upgrade-configuration-log-file config))

  (define schedule
    (unattended-upgrade-configuration-schedule config))

  (define services
    (unattended-upgrade-configuration-services-to-restart config))

  (define reboot?
    (unattended-upgrade-configuration-reboot? config))

  (define expiration
    (unattended-upgrade-system-expiration config))

  (define config-file
    (unattended-upgrade-operating-system-file config))

  (define expression
    (unattended-upgrade-operating-system-expression config))

  (define arguments
    (if expression
        #~(list "-e" (object->string '#$expression))
        #~(list #$config-file)))

  (define code
    (with-imported-modules (source-module-closure '((guix build utils)
                                                    (gnu services herd)))
      #~(begin
          (use-modules (guix build utils)
                       (gnu services herd)
                       (srfi srfi-34))

          (setvbuf (current-output-port) 'line)
          (setvbuf (current-error-port) 'line)

          ;; 'guix time-machine' needs X.509 certificates to authenticate the
          ;; Git host.
          (setenv "SSL_CERT_DIR"
                  #$(file-append nss-certs "/etc/ssl/certs"))

          (format #t "starting upgrade...~%")
          (guard (c ((invoke-error? c)
                     (report-invoke-error c)
                     (exit 1)))
            (apply invoke #$(file-append guix "/bin/guix")
                   "time-machine" "-C" #$channels
                   "--" "system" "reconfigure" #$arguments)

            ;; 'guix system delete-generations' fails when there's no
            ;; matching generation.  Thus, catch 'invoke-error?'.
            (guard (c ((invoke-error? c)
                       (report-invoke-error c)))
              (invoke #$(file-append guix "/bin/guix")
                      "system" "delete-generations"
                      #$(string-append (number->string expiration)
                                       "s")))

            (unless #$reboot?
              ;; Rebooting effectively restarts services anyway and execution
              ;; would be halted here if mcron is restarted.
              (format #t "restarting services...~%")
              (for-each restart-service '#$services))

            ;; XXX: If this service has been restarted, this is not reached.
            (format #t "upgrade complete~%")

            ;; Stopping the root shepherd service triggers a reboot.
            (when #$reboot?
              (format #t "rebooting system~%")
              (force-output) ;ensure the entire log is written.
              (stop-service 'root))))))

  (define upgrade
    (program-file "unattended-upgrade" code))

  (list (shepherd-service
         (provision '(unattended-upgrade))
         (requirement '(user-processes networking))
         (modules '((shepherd service timer)))
         (start #~(make-timer-constructor
                   #$(if (string? schedule)
                         #~(cron-string->calendar-event #$schedule)
                         schedule)
                   (command '(#$upgrade))

                   #:log-file #$log

                   ;; Make sure the upgrade doesn't take too long.
                   #:max-duration
                   #$(unattended-upgrade-maximum-duration config)

                   ;; Wait for the previous attempt to terminate before trying
                   ;; again.
                   #:wait-for-termination? #t))
         (stop #~(make-timer-destructor))
         (actions (list shepherd-trigger-action)))))

(define unattended-upgrade-service-type
  (service-type
   (name 'unattended-upgrade)
   (extensions
    (list (service-extension shepherd-root-service-type
                             unattended-upgrade-shepherd-services)))
   (description
    "Periodically upgrade the system from the current configuration.")
   (default-value (unattended-upgrade-configuration))))


;;;
;;; Opendoas.
;;;

(define (setenv-pair? x)
  (and (pair? x)
       (string? (car x))
       (or (string? (cdr x))
           (boolean? (cdr x)))))

(define setenv-list?
  (list-of setenv-pair?))

(define (serialize-setenv-list field-name val)
  (map (match-lambda
         ((var . #t) var)
         ((var . #f) (string-append "-" var))
         ((var . value) (string-append var "=" value)))
       val))

(define-maybe list-of-strings)
(define-maybe setenv-list)
(define-maybe string)

(define-configuration/no-serialization opendoas-permit-rule
  (nopass?
   (boolean #f)
   "Whether the user should be permitted to run the command without a password.")
  (nolog?
   (boolean #f)
   "Wheter sucessful command execution should be logged.")
  (persist?
   (boolean #f)
   "After the user sucessfully authenticates, do not ask for a password again
for some time.")
  (keepenv?
   (boolean #f)
   "Wheter environment variables other than those listed in doas should be
retained when creating the enviroment for the new process.")
  (identity
   string
   "The username to match. Groups may be specified by prepending a colon ':'."
   empty-serializer)
  (as-user
   maybe-string
   "The target user the running user is allowed to run the command as.  The
default is all users."
   empty-serializer)
  (command
   maybe-string
   "The command the user is allowed to run.  The default is all commands.
It's preferable to have commands specifieds by absolute paths. If a relative
path is specified, only a restricted PATH will be searched."
   empty-serializer)
  (args
   maybe-list-of-strings
   "Arguments to command.  The command arguments provided by the user need to
match those specified.  The keyword args alone means that command must be run
without arguments."
   empty-serializer)
  (setenv
   maybe-setenv-list
   "Set the specified variables.  Variables may also be removed by setting them
to #f, or simply exported, by setting them to #t.  If the first character of the
value is @code{$} then the value to be set is taken from the existing environment
variable with the given name."))

(define-configuration/no-serialization opendoas-deny-rule
  (identity
   string
   "The username to match. Groups may be specified by prepending a colon ':'."
   empty-serializer)
  (as-user
   maybe-string
   "The target user the running user is allowed to run the command as.  The
default is all users."
   empty-serializer)
  (command
   maybe-string
   "The command the user is allowed to run.  The default is all commands.
It's preferable to have commands specifieds by absolute paths. If a relative
path is specified, only a restricted PATH will be searched."
   empty-serializer)
  (args
   maybe-string
   "Arguments to command.  The command arguments provided by the user need to
match those specified.  The keyword args alone means that command must be run
without arguments."
   empty-serializer))

(define (opendoas-rule? x)
  (or (opendoas-permit-rule? x)
      (opendoas-deny-rule? x)))

(define* (if-set val #:optional (proc identity))
  "Apply PROC to VAL if VAL is not unset, otherwise returns #f."
  (if (maybe-value-set? val) (proc val) #f))

(define serialize-opendoas-permit-rule
  (match-record-lambda <opendoas-permit-rule>
    (identity as-user command args setenv keepenv? nopass? nolog? persist?)
    (format #f "permit ~:[~;keepenv ~]~
                       ~:[~;nopass ~]~
                       ~:[~;nolog ~]~
                       ~:[~;persist ~]~
                       ~@[setenv {~{ ~a~} } ~]~
                       ~a~@[ as ~a~]~
                         ~@[ cmd ~a~]~
                         ~@[ args~{ ~a~}~]~%"
            keepenv?
            nopass?
            nolog?
            persist?
            (if-set setenv (cut serialize-setenv-list #f <>))
            identity
            (if-set as-user)
            (if-set command)
            (if-set args))))

(define serialize-opendoas-deny-rule
  (match-record-lambda <opendoas-deny-rule>
    (identity as-user command args)
    (format #f "deny ~a~@[ as ~a~]~@[ cmd ~a~]~@[ args~{ ~a~}~]~%"
            identity
            (if-set as-user)
            (if-set command)
            (if-set args))))

(define (serialize-opendoas-rule rule)
  (cond ((opendoas-permit-rule? rule)
          (serialize-opendoas-permit-rule rule))
         ((opendoas-deny-rule? rule)
          (serialize-opendoas-deny-rule rule))))

(define list-of-opendoas-rules?
  (list-of opendoas-rule?))

(define-configuration/no-serialization opendoas-configuration
  (opendoas
    (package opendoas)
    "The opendoas package to be used.")
  (rules
    (list-of-opendoas-rules
     (list (opendoas-permit-rule
            (identity ":wheel"))))
    "The list of permit and/or deny rules used by opendoas."))

(define (opendoas-extensions original-config extension-configs)
  (opendoas-configuration
    (inherit original-config)
    (rules (append (opendoas-configuration-rules original-config)
                   (reverse (apply append extension-configs))))))

(define (opendoas-activation config)
  ;; Opendoas requires this file to be owned by root. So we install this file
  ;; on activation rather than by etc-service-type to ensure proper working on
  ;; unprivileged daemon setups
  #~(let* ((doas.conf "/etc/doas.conf")
           (root:pwnam (getpwnam "root"))
           (root:uid (passwd:uid root:pwnam))
           (root:gid (passwd:gid root:pwnam)))
      ;; Just being extra cautious
      (mkdir-p/perms "/etc" root:pwnam #o755)
      ;; If /etc/doas.conf is a symlink, copy-file fails to replace it, so delete
      ;; it before copying the new file there
      (when (file-exists? doas.conf) (delete-file doas.conf))
      (copy-file
       #$(plain-file "doas.conf"
           (apply string-append
                  (map serialize-opendoas-rule
                       (opendoas-configuration-rules config))))
       doas.conf)
      (chown doas.conf root:uid root:gid)
      (chmod doas.conf #o400)))

(define (opendoas-privileged-programs config)
  (let ((opendoas (opendoas-configuration-opendoas config)))
    (list (privileged-program
            (program (file-append opendoas "/bin/doas"))
            (setuid? #t)))))

(define (opendoas-packages config)
  (list (opendoas-configuration-opendoas config)))

(define opendoas-service-type
  (service-type
   (name 'opendoas)
   (extensions
    (list (service-extension activation-service-type
                             opendoas-activation)
          (service-extension profile-service-type
                             opendoas-packages)
          (service-extension privileged-program-service-type
                             opendoas-privileged-programs)))
   (compose identity)
   (extend opendoas-extensions)
   (default-value (opendoas-configuration))
   (description "Set /etc/doas.conf")))


;;;
;;; Resize file system.
;;;

(define-record-type* <resize-file-system-configuration>
  resize-file-system-configuration make-resize-file-system-configuration
  resize-file-system-configuration?
  (file-system    resize-file-system-file-system)
  (cloud-utils    resize-file-system-cloud-utils
                  (default cloud-utils))
  (e2fsprogs      resize-file-system-e2fsprogs
                  (default e2fsprogs))
  (btrfs-progs    resize-file-system-btrfs-progs
                  (default btrfs-progs))
  (bcachefs-tools resize-file-system-bcachefs-tools
                  (default bcachefs-tools)))

(define (resize-file-system-shepherd-service config)
  "Returns a <shepherd-service> for resize-file-system-service for CONFIG."
  (match-record config <resize-file-system-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-file-system))
       (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-file-system-service-type
  (service-type
   (name 'resize-file-system)
   (description "Resize a partition and the underlying file system during boot.")
   (extensions
    (list
     (service-extension shepherd-root-service-type
                        (compose list resize-file-system-shepherd-service))))))

;;; admin.scm ends here