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             tailon-configuration-file-http-auth
  63             tailon-configuration-file-users
  64
  65             <tailon-configuration>
  66             tailon-configuration
  67             tailon-configuration?
  68             tailon-configuration-config-file
  69             tailon-configuration-package
  70
  71             tailon-service-type))
  72
  73 ;;; Commentary:
  74 ;;;
  75 ;;; This module implements configuration of rottlog by writing
  76 ;;; /etc/rottlog/{rc,hourly|daily|weekly}.  Example usage
  77 ;;;
  78 ;;;     (mcron-service)
  79 ;;;     (service rottlog-service-type)
  80 ;;;
  81 ;;; Code:
  82
  83 (define-record-type* <log-rotation> log-rotation make-log-rotation
  84   log-rotation?
  85   (files       log-rotation-files)                ;list of strings
  86   (frequency   log-rotation-frequency             ;symbol
  87                (default 'weekly))
  88   (post-rotate log-rotation-post-rotate           ;#f | gexp
  89                (default #f))
  90   (options     log-rotation-options               ;list of strings
  91                (default '())))
  92
  93 (define %rotated-files
  94   ;; Syslog files subject to rotation.
  95   '("/var/log/messages" "/var/log/secure" "/var/log/maillog"))
  96
  97 (define %default-rotations
  98   (list (log-rotation                             ;syslog files
  99          (files %rotated-files)
 100
 101          ;; Restart syslogd after rotation.
 102          (options '("sharedscripts"))
 103          (post-rotate #~(let ((pid (call-with-input-file "/var/run/syslog.pid"
 104                                      read)))
 105                           (kill pid SIGHUP))))
 106         (log-rotation
 107          (files '("/var/log/shepherd.log" "/var/log/guix-daemon.log")))))
 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)))
 151
 152 (define (default-jobs rottlog)
 153   (list #~(job '(next-hour '(0))                  ;midnight
 154                (lambda ()
 155                  (system* #$(file-append rottlog "/sbin/rottlog"))))
 156         #~(job '(next-hour '(12))                 ;noon
 157                (lambda ()
 158                  (system* #$(file-append rottlog "/sbin/rottlog"))))))
 159
 160 (define-record-type* <rottlog-configuration>
 161   rottlog-configuration make-rottlog-configuration
 162   rottlog-configuration?
 163   (rottlog            rottlog-rottlog             ;package
 164                       (default rottlog))
 165   (rc-file            rottlog-rc-file             ;file-like
 166                       (default (file-append rottlog "/etc/rc")))
 167   (rotations          rottlog-rotations           ;list of <log-rotation>
 168                       (default %default-rotations))
 169   (jobs               rottlog-jobs                ;list of <mcron-job>
 170                       (default #f)))
 171
 172 (define (rottlog-etc config)
 173   `(("rottlog"
 174      ,(file-union "rottlog"
 175                   (cons `("rc" ,(rottlog-rc-file config))
 176                         (log-rotations->/etc-entries
 177                          (rottlog-rotations config)))))))
 178
 179 (define (rottlog-jobs-or-default config)
 180   (or (rottlog-jobs config)
 181       (default-jobs (rottlog-rottlog config))))
 182
 183 (define rottlog-service-type
 184   (service-type
 185    (name 'rottlog)
 186    (extensions (list (service-extension etc-service-type rottlog-etc)
 187                      (service-extension mcron-service-type
 188                                         rottlog-jobs-or-default)
 189
 190                      ;; Add Rottlog to the global profile so users can access
 191                      ;; the documentation.
 192                      (service-extension profile-service-type
 193                                         (compose list rottlog-rottlog))))
 194    (compose concatenate)
 195    (extend (lambda (config rotations)
 196              (rottlog-configuration
 197               (inherit config)
 198               (rotations (append (rottlog-rotations config)
 199                                  rotations)))))
 200    (default-value (rottlog-configuration))))
 201
 202 \f
 203 ;;;
 204 ;;; Tailon
 205 ;;;
 206
 207 (define-record-type* <tailon-configuration-file>
 208   tailon-configuration-file make-tailon-configuration-file
 209   tailon-configuration-file?
 210   (files                   tailon-configuration-file-files
 211                            (default '("/var/log")))
 212   (bind                    tailon-configuration-file-bind
 213                            (default "localhost:8080"))
 214   (relative-root           tailon-configuration-file-relative-root
 215                            (default #f))
 216   (allow-transfers?        tailon-configuration-file-allow-transfers?
 217                            (default #t))
 218   (follow-names?           tailon-configuration-file-follow-names?
 219                            (default #t))
 220   (tail-lines              tailon-configuration-file-tail-lines
 221                            (default 200))
 222   (allowed-commands        tailon-configuration-file-allowed-commands
 223                            (default '("tail" "grep" "awk")))
 224   (debug?                  tailon-configuration-file-debug?
 225                            (default #f))
 226   (wrap-lines              tailon-configuration-file-wrap-lines
 227                            (default #t))
 228   (http-auth               tailon-configuration-file-http-auth
 229                            (default #f))
 230   (users                   tailon-configuration-file-users
 231                            (default #f)))
 232
 233 (define (tailon-configuration-files-string files)
 234   (string-append
 235    "\n"
 236    (string-join
 237     (map
 238      (lambda (x)
 239        (string-append
 240         "  - "
 241         (cond
 242          ((string? x)
 243           (simple-format #f "'~A'" x))
 244          ((list? x)
 245           (string-join
 246            (cons (simple-format #f "'~A':" (car x))
 247                  (map
 248                   (lambda (x) (simple-format #f "      - '~A'" x))
 249                   (cdr x)))
 250            "\n"))
 251          (else (error x)))))
 252      files)
 253     "\n")))
 254
 255 (define-gexp-compiler (tailon-configuration-file-compiler
 256                        (file <tailon-configuration-file>) system target)
 257   (match file
 258     (($ <tailon-configuration-file> files bind relative-root
 259                                     allow-transfers? follow-names?
 260                                     tail-lines allowed-commands debug?
 261                                     wrap-lines http-auth users)
 262      (text-file
 263       "tailon-config.yaml"
 264       (string-concatenate
 265        (filter-map
 266         (match-lambda
 267          ((key . #f) #f)
 268          ((key . value) (string-append key ": " value "\n")))
 269
 270         `(("files" . ,(tailon-configuration-files-string files))
 271           ("bind" . ,bind)
 272           ("relative-root" . ,relative-root)
 273           ("allow-transfers" . ,(if allow-transfers? "true" "false"))
 274           ("follow-names" . ,(if follow-names? "true" "false"))
 275           ("tail-lines" . ,(number->string tail-lines))
 276           ("commands" . ,(string-append "["
 277                                         (string-join allowed-commands ", ")
 278                                         "]"))
 279           ("debug" . ,(if debug? "true" #f))
 280           ("wrap-lines" . ,(if wrap-lines "true" "false"))
 281           ("http-auth" . ,http-auth)
 282           ("users" . ,(if users
 283                           (string-concatenate
 284                            (cons "\n"
 285                                  (map (match-lambda
 286                                        ((user . pass)
 287                                         (string-append
 288                                          "  " user ":" pass)))
 289                                       users)))
 290                           #f)))))))))
 291
 292 (define-record-type* <tailon-configuration>
 293   tailon-configuration make-tailon-configuration
 294   tailon-configuration?
 295   (config-file tailon-configuration-config-file
 296                (default (tailon-configuration-file)))
 297   (package tailon-configuration-package
 298            (default tailon)))
 299
 300 (define tailon-shepherd-service
 301   (match-lambda
 302     (($ <tailon-configuration> config-file package)
 303      (list (shepherd-service
 304             (provision '(tailon))
 305             (documentation "Run the tailon daemon.")
 306             (start #~(make-forkexec-constructor
 307                       `(,(string-append #$package "/bin/tailon")
 308                         "-c" ,#$config-file)
 309                       #:user "tailon"
 310                       #:group "tailon"))
 311             (stop #~(make-kill-destructor)))))))
 312
 313 (define %tailon-accounts
 314   (list (user-group (name "tailon") (system? #t))
 315         (user-account
 316          (name "tailon")
 317          (group "tailon")
 318          (system? #t)
 319          (comment "tailon")
 320          (home-directory "/var/empty")
 321          (shell (file-append shadow "/sbin/nologin")))))
 322
 323 (define tailon-service-type
 324   (service-type
 325    (name 'tailon)
 326    (extensions
 327     (list (service-extension shepherd-root-service-type
 328                              tailon-shepherd-service)
 329           (service-extension account-service-type
 330                              (const %tailon-accounts))))
 331    (compose concatenate)
 332    (extend (lambda (parameter files)
 333              (tailon-configuration
 334               (inherit parameter)
 335               (config-file
 336                (let ((old-config-file
 337                       (tailon-configuration-config-file parameter)))
 338                  (tailon-configuration-file
 339                   (inherit old-config-file)
 340                   (files (append (tailon-configuration-file-files old-config-file)
 341                                  files))))))))
 342    (default-value (tailon-configuration))))
 343
 344 ;;; admin.scm ends here