Re: cron-service

[Ludovic Courtès]

Hi!

Danny Milosavljevic <address@hidden> skribis:

> I've seen the mcron package but I don't understand how it gets launched. 
> Should there be a cron-service ?

Ah ha!  I have a preliminary mcron service (attached).  It’s
undocumented and subject to change, but feedback is welcome!

Currently it’s designed to run on ‘mcron’ process per user/group pair.
Eventually, we’ll probably change mcron to allow us to run a single
instance as root, and it will automatically setuid/setgid for each job.

I told Mathieu Lirzin off-line about a couple of minor issues that would
need to be fixed in his mcron branch¹, after which we can probably
commit it (but let’s not put pressure on him!).

Thanks,
Ludo’.

¹ https://notabug.org/mthl/mcron

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ludovic Courtès <address@hidden>
;;;
;;; 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 base)
  #:use-module (gnu services shepherd)
  #:autoload   (gnu packages guile) (mcron)
  #: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-job
            mcron-job?
            mcron-job-user
            mcron-job-group
            mcron-job-specification
            mcron-job-imported-modules
            mcron-job-modules

            mcron-service-type
            mcron-service))

;;; 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 (mcron-job
;;                        (user "alice")
;;                        (specification
;;                         #~(job next-second-from
;;                                (lambda ()
;;                                  (call-with-output-file "/dev/console"
;;                                    (lambda (port)
;;                                      (display "hello!\n" port)))))))))))
;;;
;;; Code:

(define-record-type* <mcron-configuration> mcron-configuration
  make-mcron-configuration
  mcron-configuration?
  (mcron             mcron-configuration-mcron    ;package
                     (default mcron))
  (jobs              mcron-configuration-jobs     ;list of <mcron-job>
                     (default '())))

(define-record-type* <mcron-job> mcron-job make-mcron-job
  mcron-job?
  (user              mcron-job-user (default "root"))  ;string
  (group             mcron-job-group (default #f))     ;string | #f
  (specification     mcron-job-specification)          ;gexp
  (imported-modules  mcron-job-imported-modules        ;list
                     (default '()))
  (modules           mcron-job-modules                 ;list
                     (default '())))

(define (job-file job)
  (scheme-file "mcron-job"
               (mcron-job-specification job)))

(define (mcron-shepherd-service mcron jobs)
  (match jobs
    ((($ <mcron-job> user group) _ ...)
     (shepherd-service
      (provision (list (string->symbol
                        (string-append "mcron-" user
                                       (if group
                                           (string-append "-" group)
                                           "")))))
      (requirement '(user-processes))
      (start #~(make-forkexec-constructor
                (list (string-append #$mcron "/bin/mcron")
                      #$@(map job-file jobs))
                #:user #$user
                #:group #$(if user
                              (or group
                                  #~(group:name
                                     (getgrgid (passwd:gid (getpw #$user)))))
                              group)))
      (stop #~(make-kill-destructor))))))

(define mcron-shepherd-services
  (match-lambda
    (($ <mcron-configuration> mcron jobs)
     (define sorted-jobs
       (fold (lambda (job result)
               (match job
                 (($ <mcron-job> user group)
                  (vhash-cons (list user group) job result))))
             vlist-null
             jobs))

     (define users+groups
       (delete-duplicates
        (match jobs
          ((($ <mcron-job> users groups) ...)
           (zip users groups)))))

     (map (lambda (key)
            (mcron-shepherd-service mcron (vhash-fold* cons '() key 
sorted-jobs)))
          users+groups))))

(define mcron-service-type
  (service-type (name 'mcron)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          mcron-shepherd-services)))
                (compose concatenate)
                (extend (lambda (config jobs)
                          (mcron-configuration
                           (inherit config)
                           (jobs (append (mcron-configuration-jobs config)
                                         jobs)))))))

(define* (mcron-service #:optional (mcron mcron))
  (service mcron-service-type (mcron-configuration (mcron mcron))))

;;; mcron.scm ends here

modified   gnu/packages/guile.scm
@@ -41,6 +41,7 @@
   #:use-module (gnu packages ed)
   #:use-module (gnu packages base)
   #:use-module (gnu packages texinfo)
+  #:use-module (gnu packages man)
   #:use-module (gnu packages gettext)
   #:use-module (gnu packages databases)
   #:use-module (gnu packages python)
@@ -424,6 +425,54 @@ Guile, so its configuration can be written in Scheme; the 
original cron
 format is also supported.")
     (license gpl3+)))
 
+(define-public mcron2
+  (let ((commit "573a09a32684c091cb8e8f521946f8bf90a295af"))
+    (package
+      (inherit mcron)
+      (name "mcron2")
+      (version (string-append (package-version mcron) "-0."
+                              (string-take commit 7)))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://notabug.org/mthl/mcron/";)
+                      (commit commit)))
+                (sha256
+                 (base32
+                  "0m4kcpxmcr3rf6l6dd2z0m427gc2y1xx9z361j2zw3jgvamg0yhw"))
+                (file-name (string-append name "-" version "-checkout"))))
+      (native-inputs
+       `(("autoconf" ,autoconf)
+         ("automake" ,automake)
+         ("pkg-config" ,pkg-config)
+         ("texinfo" ,texinfo)
+         ("help2man" ,help2man)))
+      (arguments
+       `(#:modules ((ice-9 match) (ice-9 ftw)
+                    ,@%gnu-build-system-modules)
+
+         #:phases (modify-phases %standard-phases
+                    (add-after 'unpack 'bootstrap
+                      (lambda _
+                        (zero? (system* "autoreconf" "-vfi"))))
+                    (add-after 'install 'wrap-mcron
+                      (lambda* (#:key outputs #:allow-other-keys)
+                        ;; Wrap the 'mcron' command to refer to the right
+                        ;; modules.
+                        (let* ((out  (assoc-ref outputs "out"))
+                               (bin  (string-append out "/bin"))
+                               (site (string-append
+                                      out "/share/guile/site")))
+                          (match (scandir site)
+                            (("." ".." version)
+                             (let ((modules (string-append site "/" version)))
+                               (wrap-program (string-append bin "/mcron")
+                                 `("GUILE_LOAD_PATH" ":" prefix
+                                   (,modules))
+                                 `("GUILE_LOAD_COMPILED_PATH" ":" prefix
+                                   (,modules)))
+                               #t))))))))))))
+
 (define-public guile-lib
   (package
     (name "guile-lib")
modified   gnu/system/examples/bare-bones.tmpl
@@ -2,7 +2,7 @@
 ;; for a "bare bones" setup, with no X11 display server.
 
 (use-modules (gnu))
-(use-service-modules networking ssh)
+(use-service-modules networking ssh mcron)
 (use-package-modules admin)
 
 (operating-system
@@ -42,6 +42,15 @@
 
   ;; Add services to the baseline: a DHCP client and
   ;; an SSH server.
-  (services (cons* (dhcp-client-service)
-                   (lsh-service #:port-number 2222)
+  (services (cons* (service mcron-service-type
+                            (mcron-configuration
+                             (jobs (list (mcron-job
+                                          (user "alice")
+                                          (specification
+                                           #~(job next-second-from
+                                                  (lambda ()
+                                                    (call-with-output-file
+                                                        "/dev/console"
+                                                      (lambda (port)
+                                                        (display "hello!\n" 
port)))))))))))
                    %base-services)))