[jackhill/guix/guix.git] / gnu / services / admin.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;;
;;; 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 admin)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages certs)
  #:use-module (gnu packages package-management)
  #:use-module (gnu services)
  #:use-module (gnu services mcron)
  #:use-module (gnu services shepherd)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 vlist)
  #:export (%default-rotations
            %rotated-files

            log-rotation
            log-rotation?
            log-rotation-frequency
            log-rotation-files
            log-rotation-options
            log-rotation-post-rotate

            rottlog-configuration
            rottlog-configuration?
            rottlog-service
            rottlog-service-type

            log-cleanup-service-type
            log-cleanup-configuration
            log-cleanup-configuration?
            log-cleanup-configuration-directory
            log-cleanup-configuration-expiry
            log-cleanup-configuration-schedule

            unattended-upgrade-service-type
            unattended-upgrade-configuration
            unattended-upgrade-configuration?
            unattended-upgrade-configuration-operating-system-file
            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))

;;; Commentary:
;;;
;;; This module implements configuration of rottlog by writing
;;; /etc/rottlog/{rc,hourly|daily|weekly}.  Example usage
;;;
;;;     (mcron-service)
;;;     (service rottlog-service-type)
;;;
;;; Code:

(define-record-type* <log-rotation> log-rotation make-log-rotation
  log-rotation?
  (files       log-rotation-files)                ;list of strings
  (frequency   log-rotation-frequency             ;symbol
               (default 'weekly))
  (post-rotate log-rotation-post-rotate           ;#f | gexp
               (default #f))
  (options     log-rotation-options               ;list of strings
               (default '())))

(define %rotated-files
  ;; Syslog files subject to rotation.
  '("/var/log/messages" "/var/log/secure" "/var/log/debug"
    "/var/log/maillog" "/var/log/mcron.log"))

(define %default-rotations
  (list (log-rotation                             ;syslog files
         (files %rotated-files)

         (options '(;; Run post-rotate once per rotation
                    "sharedscripts"
                    ;; Append .gz to rotated files
                    "storefile @FILENAME.@COMP_EXT"))
         ;; Restart syslogd after rotation.
         (post-rotate #~(let ((pid (call-with-input-file "/var/run/syslog.pid"
                                     read)))
                          (kill pid SIGHUP))))
        (log-rotation
         (files '("/var/log/guix-daemon.log"))
         (options '("rotate 4"                    ;don't keep too many of them
                    "storefile @FILENAME.@COMP_EXT")))))

(define (log-rotation->config rotation)
  "Return a string-valued gexp representing the rottlog configuration snippet
for ROTATION."
  (define post-rotate
    (let ((post (log-rotation-post-rotate rotation)))
      (and post
           (program-file "rottlog-post-rotate.scm" post))))

  #~(let ((post #$post-rotate))
      (string-append (string-join '#$(log-rotation-files rotation) ",")
                     " {"
                     #$(string-join (log-rotation-options rotation)
                                    "\n  " 'prefix)
                     (if post
                         (string-append "\n  postrotate\n    " post
                                        "\n  endscript\n")
                         "")
                     "\n}\n")))

(define (log-rotations->/etc-entries rotations)
  "Return the list of /etc entries for ROTATIONS, a list of <log-rotation>."
  (define (frequency-file frequency rotations)
    (computed-file (string-append "rottlog." (symbol->string frequency))
                   #~(call-with-output-file #$output
                       (lambda (port)
                         (for-each (lambda (str)
                                     (display str port))
                                   (list #$@(map log-rotation->config
                                                 rotations)))))))

  (let* ((frequencies (delete-duplicates
                       (map log-rotation-frequency rotations)))
         (table       (fold (lambda (rotation table)
                              (vhash-consq (log-rotation-frequency rotation)
                                           rotation table))
                            vlist-null
                            rotations)))
    (map (lambda (frequency)
           `(,(symbol->string frequency)
             ,(frequency-file frequency
                              (vhash-foldq* cons '() frequency table))))
         frequencies)))

(define (default-jobs rottlog)
  (list #~(job '(next-hour '(0))                  ;midnight
               #$(file-append rottlog "/sbin/rottlog"))
        #~(job '(next-hour '(12))                 ;noon
               #$(file-append rottlog "/sbin/rottlog"))))

(define-record-type* <rottlog-configuration>
  rottlog-configuration make-rottlog-configuration
  rottlog-configuration?
  (rottlog            rottlog-rottlog             ;file-like
                      (default rottlog))
  (rc-file            rottlog-rc-file             ;file-like
                      (default (file-append rottlog "/etc/rc")))
  (rotations          rottlog-rotations           ;list of <log-rotation>
                      (default %default-rotations))
  (jobs               rottlog-jobs                ;list of <mcron-job>
                      (default #f)))

(define (rottlog-etc config)
  `(("rottlog"
     ,(file-union "rottlog"
                  (cons `("rc" ,(rottlog-rc-file config))
                        (log-rotations->/etc-entries
                         (rottlog-rotations config)))))))

(define (rottlog-jobs-or-default config)
  (or (rottlog-jobs config)
      (default-jobs (rottlog-rottlog config))))

(define rottlog-service-type
  (service-type
   (name 'rottlog)
   (description
    "Periodically rotate log files using GNU@tie{}Rottlog and GNU@tie{}mcron.
Old log files are removed or compressed according to the configuration.")
   (extensions (list (service-extension etc-service-type rottlog-etc)
                     (service-extension mcron-service-type
                                        rottlog-jobs-or-default)

                     ;; Add Rottlog to the global profile so users can access
                     ;; the documentation.
                     (service-extension profile-service-type
                                        (compose list rottlog-rottlog))))
   (compose concatenate)
   (extend (lambda (config rotations)
             (rottlog-configuration
              (inherit config)
              (rotations (append (rottlog-rotations config)
                                 rotations)))))
   (default-value (rottlog-configuration))))

\f
;;;
;;; 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-mcron-jobs configuration)
  (match-record configuration <log-cleanup-configuration>
    (directory expiry schedule)
    (list #~(job #$schedule
                 #$(log-cleanup-program directory expiry)))))

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

\f
;;;
;;; 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"))
  (schedule             unattended-upgrade-configuration-schedule
                        (default "30 01 * * 0"))
  (channels             unattended-upgrade-configuration-channels
                        (default #~%default-channels))
  (services-to-restart  unattended-upgrade-configuration-services-to-restart
                        (default '(mcron)))
  (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-mcron-jobs config)
  (define channels
    (scheme-file "channels.scm"
                 (unattended-upgrade-configuration-channels config)))

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

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

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

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

  (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-19)
                       (srfi srfi-34))

          (define log
            (open-file #$log "a0"))

          (define (timestamp)
            (date->string (time-utc->date (current-time time-utc))
                          "[~4]"))

          (define (alarm-handler . _)
            (format #t "~a time is up, aborting upgrade~%"
                    (timestamp))
            (exit 1))

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

          ;; Make sure the upgrade doesn't take too long.
          (sigaction SIGALRM alarm-handler)
          (alarm #$(unattended-upgrade-maximum-duration config))

          ;; Redirect stdout/stderr to LOG to save the output of 'guix' below.
          (redirect-port log (current-output-port))
          (redirect-port log (current-error-port))

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

            ;; '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")))

            (format #t "~a restarting services...~%" (timestamp))
            (for-each restart-service '#$services)

            ;; XXX: If 'mcron' has been restarted, perhaps this isn't
            ;; reached.
            (format #t "~a upgrade complete~%" (timestamp))))))

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

  (list #~(job #$(unattended-upgrade-configuration-schedule config)
               #$upgrade)))

(define (unattended-upgrade-log-rotations config)
  (list (log-rotation
         (files
          (list (unattended-upgrade-configuration-log-file config))))))

(define unattended-upgrade-service-type
  (service-type
   (name 'unattended-upgrade)
   (extensions
    (list (service-extension mcron-service-type
                             unattended-upgrade-mcron-jobs)
          (service-extension rottlog-service-type
                             unattended-upgrade-log-rotations)))
   (description
    "Periodically upgrade the system from the current configuration.")
   (default-value (unattended-upgrade-configuration))))

;;; admin.scm ends here
Commit	Line	Data
92c03a87 JN	1	;;; GNU Guix --- Functional package management for GNU
92c03a87 JN	2	;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
3b9b3b49	3	;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
ab034adf	4	;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
92c03a87 JN	5	;;;
	6	;;; This file is part of GNU Guix.
	7	;;;
	8	;;; GNU Guix is free software; you can redistribute it and/or modify it
	9	;;; under the terms of the GNU General Public License as published by
	10	;;; the Free Software Foundation; either version 3 of the License, or (at
	11	;;; your option) any later version.
	12	;;;
	13	;;; GNU Guix is distributed in the hope that it will be useful, but
	14	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	15	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	;;; GNU General Public License for more details.
	17	;;;
83715a7e	18	;;; You should have received a copy of the GNU General Public License
92c03a87 JN	19	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	20
	21	(define-module (gnu services admin)
	22	#:use-module (gnu packages admin)
79501f26 LC	23	#:use-module (gnu packages certs)
79501f26 LC	24	#:use-module (gnu packages package-management)
92c03a87 JN	25	#:use-module (gnu services)
	26	#:use-module (gnu services mcron)
	27	#:use-module (gnu services shepherd)
	28	#:use-module (guix gexp)
79501f26	29	#:use-module (guix modules)
92c03a87 JN	30	#:use-module (guix packages)
	31	#:use-module (guix records)
	32	#:use-module (srfi srfi-1)
81fa2229	33	#:use-module (ice-9 vlist)
92c03a87 JN	34	#:export (%default-rotations
92c03a87 JN	35	%rotated-files
81fa2229 LC	36
	37	log-rotation
	38	log-rotation?
	39	log-rotation-frequency
	40	log-rotation-files
	41	log-rotation-options
	42	log-rotation-post-rotate
	43
92c03a87 JN	44	rottlog-configuration
	45	rottlog-configuration?
	46	rottlog-service
79501f26 LC	47	rottlog-service-type
79501f26 LC	48
3b9b3b49 LC	49	log-cleanup-service-type
	50	log-cleanup-configuration
	51	log-cleanup-configuration?
	52	log-cleanup-configuration-directory
	53	log-cleanup-configuration-expiry
	54	log-cleanup-configuration-schedule
	55
79501f26 LC	56	unattended-upgrade-service-type
	57	unattended-upgrade-configuration
	58	unattended-upgrade-configuration?
0d203eea	59	unattended-upgrade-configuration-operating-system-file
79501f26 LC	60	unattended-upgrade-configuration-channels
	61	unattended-upgrade-configuration-schedule
	62	unattended-upgrade-configuration-services-to-restart
	63	unattended-upgrade-configuration-system-expiration
	64	unattended-upgrade-configuration-maximum-duration
	65	unattended-upgrade-configuration-log-file))
92c03a87 JN	66
	67	;;; Commentary:
	68	;;;
	69	;;; This module implements configuration of rottlog by writing
	70	;;; /etc/rottlog/{rc,hourly\|daily\|weekly}. Example usage
	71	;;;
	72	;;; (mcron-service)
81fa2229	73	;;; (service rottlog-service-type)
92c03a87 JN	74	;;;
	75	;;; Code:
	76
81fa2229 LC	77	(define-record-type* <log-rotation> log-rotation make-log-rotation
	78	log-rotation?
	79	(files log-rotation-files) ;list of strings
	80	(frequency log-rotation-frequency ;symbol
	81	(default 'weekly))
	82	(post-rotate log-rotation-post-rotate ;#f \| gexp
	83	(default #f))
	84	(options log-rotation-options ;list of strings
	85	(default '())))
	86
92c03a87	87	(define %rotated-files
4d67ed70	88	;; Syslog files subject to rotation.
7fe1432a	89	'("/var/log/messages" "/var/log/secure" "/var/log/debug"
3104a743	90	"/var/log/maillog" "/var/log/mcron.log"))
92c03a87	91
92c03a87	92	(define %default-rotations
81fa2229 LC	93	(list (log-rotation ;syslog files
	94	(files %rotated-files)
	95
ab034adf BW	96	(options '(;; Run post-rotate once per rotation
	97	"sharedscripts"
	98	;; Append .gz to rotated files
	99	"storefile @FILENAME.@COMP_EXT"))
81fa2229	100	;; Restart syslogd after rotation.
81fa2229 LC	101	(post-rotate #~(let ((pid (call-with-input-file "/var/run/syslog.pid"
	102	read)))
	103	(kill pid SIGHUP))))
	104	(log-rotation
0996d48d LC	105	(files '("/var/log/guix-daemon.log"))
	106	(options '("rotate 4" ;don't keep too many of them
	107	"storefile @FILENAME.@COMP_EXT")))))
81fa2229 LC	108
	109	(define (log-rotation->config rotation)
	110	"Return a string-valued gexp representing the rottlog configuration snippet
	111	for ROTATION."
	112	(define post-rotate
	113	(let ((post (log-rotation-post-rotate rotation)))
	114	(and post
	115	(program-file "rottlog-post-rotate.scm" post))))
	116
	117	#~(let ((post #$post-rotate))
	118	(string-append (string-join '#$(log-rotation-files rotation) ",")
	119	" {"
	120	#$(string-join (log-rotation-options rotation)
	121	"\n " 'prefix)
	122	(if post
	123	(string-append "\n postrotate\n " post
	124	"\n endscript\n")
	125	"")
	126	"\n}\n")))
	127
	128	(define (log-rotations->/etc-entries rotations)
	129	"Return the list of /etc entries for ROTATIONS, a list of <log-rotation>."
	130	(define (frequency-file frequency rotations)
	131	(computed-file (string-append "rottlog." (symbol->string frequency))
	132	#~(call-with-output-file #$output
	133	(lambda (port)
	134	(for-each (lambda (str)
	135	(display str port))
	136	(list #$@(map log-rotation->config
	137	rotations)))))))
	138
	139	(let* ((frequencies (delete-duplicates
	140	(map log-rotation-frequency rotations)))
	141	(table (fold (lambda (rotation table)
	142	(vhash-consq (log-rotation-frequency rotation)
	143	rotation table))
	144	vlist-null
	145	rotations)))
	146	(map (lambda (frequency)
	147	`(,(symbol->string frequency)
	148	,(frequency-file frequency
	149	(vhash-foldq* cons '() frequency table))))
	150	frequencies)))
92c03a87 JN	151
	152	(define (default-jobs rottlog)
	153	(list #~(job '(next-hour '(0)) ;midnight
89fdd9ee	154	#$(file-append rottlog "/sbin/rottlog"))
92c03a87	155	#~(job '(next-hour '(12)) ;noon
89fdd9ee	156	#$(file-append rottlog "/sbin/rottlog"))))
92c03a87 JN	157
	158	(define-record-type* <rottlog-configuration>
	159	rottlog-configuration make-rottlog-configuration
	160	rottlog-configuration?
892f1b72	161	(rottlog rottlog-rottlog ;file-like
92c03a87 JN	162	(default rottlog))
	163	(rc-file rottlog-rc-file ;file-like
	164	(default (file-append rottlog "/etc/rc")))
81fa2229	165	(rotations rottlog-rotations ;list of <log-rotation>
92c03a87 JN	166	(default %default-rotations))
	167	(jobs rottlog-jobs ;list of <mcron-job>
	168	(default #f)))
	169
	170	(define (rottlog-etc config)
81fa2229 LC	171	`(("rottlog"
	172	,(file-union "rottlog"
	173	(cons `("rc" ,(rottlog-rc-file config))
	174	(log-rotations->/etc-entries
	175	(rottlog-rotations config)))))))
92c03a87 JN	176
	177	(define (rottlog-jobs-or-default config)
	178	(or (rottlog-jobs config)
	179	(default-jobs (rottlog-rottlog config))))
	180
	181	(define rottlog-service-type
	182	(service-type
	183	(name 'rottlog)
21b71b01 LC	184	(description
	185	"Periodically rotate log files using GNU@tie{}Rottlog and GNU@tie{}mcron.
	186	Old log files are removed or compressed according to the configuration.")
92c03a87 JN	187	(extensions (list (service-extension etc-service-type rottlog-etc)
92c03a87 JN	188	(service-extension mcron-service-type
26cfc415 LC	189	rottlog-jobs-or-default)
	190
	191	;; Add Rottlog to the global profile so users can access
	192	;; the documentation.
	193	(service-extension profile-service-type
3d3c5650	194	(compose list rottlog-rottlog))))
254ea3f9 LC	195	(compose concatenate)
	196	(extend (lambda (config rotations)
	197	(rottlog-configuration
	198	(inherit config)
	199	(rotations (append (rottlog-rotations config)
	200	rotations)))))
3d3c5650	201	(default-value (rottlog-configuration))))
92c03a87	202
79501f26	203	\f
3b9b3b49 LC	204	;;;
	205	;;; Build log removal.
	206	;;;
	207
	208	(define-record-type* <log-cleanup-configuration>
	209	log-cleanup-configuration make-log-cleanup-configuration
	210	log-cleanup-configuration?
	211	(directory log-cleanup-configuration-directory) ;string
	212	(expiry log-cleanup-configuration-expiry ;integer (seconds)
	213	(default (* 6 30 24 3600)))
	214	(schedule log-cleanup-configuration-schedule ;string or gexp
	215	(default "30 12 01,08,15,22 * *")))
	216
	217	(define (log-cleanup-program directory expiry)
	218	(program-file "delete-old-logs"
	219	(with-imported-modules '((guix build utils))
	220	#~(begin
	221	(use-modules (guix build utils))
	222
	223	(let* ((now (car (gettimeofday)))
	224	(logs (find-files #$directory
	225	(lambda (file stat)
	226	(> (- now (stat:mtime stat))
	227	#$expiry)))))
	228	(format #t "deleting ~a log files from '~a'...~%"
	229	(length logs) #$directory)
	230	(for-each delete-file logs))))))
	231
	232	(define (log-cleanup-mcron-jobs configuration)
	233	(match-record configuration <log-cleanup-configuration>
	234	(directory expiry schedule)
	235	(list #~(job #$schedule
	236	#$(log-cleanup-program directory expiry)))))
	237
	238	(define log-cleanup-service-type
	239	(service-type
	240	(name 'log-cleanup)
	241	(extensions
	242	(list (service-extension mcron-service-type
	243	log-cleanup-mcron-jobs)))
	244	(description
	245	"Periodically delete old log files.")))
	246
	247	\f
79501f26 LC	248	;;;
	249	;;; Unattended upgrade.
	250	;;;
	251
	252	(define-record-type* <unattended-upgrade-configuration>
	253	unattended-upgrade-configuration make-unattended-upgrade-configuration
	254	unattended-upgrade-configuration?
0d203eea LC	255	(operating-system-file unattended-upgrade-operating-system-file
0d203eea LC	256	(default "/run/current-system/configuration.scm"))
79501f26 LC	257	(schedule unattended-upgrade-configuration-schedule
	258	(default "30 01 * * 0"))
	259	(channels unattended-upgrade-configuration-channels
	260	(default #~%default-channels))
	261	(services-to-restart unattended-upgrade-configuration-services-to-restart
	262	(default '(mcron)))
	263	(system-expiration unattended-upgrade-system-expiration
	264	(default (* 3 30 24 3600)))
	265	(maximum-duration unattended-upgrade-maximum-duration
	266	(default 3600))
	267	(log-file unattended-upgrade-configuration-log-file
	268	(default %unattended-upgrade-log-file)))
	269
	270	(define %unattended-upgrade-log-file
	271	"/var/log/unattended-upgrade.log")
	272
	273	(define (unattended-upgrade-mcron-jobs config)
	274	(define channels
	275	(scheme-file "channels.scm"
	276	(unattended-upgrade-configuration-channels config)))
	277
	278	(define log
	279	(unattended-upgrade-configuration-log-file config))
	280
	281	(define services
	282	(unattended-upgrade-configuration-services-to-restart config))
	283
	284	(define expiration
	285	(unattended-upgrade-system-expiration config))
	286
0d203eea LC	287	(define config-file
	288	(unattended-upgrade-operating-system-file config))
	289
79501f26 LC	290	(define code
	291	(with-imported-modules (source-module-closure '((guix build utils)
	292	(gnu services herd)))
	293	#~(begin
	294	(use-modules (guix build utils)
	295	(gnu services herd)
	296	(srfi srfi-19)
	297	(srfi srfi-34))
	298
	299	(define log
	300	(open-file #$log "a0"))
	301
	302	(define (timestamp)
	303	(date->string (time-utc->date (current-time time-utc))
	304	"[~4]"))
	305
	306	(define (alarm-handler . _)
	307	(format #t "~a time is up, aborting upgrade~%"
	308	(timestamp))
	309	(exit 1))
	310
79501f26 LC	311	;; 'guix time-machine' needs X.509 certificates to authenticate the
	312	;; Git host.
	313	(setenv "SSL_CERT_DIR"
	314	#$(file-append nss-certs "/etc/ssl/certs"))
	315
	316	;; Make sure the upgrade doesn't take too long.
	317	(sigaction SIGALRM alarm-handler)
	318	(alarm #$(unattended-upgrade-maximum-duration config))
	319
fe42e5f3 LC	320	;; Redirect stdout/stderr to LOG to save the output of 'guix' below.
	321	(redirect-port log (current-output-port))
	322	(redirect-port log (current-error-port))
	323
	324	(format #t "~a starting upgrade...~%" (timestamp))
	325	(guard (c ((invoke-error? c)
	326	(report-invoke-error c)))
	327	(invoke #$(file-append guix "/bin/guix")
	328	"time-machine" "-C" #$channels
	329	"--" "system" "reconfigure" #$config-file)
	330
	331	;; 'guix system delete-generations' fails when there's no
	332	;; matching generation. Thus, catch 'invoke-error?'.
	333	(guard (c ((invoke-error? c)
	334	(report-invoke-error c)))
	335	(invoke #$(file-append guix "/bin/guix")
	336	"system" "delete-generations"
	337	#$(string-append (number->string expiration)
	338	"s")))
	339
	340	(format #t "~a restarting services...~%" (timestamp))
	341	(for-each restart-service '#$services)
	342
	343	;; XXX: If 'mcron' has been restarted, perhaps this isn't
	344	;; reached.
	345	(format #t "~a upgrade complete~%" (timestamp))))))
79501f26 LC	346
	347	(define upgrade
	348	(program-file "unattended-upgrade" code))
	349
	350	(list #~(job #$(unattended-upgrade-configuration-schedule config)
	351	#$upgrade)))
	352
	353	(define (unattended-upgrade-log-rotations config)
	354	(list (log-rotation
	355	(files
	356	(list (unattended-upgrade-configuration-log-file config))))))
	357
	358	(define unattended-upgrade-service-type
	359	(service-type
	360	(name 'unattended-upgrade)
	361	(extensions
	362	(list (service-extension mcron-service-type
	363	unattended-upgrade-mcron-jobs)
	364	(service-extension rottlog-service-type
	365	unattended-upgrade-log-rotations)))
	366	(description
	367	"Periodically upgrade the system from the current configuration.")
	368	(default-value (unattended-upgrade-configuration))))
	369
92c03a87	370	;;; admin.scm ends here