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 packages logging)
  24   #:use-module (gnu services)
  25   #:use-module (gnu services mcron)
  26   #:use-module (gnu services shepherd)
  27   #:use-module (gnu services web)
  28   #:use-module (gnu system shadow)
  29   #:use-module (guix gexp)
  30   #:use-module (guix store)
  31   #:use-module (guix packages)
  32   #:use-module (guix records)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (ice-9 vlist)
  35   #:use-module (ice-9 match)
  36   #:export (%default-rotations
  37             %rotated-files
  38
  39             log-rotation
  40             log-rotation?
  41             log-rotation-frequency
  42             log-rotation-files
  43             log-rotation-options
  44             log-rotation-post-rotate
  45
  46             rottlog-configuration
  47             rottlog-configuration?
  48             rottlog-service
  49             rottlog-service-type
  50
  51             <tailon-configuration-file>
  52             tailon-configuration-file
  53             tailon-configuration-file?
  54             tailon-configuration-file-files
  55             tailon-configuration-file-bind
  56             tailon-configuration-file-relative-root
  57             tailon-configuration-file-allow-transfers?
  58             tailon-configuration-file-follow-names?
  59             tailon-configuration-file-tail-lines
  60             tailon-configuration-file-allowed-commands
  61             tailon-configuration-file-debug?
  62
  63             <tailon-configuration>
  64             tailon-configuration
  65             tailon-configuration?
  66             tailon-configuration-config-file
  67             tailon-configuration-package
  68
  69             tailon-service-type))
  70
  71 ;;; Commentary:
  72 ;;;
  73 ;;; This module implements configuration of rottlog by writing
  74 ;;; /etc/rottlog/{rc,hourly|daily|weekly}.  Example usage
  75 ;;;
  76 ;;;     (mcron-service)
  77 ;;;     (service rottlog-service-type)
  78 ;;;
  79 ;;; Code:
  80
  81 (define-record-type* <log-rotation> log-rotation make-log-rotation
  82   log-rotation?
  83   (files       log-rotation-files)                ;list of strings
  84   (frequency   log-rotation-frequency             ;symbol
  85                (default 'weekly))
  86   (post-rotate log-rotation-post-rotate           ;#f | gexp
  87                (default #f))
  88   (options     log-rotation-options               ;list of strings
  89                (default '())))
  90
  91 (define %rotated-files
  92   ;; Syslog files subject to rotation.
  93   '("/var/log/messages" "/var/log/secure" "/var/log/maillog"))
  94
  95 (define %default-rotations
  96   (list (log-rotation                             ;syslog files
  97          (files %rotated-files)
  98
  99          ;; Restart syslogd after rotation.
 100          (options '("sharedscripts"))
 101          (post-rotate #~(let ((pid (call-with-input-file "/var/run/syslog.pid"
 102                                      read)))
 103                           (kill pid SIGHUP))))
 104         (log-rotation
 105          (files '("/var/log/shepherd.log" "/var/log/guix-daemon.log")))))
 106
 107 (define (log-rotation->config rotation)
 108   "Return a string-valued gexp representing the rottlog configuration snippet
 109 for ROTATION."
 110   (define post-rotate
 111     (let ((post (log-rotation-post-rotate rotation)))
 112       (and post
 113            (program-file "rottlog-post-rotate.scm" post))))
 114
 115   #~(let ((post #$post-rotate))
 116       (string-append (string-join '#$(log-rotation-files rotation) ",")
 117                      " {"
 118                      #$(string-join (log-rotation-options rotation)
 119                                     "\n  " 'prefix)
 120                      (if post
 121                          (string-append "\n  postrotate\n    " post
 122                                         "\n  endscript\n")
 123                          "")
 124                      "\n}\n")))
 125
 126 (define (log-rotations->/etc-entries rotations)
 127   "Return the list of /etc entries for ROTATIONS, a list of <log-rotation>."
 128   (define (frequency-file frequency rotations)
 129     (computed-file (string-append "rottlog." (symbol->string frequency))
 130                    #~(call-with-output-file #$output
 131                        (lambda (port)
 132                          (for-each (lambda (str)
 133                                      (display str port))
 134                                    (list #$@(map log-rotation->config
 135                                                  rotations)))))))
 136
 137   (let* ((frequencies (delete-duplicates
 138                        (map log-rotation-frequency rotations)))
 139          (table       (fold (lambda (rotation table)
 140                               (vhash-consq (log-rotation-frequency rotation)
 141                                            rotation table))
 142                             vlist-null
 143                             rotations)))
 144     (map (lambda (frequency)
 145            `(,(symbol->string frequency)
 146              ,(frequency-file frequency
 147                               (vhash-foldq* cons '() frequency table))))
 148          frequencies)))
 149
 150 (define (default-jobs rottlog)
 151   (list #~(job '(next-hour '(0))                  ;midnight
 152                (lambda ()
 153                  (system* #$(file-append rottlog "/sbin/rottlog"))))
 154         #~(job '(next-hour '(12))                 ;noon
 155                (lambda ()
 156                  (system* #$(file-append rottlog "/sbin/rottlog"))))))
 157
 158 (define-record-type* <rottlog-configuration>
 159   rottlog-configuration make-rottlog-configuration
 160   rottlog-configuration?
 161   (rottlog            rottlog-rottlog             ;package
 162                       (default rottlog))
 163   (rc-file            rottlog-rc-file             ;file-like
 164                       (default (file-append rottlog "/etc/rc")))
 165   (rotations          rottlog-rotations           ;list of <log-rotation>
 166                       (default %default-rotations))
 167   (jobs               rottlog-jobs                ;list of <mcron-job>
 168                       (default #f)))
 169
 170 (define (rottlog-etc config)
 171   `(("rottlog"
 172      ,(file-union "rottlog"
 173                   (cons `("rc" ,(rottlog-rc-file config))
 174                         (log-rotations->/etc-entries
 175                          (rottlog-rotations config)))))))
 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)
 184    (extensions (list (service-extension etc-service-type rottlog-etc)
 185                      (service-extension mcron-service-type
 186                                         rottlog-jobs-or-default)
 187
 188                      ;; Add Rottlog to the global profile so users can access
 189                      ;; the documentation.
 190                      (service-extension profile-service-type
 191                                         (compose list rottlog-rottlog))))
 192    (compose concatenate)
 193    (extend (lambda (config rotations)
 194              (rottlog-configuration
 195               (inherit config)
 196               (rotations (append (rottlog-rotations config)
 197                                  rotations)))))
 198    (default-value (rottlog-configuration))))
 199
 200 \f
 201 ;;;
 202 ;;; Tailon
 203 ;;;
 204
 205 (define-record-type* <tailon-configuration-file>
 206   tailon-configuration-file make-tailon-configuration-file
 207   tailon-configuration-file?
 208   (files                   tailon-configuration-file-files
 209                            (default '("/var/log")))
 210   (bind                    tailon-configuration-file-bind
 211                            (default "localhost:8080"))
 212   (relative-root           tailon-configuration-file-relative-root
 213                            (default #f))
 214   (allow-transfers?        tailon-configuration-file-allow-transfers?
 215                            (default #t))
 216   (follow-names?           tailon-configuration-file-follow-names?
 217                            (default #t))
 218   (tail-lines              tailon-configuration-file-tail-lines
 219                            (default 200))
 220   (allowed-commands        tailon-configuration-file-allowed-commands
 221                            (default '("tail" "grep" "awk")))
 222   (debug?                  tailon-configuration-file-debug?
 223                            (default #f)))
 224
 225 (define (tailon-configuration-files-string files)
 226   (string-append
 227    "\n"
 228    (string-join
 229     (map
 230      (lambda (x)
 231        (string-append
 232         "  - "
 233         (cond
 234          ((string? x)
 235           (simple-format #f "'~A'" x))
 236          ((list? x)
 237           (string-join
 238            (cons (simple-format #f "'~A':" (car x))
 239                  (map
 240                   (lambda (x) (simple-format #f "      - '~A'" x))
 241                   (cdr x)))
 242            "\n"))
 243          (else (error x)))))
 244      files)
 245     "\n")))
 246
 247 (define-gexp-compiler (tailon-configuration-file-compiler
 248                        (file <tailon-configuration-file>) system target)
 249   (match file
 250     (($ <tailon-configuration-file> files bind relative-root
 251                                     allow-transfers? follow-names?
 252                                     tail-lines allowed-commands debug?)
 253      (text-file
 254       "tailon-config.yaml"
 255       (string-concatenate
 256        (filter-map
 257         (match-lambda
 258          ((key . #f) #f)
 259          ((key . value) (string-append key ": " value "\n")))
 260
 261         `(("files" . ,(tailon-configuration-files-string files))
 262           ("bind" . ,bind)
 263           ("relative-root" . ,relative-root)
 264           ("allow-transfers" . ,(if allow-transfers? "true" "false"))
 265           ("follow-names" . ,(if follow-names? "true" "false"))
 266           ("tail-lines" . ,(number->string tail-lines))
 267           ("commands" . ,(string-append "["
 268                                         (string-join allowed-commands ", ")
 269                                         "]"))
 270           ,@(if debug? '(("debug" . "true")) '()))))))))
 271
 272 (define-record-type* <tailon-configuration>
 273   tailon-configuration make-tailon-configuration
 274   tailon-configuration?
 275   (config-file tailon-configuration-config-file
 276                (default (tailon-configuration-file)))
 277   (package tailon-configuration-package
 278            (default tailon)))
 279
 280 (define tailon-shepherd-service
 281   (match-lambda
 282     (($ <tailon-configuration> config-file package)
 283      (list (shepherd-service
 284             (provision '(tailon))
 285             (documentation "Run the tailon daemon.")
 286             (start #~(make-forkexec-constructor
 287                       `(,(string-append #$package "/bin/tailon")
 288                         "-c" ,#$config-file)
 289                       #:user "tailon"
 290                       #:group "tailon"))
 291             (stop #~(make-kill-destructor)))))))
 292
 293 (define %tailon-accounts
 294   (list (user-group (name "tailon") (system? #t))
 295         (user-account
 296          (name "tailon")
 297          (group "tailon")
 298          (system? #t)
 299          (comment "tailon")
 300          (home-directory "/var/empty")
 301          (shell (file-append shadow "/sbin/nologin")))))
 302
 303 (define tailon-service-type
 304   (service-type
 305    (name 'tailon)
 306    (extensions
 307     (list (service-extension shepherd-root-service-type
 308                              tailon-shepherd-service)
 309           (service-extension account-service-type
 310                              (const %tailon-accounts))))
 311    (compose concatenate)
 312    (extend (lambda (parameter files)
 313              (tailon-configuration
 314               (inherit parameter)
 315               (config-file
 316                (let ((old-config-file
 317                       (tailon-configuration-config-file parameter)))
 318                  (tailon-configuration-file
 319                   (inherit old-config-file)
 320                   (files (append (tailon-configuration-file-files old-config-file)
 321                                  files))))))))
 322    (default-value (tailon-configuration))))
 323
 324 ;;; admin.scm ends here