gnu/services/admin.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   3 ;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
   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 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  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)
  23   #:use-module (gnu packages certs)
  24   #:use-module (gnu packages package-management)
  25   #:use-module (gnu services)
  26   #:use-module (gnu services mcron)
  27   #:use-module (gnu services shepherd)
  28   #:use-module (guix gexp)
  29   #:use-module (guix modules)
  30   #:use-module (guix packages)
  31   #:use-module (guix records)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (ice-9 vlist)
  34   #:export (%default-rotations
  35             %rotated-files
  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
  44             rottlog-configuration
  45             rottlog-configuration?
  46             rottlog-service
  47             rottlog-service-type
  48
  49             unattended-upgrade-service-type
  50             unattended-upgrade-configuration
  51             unattended-upgrade-configuration?
  52             unattended-upgrade-configuration-operating-system-file
  53             unattended-upgrade-configuration-channels
  54             unattended-upgrade-configuration-schedule
  55             unattended-upgrade-configuration-services-to-restart
  56             unattended-upgrade-configuration-system-expiration
  57             unattended-upgrade-configuration-maximum-duration
  58             unattended-upgrade-configuration-log-file))
  59
  60 ;;; Commentary:
  61 ;;;
  62 ;;; This module implements configuration of rottlog by writing
  63 ;;; /etc/rottlog/{rc,hourly|daily|weekly}.  Example usage
  64 ;;;
  65 ;;;     (mcron-service)
  66 ;;;     (service rottlog-service-type)
  67 ;;;
  68 ;;; Code:
  69
  70 (define-record-type* <log-rotation> log-rotation make-log-rotation
  71   log-rotation?
  72   (files       log-rotation-files)                ;list of strings
  73   (frequency   log-rotation-frequency             ;symbol
  74                (default 'weekly))
  75   (post-rotate log-rotation-post-rotate           ;#f | gexp
  76                (default #f))
  77   (options     log-rotation-options               ;list of strings
  78                (default '())))
  79
  80 (define %rotated-files
  81   ;; Syslog files subject to rotation.
  82   '("/var/log/messages" "/var/log/secure" "/var/log/debug"
  83     "/var/log/maillog" "/var/log/mcron.log"))
  84
  85 (define %default-rotations
  86   (list (log-rotation                             ;syslog files
  87          (files %rotated-files)
  88
  89          (options '(;; Run post-rotate once per rotation
  90                     "sharedscripts"
  91                     ;; Append .gz to rotated files
  92                     "storefile @FILENAME.@COMP_EXT"))
  93          ;; Restart syslogd after rotation.
  94          (post-rotate #~(let ((pid (call-with-input-file "/var/run/syslog.pid"
  95                                      read)))
  96                           (kill pid SIGHUP))))
  97         (log-rotation
  98          (files '("/var/log/guix-daemon.log")))))
  99
 100 (define (log-rotation->config rotation)
 101   "Return a string-valued gexp representing the rottlog configuration snippet
 102 for ROTATION."
 103   (define post-rotate
 104     (let ((post (log-rotation-post-rotate rotation)))
 105       (and post
 106            (program-file "rottlog-post-rotate.scm" post))))
 107
 108   #~(let ((post #$post-rotate))
 109       (string-append (string-join '#$(log-rotation-files rotation) ",")
 110                      " {"
 111                      #$(string-join (log-rotation-options rotation)
 112                                     "\n  " 'prefix)
 113                      (if post
 114                          (string-append "\n  postrotate\n    " post
 115                                         "\n  endscript\n")
 116                          "")
 117                      "\n}\n")))
 118
 119 (define (log-rotations->/etc-entries rotations)
 120   "Return the list of /etc entries for ROTATIONS, a list of <log-rotation>."
 121   (define (frequency-file frequency rotations)
 122     (computed-file (string-append "rottlog." (symbol->string frequency))
 123                    #~(call-with-output-file #$output
 124                        (lambda (port)
 125                          (for-each (lambda (str)
 126                                      (display str port))
 127                                    (list #$@(map log-rotation->config
 128                                                  rotations)))))))
 129
 130   (let* ((frequencies (delete-duplicates
 131                        (map log-rotation-frequency rotations)))
 132          (table       (fold (lambda (rotation table)
 133                               (vhash-consq (log-rotation-frequency rotation)
 134                                            rotation table))
 135                             vlist-null
 136                             rotations)))
 137     (map (lambda (frequency)
 138            `(,(symbol->string frequency)
 139              ,(frequency-file frequency
 140                               (vhash-foldq* cons '() frequency table))))
 141          frequencies)))
 142
 143 (define (default-jobs rottlog)
 144   (list #~(job '(next-hour '(0))                  ;midnight
 145                #$(file-append rottlog "/sbin/rottlog"))
 146         #~(job '(next-hour '(12))                 ;noon
 147                #$(file-append rottlog "/sbin/rottlog"))))
 148
 149 (define-record-type* <rottlog-configuration>
 150   rottlog-configuration make-rottlog-configuration
 151   rottlog-configuration?
 152   (rottlog            rottlog-rottlog             ;package
 153                       (default rottlog))
 154   (rc-file            rottlog-rc-file             ;file-like
 155                       (default (file-append rottlog "/etc/rc")))
 156   (rotations          rottlog-rotations           ;list of <log-rotation>
 157                       (default %default-rotations))
 158   (jobs               rottlog-jobs                ;list of <mcron-job>
 159                       (default #f)))
 160
 161 (define (rottlog-etc config)
 162   `(("rottlog"
 163      ,(file-union "rottlog"
 164                   (cons `("rc" ,(rottlog-rc-file config))
 165                         (log-rotations->/etc-entries
 166                          (rottlog-rotations config)))))))
 167
 168 (define (rottlog-jobs-or-default config)
 169   (or (rottlog-jobs config)
 170       (default-jobs (rottlog-rottlog config))))
 171
 172 (define rottlog-service-type
 173   (service-type
 174    (name 'rottlog)
 175    (description
 176     "Periodically rotate log files using GNU@tie{}Rottlog and GNU@tie{}mcron.
 177 Old log files are removed or compressed according to the configuration.")
 178    (extensions (list (service-extension etc-service-type rottlog-etc)
 179                      (service-extension mcron-service-type
 180                                         rottlog-jobs-or-default)
 181
 182                      ;; Add Rottlog to the global profile so users can access
 183                      ;; the documentation.
 184                      (service-extension profile-service-type
 185                                         (compose list rottlog-rottlog))))
 186    (compose concatenate)
 187    (extend (lambda (config rotations)
 188              (rottlog-configuration
 189               (inherit config)
 190               (rotations (append (rottlog-rotations config)
 191                                  rotations)))))
 192    (default-value (rottlog-configuration))))
 193
 194 \f
 195 ;;;
 196 ;;; Unattended upgrade.
 197 ;;;
 198
 199 (define-record-type* <unattended-upgrade-configuration>
 200   unattended-upgrade-configuration make-unattended-upgrade-configuration
 201   unattended-upgrade-configuration?
 202   (operating-system-file unattended-upgrade-operating-system-file
 203                          (default "/run/current-system/configuration.scm"))
 204   (schedule             unattended-upgrade-configuration-schedule
 205                         (default "30 01 * * 0"))
 206   (channels             unattended-upgrade-configuration-channels
 207                         (default #~%default-channels))
 208   (services-to-restart  unattended-upgrade-configuration-services-to-restart
 209                         (default '(mcron)))
 210   (system-expiration    unattended-upgrade-system-expiration
 211                         (default (* 3 30 24 3600)))
 212   (maximum-duration     unattended-upgrade-maximum-duration
 213                         (default 3600))
 214   (log-file             unattended-upgrade-configuration-log-file
 215                         (default %unattended-upgrade-log-file)))
 216
 217 (define %unattended-upgrade-log-file
 218   "/var/log/unattended-upgrade.log")
 219
 220 (define (unattended-upgrade-mcron-jobs config)
 221   (define channels
 222     (scheme-file "channels.scm"
 223                  (unattended-upgrade-configuration-channels config)))
 224
 225   (define log
 226     (unattended-upgrade-configuration-log-file config))
 227
 228   (define services
 229     (unattended-upgrade-configuration-services-to-restart config))
 230
 231   (define expiration
 232     (unattended-upgrade-system-expiration config))
 233
 234   (define config-file
 235     (unattended-upgrade-operating-system-file config))
 236
 237   (define code
 238     (with-imported-modules (source-module-closure '((guix build utils)
 239                                                     (gnu services herd)))
 240       #~(begin
 241           (use-modules (guix build utils)
 242                        (gnu services herd)
 243                        (srfi srfi-19)
 244                        (srfi srfi-34))
 245
 246           (define log
 247             (open-file #$log "a0"))
 248
 249           (define (timestamp)
 250             (date->string (time-utc->date (current-time time-utc))
 251                           "[~4]"))
 252
 253           (define (alarm-handler . _)
 254             (format #t "~a time is up, aborting upgrade~%"
 255                     (timestamp))
 256             (exit 1))
 257
 258           ;; 'guix time-machine' needs X.509 certificates to authenticate the
 259           ;; Git host.
 260           (setenv "SSL_CERT_DIR"
 261                   #$(file-append nss-certs "/etc/ssl/certs"))
 262
 263           ;; Make sure the upgrade doesn't take too long.
 264           (sigaction SIGALRM alarm-handler)
 265           (alarm #$(unattended-upgrade-maximum-duration config))
 266
 267           ;; Redirect stdout/stderr to LOG to save the output of 'guix' below.
 268           (redirect-port log (current-output-port))
 269           (redirect-port log (current-error-port))
 270
 271           (format #t "~a starting upgrade...~%" (timestamp))
 272           (guard (c ((invoke-error? c)
 273                      (report-invoke-error c)))
 274             (invoke #$(file-append guix "/bin/guix")
 275                     "time-machine" "-C" #$channels
 276                     "--" "system" "reconfigure" #$config-file)
 277
 278             ;; 'guix system delete-generations' fails when there's no
 279             ;; matching generation.  Thus, catch 'invoke-error?'.
 280             (guard (c ((invoke-error? c)
 281                        (report-invoke-error c)))
 282               (invoke #$(file-append guix "/bin/guix")
 283                       "system" "delete-generations"
 284                       #$(string-append (number->string expiration)
 285                                        "s")))
 286
 287             (format #t "~a restarting services...~%" (timestamp))
 288             (for-each restart-service '#$services)
 289
 290             ;; XXX: If 'mcron' has been restarted, perhaps this isn't
 291             ;; reached.
 292             (format #t "~a upgrade complete~%" (timestamp))))))
 293
 294   (define upgrade
 295     (program-file "unattended-upgrade" code))
 296
 297   (list #~(job #$(unattended-upgrade-configuration-schedule config)
 298                #$upgrade)))
 299
 300 (define (unattended-upgrade-log-rotations config)
 301   (list (log-rotation
 302          (files
 303           (list (unattended-upgrade-configuration-log-file config))))))
 304
 305 (define unattended-upgrade-service-type
 306   (service-type
 307    (name 'unattended-upgrade)
 308    (extensions
 309     (list (service-extension mcron-service-type
 310                              unattended-upgrade-mcron-jobs)
 311           (service-extension rottlog-service-type
 312                              unattended-upgrade-log-rotations)))
 313    (description
 314     "Periodically upgrade the system from the current configuration.")
 315    (default-value (unattended-upgrade-configuration))))
 316
 317 ;;; admin.scm ends here