;;; 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 | 2020-05-04 | git-authenticate: Add missing import....* build-aux/git-authenticate.scm: Import (guix utils), used by the cache
handling code and inadvertently removed in
041dc3a9c0694ada41b86115b9774a23c9d50f73.
| Ludovic Courtès |
| 2020-05-04 | git-authenticate: Load the keyring from the repository....* build-aux/git-authenticate.scm (load-keyring-from-blob)
(load-keyring-from-reference): New procedures.
(authenticate-commits): Add #:keyring-reference and use
'load-keyring-from-reference'.
| Ludovic Courtès |
| 2020-05-04 | git-authenticate: Load the list of authorized keys from the tree....* build-aux/git-authenticate.scm (read-authorizations)
(commit-authorized-keys): New procedures.
(authenticate-commit): Use it instead of %AUTHORIZED-SIGNING-KEYS.
| Ludovic Courtès |
| 2020-05-04 | git-authenticate: Use (guix openpgp)....It can now authenticate 14K+ commits in 23s instead of 4mn20.
* build-aux/git-authenticate.scm (%authorized-signing-keys): Turn
fingerprints into bytevectors.
(with-temporary-files): Remove.
(commit-signing-key): Add 'keyring' parameter. Use
'string->openpgp-packet' and 'verify-openpgp-signature' instead of (guix
gnupg) procedures.
(authenticate-commit): Add 'keyring' parameter. Pass it to
'commit-signing-key'. Adjust to SIGNING-KEY being an <openpgp-public-key>.
(authenticate-commits): Remove 'parameterize'. Load keyring with
'get-openpgp-keyring'.
(git-authenticate): When printing stats, adjust to SIGNER being an
<openpgp-public-key>.
| Ludovic Courtès |
(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
