aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016-2020, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;;
;;; 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 mcron)
  #:use-module (gnu services)
  #:use-module ((gnu services configuration) #:select
                (define-configuration/no-serialization))
  #:use-module (gnu services shepherd)
  #:use-module (gnu system privilege)
  #:use-module (gnu packages guile-xyz)
  #:use-module ((guix packages) #:select (package?))
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:export (mcron-configuration
            mcron-configuration?
            mcron-configuration-mcron
            mcron-configuration-jobs
            mcron-configuration-log?
            mcron-configuration-log-file
            mcron-configuration-log-format
            mcron-configuration-date-format
            mcron-configuration-home-service?

            mcron-service-type

            cron-daemon-configuration
            cron-daemon-configuration-cron
            cron-daemon-configuration-
            cron-daemon-service-type))

;;; Commentary:
;;;
;;; This module implements a service that to run instances of GNU mcron, a
;;; periodic job execution daemon.  Example of a service:
;;
;;  (service mcron-service-type
;;           (mcron-configuration
;;            (jobs (list #~(job next-second-from
;;                               (lambda ()
;;                                 (call-with-output-file "/dev/console"
;;                                   (lambda (port)
;;                                     (display "hello!\n" port)))))))))
;;;
;;; Code:

;; Configuration of mcron.
;; XXX: 'define-configuration' cannot be used here due to the need for
;; 'thunked' and 'innate' fields as well as 'this-mcron-configuration'.
(define-record-type* <mcron-configuration> mcron-configuration
  make-mcron-configuration
  mcron-configuration?
  this-mcron-configuration

  (mcron       mcron-configuration-mcron          ;file-like
               (default mcron))
  (jobs        mcron-configuration-jobs           ;list of gexps
               (default '()))
  (log?        mcron-configuration-log?           ;Boolean
               (default #t))
  (log-file    mcron-configuration-log-file       ;string | gexp
               (thunked)
               (default
                 (if (mcron-configuration-home-service?
                      this-mcron-configuration)
                     #~(string-append %user-log-dir "/mcron.log")
                     "/var/log/mcron.log")))
  (log-format  mcron-configuration-log-format     ;string
               (default "~1@*~a ~a: ~a~%"))
  (date-format mcron-configuration-date-format    ;string | #f
               (default #f))

  (home-service? mcron-configuration-home-service?
                 (default for-home?) (innate)))

(define (job-files mcron jobs)
  "Return a list of file-like object for JOBS, a list of gexps."
  (define (validated-file job)
    ;; This procedure behaves like 'scheme-file' but it runs 'mcron
    ;; --schedule' to detect any error in JOB.
    (computed-file "mcron-job"
                   (with-imported-modules '((guix build utils))
                     #~(begin
                         (use-modules (guix build utils))

                         (call-with-output-file "prologue"
                           (lambda (port)
                             ;; This prologue allows 'mcron --schedule' to
                             ;; proceed no matter what #:user option is passed
                             ;; to 'job'.
                             (write '(set! getpw
                                       (const (getpwuid (getuid))))
                                    port)))

                         (call-with-output-file "job"
                           (lambda (port)
                             (write '#$job port)))

                         (invoke #+(file-append mcron "/bin/mcron")
                                 "--schedule=20" "prologue" "job")
                         (copy-file "job" #$output)))
                   #:options '(#:env-vars (("COLUMNS" . "150")))))

  (map validated-file jobs))

(define (shepherd-schedule-action mcron files)
  "Return a Shepherd action that runs MCRON with '--schedule' for the given
files."
  (shepherd-action
   (name 'schedule)
   (documentation
    "Display jobs that are going to be scheduled.")
   (procedure
    #~(lambda* (_ #:optional (n "5"))
        ;; XXX: This is a global side effect.
        (setenv "GUILE_AUTO_COMPILE" "0")

        ;; Run 'mcron' in a pipe so we can explicitly redirect its output to
        ;; 'current-output-port', which at this stage is bound to the client
        ;; connection.
        (let ((pipe (open-pipe* OPEN_READ
                                #$(file-append mcron "/bin/mcron")
                                (string-append "--schedule=" n)
                                #$@files)))
          (let loop ()
            (match (read-line pipe 'concat)
              ((? eof-object?)
               (catch 'system-error
                 (lambda ()
                   (zero? (close-pipe pipe)))
                 (lambda args
                   ;; There's a race with the SIGCHLD handler, which
                   ;; could call 'waitpid' before 'close-pipe' above does.  If
                   ;; we get ECHILD, that means we lost the race, but that's
                   ;; fine.
                   (or (= ECHILD (system-error-errno args))
                       (apply throw args)))))
              (line
               (display line)
               (loop)))))))))

(define (mcron-shepherd-services config)
  (match-record config <mcron-configuration>
    (mcron jobs log? log-file log-format date-format home-service?)
    (if (eq? jobs '())
        '()                             ;nothing to do
        (let ((files (job-files mcron jobs)))
          (list (shepherd-service
                 (provision '(mcron))
                 (requirement (if home-service?
                                  '()
                                  '(user-processes)))
                 (modules `((srfi srfi-1)
                            (srfi srfi-26)
                            (ice-9 popen) ;for the 'schedule' action
                            (ice-9 rdelim)
                            (ice-9 match)
                            ((shepherd support) #:hide (mkdir-p)) ;for '%user-log-dir'
                            ,@%default-modules))
                 (start #~(make-forkexec-constructor
                           (list #$(file-append mcron "/bin/mcron")
                                 #$@(if log?
                                        `("--log" "--log-format" ,log-format
                                          ,@(if date-format
                                                (list "--date-format"
                                                      date-format)
                                                '()))
                                        '())
                                 #$@files)

                           ;; Disable auto-compilation of the job files and
                           ;; set a sane value for 'PATH'.
                           #:environment-variables
                           (cons* "GUILE_AUTO_COMPILE=0"
                                  #$(if home-service?
                                        '(environ)
                                        '(cons*
                                          "PATH=/run/current-system/profile/bin"
                                          (remove (cut string-prefix? "PATH=" <>)
                                                  (environ)))))

                           #:log-file #$log-file))
                 (stop #~(make-kill-destructor))
                 (actions
                  (list (shepherd-schedule-action mcron files)))))))))

(define mcron-service-type
  (service-type (name 'mcron)
                (description
                 "Run the mcron job scheduling daemon.")
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          mcron-shepherd-services)
                       (service-extension profile-service-type
                                          (compose list
                                                   mcron-configuration-mcron))))
                (compose concatenate)
                (extend (lambda (config jobs)
                          (mcron-configuration
                           (inherit config)
                           (home-service?
                            (mcron-configuration-home-service? config))
                           (jobs (append (mcron-configuration-jobs config)
                                         jobs)))))
                (default-value (mcron-configuration)))) ;empty job list



(define-configuration/no-serialization cron-daemon-configuration
  (cron
   (package mcron)
   "The cron package to use.")
  (monitor-etc?
   (boolean #f)
   "Whether to check /etc/crontab for updates."))

(define (cron-daemon-shepherd-services config)
  (list (shepherd-service
         (provision '(cron-daemon))
         (start #~(make-forkexec-constructor
                   '(#$(file-append (cron-daemon-configuration-cron config)
                                    "/sbin/cron")
                     #$@(if (cron-daemon-configuration-monitor-etc? config)
                            '()
                            '("--noetc")))
                   #:pid-file "/var/run/cron.pid"))
         (stop #~(make-kill-destructor)))))

(define cron-daemon-activation
  (const #~(mkdir-p "/var/cron/tabs")))

(define (cron-daemon-setuid-programs config)
  (list (privileged-program
         (program (file-append (cron-daemon-configuration-cron config)
                               "/sbin/crontab-access")))))

(define cron-daemon-service-type
  (service-type (name 'cron-daemon)
                (description
                 "Run the traditional cron daemon.")
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          cron-daemon-shepherd-services)
                       (service-extension activation-service-type
                                          cron-daemon-activation)
                       (service-extension privileged-program-service-type
                                          cron-daemon-setuid-programs)))
                (default-value (cron-daemon-configuration))))

;;; mcron.scm ends here
generated by cgit
(uuid? (file-system-device fs))) file-systems))) '())) (define (machine-check-initrd-modules machine) "Return a list of <remote-assertion> that raise a '&message' error condition if any of the modules needed by 'needed-for-boot' file systems in MACHINE are not available in the initrd." (define file-systems (filter (lambda (file-system) (and (file-system-needed-for-boot? file-system) (not (member (file-system-type file-system) %pseudo-file-system-types)))) (operating-system-file-systems (machine-operating-system machine)))) (define (missing-modules fs) (define remote-exp (let ((device (file-system-device fs))) (with-imported-modules (source-module-closure '((gnu build file-systems) (gnu build linux-modules) (gnu system uuid))) #~(begin (use-modules (gnu build file-systems) (gnu build linux-modules) (gnu system uuid)) (define dev #$(cond ((string? device) device) ((uuid? device) #~(find-partition-by-uuid (string->uuid #$(uuid->string device)))) ((file-system-label? device) #~(find-partition-by-label #$(file-system-label->string device))))) (missing-modules dev '#$(operating-system-initrd-modules (machine-operating-system machine))))))) (remote-let ((missing remote-exp)) (unless (null? missing) (raise (formatted-message (G_ "missing modules for ~a:~{ ~a~}~%") (file-system-device fs) missing))))) (if (machine-ssh-configuration-safety-checks? (machine-configuration machine)) (map missing-modules file-systems) '())) (define* (machine-check-forward-update machine) "Check whether we are making a forward update for MACHINE. Depending on its 'allow-upgrades?' field, raise an error or display a warning if we are potentially downgrading it." (define config (machine-configuration machine)) (define validate-reconfigure (if (machine-ssh-configuration-allow-downgrades? config) warn-about-backward-reconfigure ensure-forward-reconfigure)) (remote-let ((provenance #~(call-with-input-file "/run/current-system/provenance" read))) (define channels (sexp->system-provenance provenance)) (check-forward-update validate-reconfigure #:current-channels channels))) (define (machine-check-building-for-appropriate-system machine) "Raise a '&message' error condition if MACHINE is configured to be built locally and the 'system' field does not match the '%current-system' reported by MACHINE." (let ((config (machine-configuration machine)) (system (remote-system (machine-ssh-session machine)))) (when (and (machine-ssh-configuration-build-locally? config) (not (string= system (machine-ssh-configuration-system config)))) (raise (formatted-message (G_ "incorrect target system\ ('~a' was given, while the system reports that it is '~a')~%") (machine-ssh-configuration-system config) system))))) (define (check-deployment-sanity machine) "Raise a '&message' error condition if it is clear that deploying MACHINE's 'system' declaration would fail." (define assertions (parameterize ((%current-system (machine-ssh-configuration-system (machine-configuration machine))) (%current-target-system #f)) (append (machine-check-file-system-availability machine) (machine-check-initrd-modules machine) (list (machine-check-forward-update machine))))) (define aggregate-exp ;; Gather all the expressions so that a single round-trip is enough to ;; evaluate all the ASSERTIONS remotely. #~(map (lambda (file) (false-if-exception (primitive-load file))) '#$(map (lambda (assertion) (scheme-file "remote-assertion.scm" (remote-assertion-expression assertion))) assertions))) ;; First check MACHINE's system type--an incorrect value for 'system' would ;; cause subsequent invocations of 'remote-eval' to fail. (machine-check-building-for-appropriate-system machine) (mlet %store-monad ((values (machine-remote-eval machine aggregate-exp))) (for-each (lambda (proc value) (proc value)) (map remote-assertion-procedure assertions) values) (return #t))) ;;; ;;; System deployment. ;;; (define not-config? ;; Select (guix …) and (gnu …) modules, except (guix config). (match-lambda (('guix 'config) #f) (('guix _ ...) #t) (('gnu _ ...) #t) (_ #f))) (define (machine-boot-parameters machine) "Monadic procedure returning a list of 'boot-parameters' for the generations of MACHINE's system profile, ordered from most recent to oldest." (define bootable-kernel-arguments (@@ (gnu system) bootable-kernel-arguments)) (define remote-exp (with-extensions (list guile-gcrypt) (with-imported-modules `(((guix config) => ,(make-config.scm)) ,@(source-module-closure '((guix profiles)) #:select? not-config?)) #~(begin (use-modules (guix config) (guix profiles) (ice-9 textual-ports)) (define %system-profile (string-append %state-directory "/profiles/system")) (define (read-file path) (call-with-input-file path (lambda (port) (get-string-all port)))) (map (lambda (generation) (let* ((system-path (generation-file-name %system-profile generation)) (boot-parameters-path (string-append system-path "/parameters")) (time (stat:mtime (lstat system-path)))) (list generation system-path time (read-file boot-parameters-path)))) (reverse (generation-numbers %system-profile))))))) (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp))) (return (map (lambda (generation) (match generation ((generation system-path time serialized-params) (let* ((params (call-with-input-string serialized-params read-boot-parameters)) (root (boot-parameters-root-device params)) (label (boot-parameters-label params)) (version (boot-parameters-version params))) (boot-parameters (inherit params) (label (string-append label " (#" (number->string generation) ", " (let ((time (make-time time-utc 0 time))) (date->string (time-utc->date time) "~Y-~m-~d ~H:~M")) ")")) (kernel-arguments (append (bootable-kernel-arguments system-path root version) (boot-parameters-kernel-arguments params)))))))) generations)))) (define-syntax-rule (with-roll-back should-roll-back? mbody ...) "Catch exceptions that arise when binding MBODY, a monadic expression in %STORE-MONAD, and collect their arguments in a &deploy-error condition, with the 'should-roll-back' field set to SHOULD-ROLL-BACK?" (catch #t (lambda () mbody ...) (lambda args (raise (condition (&deploy-error (should-roll-back should-roll-back?) (captured-args args))))))) (define (deploy-managed-host machine) "Internal implementation of 'deploy-machine' for MACHINE instances with an environment type of 'managed-host." (define config (machine-configuration machine)) (define host (machine-ssh-configuration-host-name config)) (define system (machine-ssh-configuration-system config)) (maybe-raise-unsupported-configuration-error machine) (when (machine-ssh-configuration-authorize? (machine-configuration machine)) (unless (file-exists? %public-key-file) (raise (formatted-message (G_ "no signing key '~a'. \ Have you run 'guix archive --generate-key'?") %public-key-file))) (remote-authorize-signing-key (call-with-input-file %public-key-file (lambda (port) (string->canonical-sexp (get-string-all port)))) (machine-ssh-session machine) (machine-become-command machine))) (mlet %store-monad ((_ (check-deployment-sanity machine)) (boot-parameters (machine-boot-parameters machine))) ;; Make sure code that check %CURRENT-SYSTEM, such as ;; %BASE-INITRD-MODULES, gets to see the right value. (parameterize ((%current-system system) (%current-target-system #f)) (let* ((os (machine-operating-system machine)) (eval (cut machine-remote-eval machine <>)) (menu-entries (map boot-parameters->menu-entry boot-parameters)) (bootloader-configuration (operating-system-bootloader os)) (bootcfg (operating-system-bootcfg os menu-entries))) (define-syntax-rule (eval/error-handling condition handler ...) ;; Return a wrapper around EVAL such that HANDLER is evaluated if an ;; exception is raised. (lambda (exp) (lambda (store) (guard (condition ((inferior-exception? condition) (values (begin handler ...) store))) (values (run-with-store store (eval exp) #:system system) store))))) (mbegin %store-monad (with-roll-back #f (switch-to-system (eval/error-handling c (raise (formatted-message (G_ "\ failed to switch systems while deploying '~a':~%~{~s ~}") host (inferior-exception-arguments c)))) os)) (parameterize ((%current-system system) (%current-target-system #f)) (with-roll-back #t (mbegin %store-monad (upgrade-shepherd-services (eval/error-handling c (warning (G_ "\ an error occurred while upgrading services on '~a':~%~{~s ~}~%") host (inferior-exception-arguments c))) os) (load-system-for-kexec (eval/error-handling c (warning (G_ "\ failed to load system of '~a' for kexec reboot:~%~{~s~^ ~}~%") host (inferior-exception-arguments c))) os) (install-bootloader (eval/error-handling c (raise (formatted-message (G_ "\ failed to install bootloader on '~a':~%~{~s ~}~%") host (inferior-exception-arguments c)))) bootloader-configuration bootcfg))))))))) ;;; ;;; Roll-back. ;;; (define (roll-back-managed-host machine) "Internal implementation of 'roll-back-machine' for MACHINE instances with an environment type of 'managed-host." (define remote-exp (with-extensions (list guile-gcrypt) (with-imported-modules (source-module-closure '((guix config) (guix profiles))) #~(begin (use-modules (guix config) (guix profiles)) (define %system-profile (string-append %state-directory "/profiles/system")) (define target-generation (relative-generation %system-profile -1)) (if target-generation (switch-to-generation %system-profile target-generation) 'error))))) (define roll-back-failure (condition (&message (message (G_ "could not roll-back machine"))))) (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)) (_ -> (if (< (length boot-parameters) 2) (raise roll-back-failure))) (entries -> (map boot-parameters->menu-entry (list (second boot-parameters)))) (locale -> (boot-parameters-locale (second boot-parameters))) (crypto-dev -> (boot-parameters-store-crypto-devices (second boot-parameters))) (store-dir -> (boot-parameters-store-directory-prefix (second boot-parameters))) (old-entries -> (map boot-parameters->menu-entry (drop boot-parameters 2))) (bootloader -> (operating-system-bootloader (machine-operating-system machine))) (bootcfg (lower-object ((bootloader-configuration-file-generator (bootloader-configuration-bootloader bootloader)) bootloader entries #:locale locale #:store-crypto-devices crypto-dev #:store-directory-prefix store-dir #:old-entries old-entries))) (remote-result (machine-remote-eval machine remote-exp))) (when (eqv? 'error remote-result) (raise roll-back-failure)))) ;;; ;;; Environment type. ;;; (define managed-host-environment-type (environment-type (machine-remote-eval managed-host-remote-eval) (deploy-machine deploy-managed-host) (roll-back-machine roll-back-managed-host) (name 'managed-host-environment-type) (description "Provisioning for machines that are accessible over SSH and have a known host-name. This entails little more than maintaining an SSH connection to the host."))) (define (maybe-raise-unsupported-configuration-error machine) "Raise an error if MACHINE's configuration is not an instance of <machine-ssh-configuration>." (let ((config (machine-configuration machine)) (environment (environment-type-name (machine-environment machine)))) (unless (and config (machine-ssh-configuration? config)) (raise (formatted-message (G_ "unsupported machine configuration '~a' for environment of type '~a'") config environment))))) ;; Local Variables: ;; eval: (put 'remote-let 'scheme-indent-function 1) ;; eval: (put 'with-roll-back 'scheme-indent-function 1) ;; eval: (put 'eval/error-handling 'scheme-indent-function 1) ;; End:
generated by cgit