gnu/services/admin.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   3 ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of thye GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu services admin)
  21   #:use-module (gnu packages admin)
  22   #:use-module (gnu packages base)
  23   #:use-module (gnu services)
  24   #:use-module (gnu services mcron)
  25   #:use-module (gnu services shepherd)
  26   #:use-module (guix gexp)
  27   #:use-module (guix packages)
  28   #:use-module (guix records)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (ice-9 vlist)
  31   #:export (%default-rotations
  32             %rotated-files
  33
  34             log-rotation
  35             log-rotation?
  36             log-rotation-frequency
  37             log-rotation-files
  38             log-rotation-options
  39             log-rotation-post-rotate
  40
  41             rottlog-configuration
  42             rottlog-configuration?
  43             rottlog-service
  44             rottlog-service-type))
  45
  46 ;;; Commentary:
  47 ;;;
  48 ;;; This module implements configuration of rottlog by writing
  49 ;;; /etc/rottlog/{rc,hourly|daily|weekly}.  Example usage
  50 ;;;
  51 ;;;     (mcron-service)
  52 ;;;     (service rottlog-service-type)
  53 ;;;
  54 ;;; Code:
  55
  56 (define-record-type* <log-rotation> log-rotation make-log-rotation
  57   log-rotation?
  58   (files       log-rotation-files)                ;list of strings
  59   (frequency   log-rotation-frequency             ;symbol
  60                (default 'weekly))
  61   (post-rotate log-rotation-post-rotate           ;#f | gexp
  62                (default #f))
  63   (options     log-rotation-options               ;list of strings
  64                (default '())))
  65
  66 (define %rotated-files
  67   ;; Syslog files subject to rotation.
  68   '("/var/log/messages" "/var/log/secure" "/var/log/maillog"))
  69
  70 (define %default-rotations
  71   (list (log-rotation                             ;syslog files
  72          (files %rotated-files)
  73
  74          ;; Restart syslogd after rotation.
  75          (options '("sharedscripts"))
  76          (post-rotate #~(let ((pid (call-with-input-file "/var/run/syslog.pid"
  77                                      read)))
  78                           (kill pid SIGHUP))))
  79         (log-rotation
  80          (files '("/var/log/shepherd.log" "/var/log/guix-daemon.log")))))
  81
  82 (define (log-rotation->config rotation)
  83   "Return a string-valued gexp representing the rottlog configuration snippet
  84 for ROTATION."
  85   (define post-rotate
  86     (let ((post (log-rotation-post-rotate rotation)))
  87       (and post
  88            (program-file "rottlog-post-rotate.scm" post))))
  89
  90   #~(let ((post #$post-rotate))
  91       (string-append (string-join '#$(log-rotation-files rotation) ",")
  92                      " {"
  93                      #$(string-join (log-rotation-options rotation)
  94                                     "\n  " 'prefix)
  95                      (if post
  96                          (string-append "\n  postrotate\n    " post
  97                                         "\n  endscript\n")
  98                          "")
  99                      "\n}\n")))
 100
 101 (define (log-rotations->/etc-entries rotations)
 102   "Return the list of /etc entries for ROTATIONS, a list of <log-rotation>."
 103   (define (frequency-file frequency rotations)
 104     (computed-file (string-append "rottlog." (symbol->string frequency))
 105                    #~(call-with-output-file #$output
 106                        (lambda (port)
 107                          (for-each (lambda (str)
 108                                      (display str port))
 109                                    (list #$@(map log-rotation->config
 110                                                  rotations)))))))
 111
 112   (let* ((frequencies (delete-duplicates
 113                        (map log-rotation-frequency rotations)))
 114          (table       (fold (lambda (rotation table)
 115                               (vhash-consq (log-rotation-frequency rotation)
 116                                            rotation table))
 117                             vlist-null
 118                             rotations)))
 119     (map (lambda (frequency)
 120            `(,(symbol->string frequency)
 121              ,(frequency-file frequency
 122                               (vhash-foldq* cons '() frequency table))))
 123          frequencies)))
 124
 125 (define (default-jobs rottlog)
 126   (list #~(job '(next-hour '(0))                  ;midnight
 127                (lambda ()
 128                  (system* #$(file-append rottlog "/sbin/rottlog"))))
 129         #~(job '(next-hour '(12))                 ;noon
 130                (lambda ()
 131                  (system* #$(file-append rottlog "/sbin/rottlog"))))))
 132
 133 (define-record-type* <rottlog-configuration>
 134   rottlog-configuration make-rottlog-configuration
 135   rottlog-configuration?
 136   (rottlog            rottlog-rottlog             ;package
 137                       (default rottlog))
 138   (rc-file            rottlog-rc-file             ;file-like
 139                       (default (file-append rottlog "/etc/rc")))
 140   (rotations          rottlog-rotations           ;list of <log-rotation>
 141                       (default %default-rotations))
 142   (jobs               rottlog-jobs                ;list of <mcron-job>
 143                       (default #f)))
 144
 145 (define (rottlog-etc config)
 146   `(("rottlog"
 147      ,(file-union "rottlog"
 148                   (cons `("rc" ,(rottlog-rc-file config))
 149                         (log-rotations->/etc-entries
 150                          (rottlog-rotations config)))))))
 151
 152 (define (rottlog-jobs-or-default config)
 153   (or (rottlog-jobs config)
 154       (default-jobs (rottlog-rottlog config))))
 155
 156 (define rottlog-service-type
 157   (service-type
 158    (name 'rottlog)
 159    (extensions (list (service-extension etc-service-type rottlog-etc)
 160                      (service-extension mcron-service-type
 161                                         rottlog-jobs-or-default)
 162
 163                      ;; Add Rottlog to the global profile so users can access
 164                      ;; the documentation.
 165                      (service-extension profile-service-type
 166                                         (compose list rottlog-rottlog))))
 167    (compose concatenate)
 168    (extend (lambda (config rotations)
 169              (rottlog-configuration
 170               (inherit config)
 171               (rotations (append (rottlog-rotations config)
 172                                  rotations)))))
 173    (default-value (rottlog-configuration))))
 174
 175 ;;; admin.scm ends here