gnu/services/cups.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Andy Wingo <wingo@pobox.com>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu services cups)
  20   #:use-module (gnu services)
  21   #:use-module (gnu services shepherd)
  22   #:use-module (gnu system shadow)
  23   #:use-module (gnu packages admin)
  24   #:use-module (gnu packages cups)
  25   #:use-module (gnu packages tls)
  26   #:use-module (guix packages)
  27   #:use-module (guix records)
  28   #:use-module (guix gexp)
  29   #:use-module (texinfo)
  30   #:use-module (texinfo serialize)
  31   #:use-module (ice-9 match)
  32   #:use-module ((srfi srfi-1) #:select (append-map))
  33   #:use-module (srfi srfi-34)
  34   #:use-module (srfi srfi-35)
  35   #:export (&cups-configuation-error
  36             cups-configuration-error?
  37
  38             cups-service-type
  39             cups-configuration
  40             opaque-cups-configuration
  41
  42             files-configuration
  43             policy-configuration
  44             location-access-control
  45             operation-access-control
  46             method-access-control))
  47
  48 ;;; Commentary:
  49 ;;;
  50 ;;; Service defininition for the CUPS printing system.
  51 ;;;
  52 ;;; Code:
  53
  54 (define-condition-type &cups-configuration-error &error
  55   cups-configuration-error?)
  56
  57 (define (cups-error message)
  58   (raise (condition (&message (message message))
  59                     (&cups-configuration-error))))
  60 (define (cups-configuration-field-error field val)
  61   (cups-error
  62    (format #f "Invalid value for field ~a: ~s" field val)))
  63 (define (cups-configuration-missing-field kind field)
  64   (cups-error
  65    (format #f "~a configuration missing required field ~a" kind field)))
  66
  67 (define-record-type* <configuration-field>
  68   configuration-field make-configuration-field configuration-field?
  69   (name configuration-field-name)
  70   (type configuration-field-type)
  71   (getter configuration-field-getter)
  72   (predicate configuration-field-predicate)
  73   (serializer configuration-field-serializer)
  74   (default-value-thunk configuration-field-default-value-thunk)
  75   (documentation configuration-field-documentation))
  76
  77 (define (serialize-configuration config fields)
  78   (for-each (lambda (field)
  79               ((configuration-field-serializer field)
  80                (configuration-field-name field)
  81                ((configuration-field-getter field) config)))
  82             fields))
  83
  84 (define (validate-configuration config fields)
  85   (for-each (lambda (field)
  86               (let ((val ((configuration-field-getter field) config)))
  87                 (unless ((configuration-field-predicate field) val)
  88                   (cups-configuration-field-error
  89                    (configuration-field-name field) val))))
  90             fields))
  91
  92 (define-syntax define-configuration
  93   (lambda (stx)
  94     (define (id ctx part . parts)
  95       (let ((part (syntax->datum part)))
  96         (datum->syntax
  97          ctx
  98          (match parts
  99            (() part)
 100            (parts (symbol-append part
 101                                  (syntax->datum (apply id ctx parts))))))))
 102     (syntax-case stx ()
 103       ((_ stem (field (field-type def) doc) ...)
 104        (with-syntax (((field-getter ...)
 105                       (map (lambda (field)
 106                              (id #'stem #'stem #'- field))
 107                            #'(field ...)))
 108                      ((field-predicate ...)
 109                       (map (lambda (type)
 110                              (id #'stem type #'?))
 111                            #'(field-type ...)))
 112                      ((field-serializer ...)
 113                       (map (lambda (type)
 114                              (id #'stem #'serialize- type))
 115                            #'(field-type ...))))
 116            #`(begin
 117                (define-record-type* #,(id #'stem #'< #'stem #'>)
 118                  #,(id #'stem #'% #'stem)
 119                  #,(id #'stem #'make- #'stem)
 120                  #,(id #'stem #'stem #'?)
 121                  (field field-getter (default def))
 122                  ...)
 123                (define #,(id #'stem #'stem #'-fields)
 124                  (list (configuration-field
 125                         (name 'field)
 126                         (type 'field-type)
 127                         (getter field-getter)
 128                         (predicate field-predicate)
 129                         (serializer field-serializer)
 130                         (default-value-thunk (lambda () def))
 131                         (documentation doc))
 132                        ...))
 133                (define-syntax-rule (stem arg (... ...))
 134                  (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
 135                    (validate-configuration conf
 136                                            #,(id #'stem #'stem #'-fields))
 137                    conf))))))))
 138
 139 (define %cups-accounts
 140   (list (user-group (name "lp") (system? #t))
 141         (user-group (name "lpadmin") (system? #t))
 142         (user-account
 143          (name "lp")
 144          (group "lp")
 145          (system? #t)
 146          (comment "System user for invoking printing helper programs")
 147          (home-directory "/var/empty")
 148          (shell (file-append shadow "/sbin/nologin")))))
 149
 150 (define (uglify-field-name field-name)
 151   (let ((str (symbol->string field-name)))
 152     (string-concatenate
 153      (map string-titlecase
 154           (string-split (if (string-suffix? "?" str)
 155                             (substring str 0 (1- (string-length str)))
 156                             str)
 157                         #\-)))))
 158
 159 (define (serialize-field field-name val)
 160   (format #t "~a ~a\n" (uglify-field-name field-name) val))
 161
 162 (define (serialize-package field-name val)
 163   #f)
 164
 165 (define (serialize-string field-name val)
 166   (serialize-field field-name val))
 167
 168 (define (multiline-string-list? val)
 169   (and (list? val)
 170        (and-map (lambda (x)
 171                   (and (string? x) (not (string-index x #\space))))
 172                 val)))
 173 (define (serialize-multiline-string-list field-name val)
 174   (for-each (lambda (str) (serialize-field field-name str)) val))
 175
 176 (define (space-separated-string-list? val)
 177   (and (list? val)
 178        (and-map (lambda (x)
 179                   (and (string? x) (not (string-index x #\space))))
 180                 val)))
 181 (define (serialize-space-separated-string-list field-name val)
 182   (serialize-field field-name (string-join val " ")))
 183
 184 (define (space-separated-symbol-list? val)
 185   (and (list? val) (and-map symbol? val)))
 186 (define (serialize-space-separated-symbol-list field-name val)
 187   (serialize-field field-name (string-join (map symbol->string val) " ")))
 188
 189 (define (file-name? val)
 190   (and (string? val)
 191        (string-prefix? "/" val)))
 192 (define (serialize-file-name field-name val)
 193   (serialize-string field-name val))
 194
 195 (define (serialize-boolean field-name val)
 196   (serialize-string field-name (if val "yes" "no")))
 197
 198 (define (non-negative-integer? val)
 199   (and (exact-integer? val) (not (negative? val))))
 200 (define (serialize-non-negative-integer field-name val)
 201   (serialize-field field-name val))
 202
 203 (define-syntax define-enumerated-field-type
 204   (lambda (x)
 205     (define (id-append ctx . parts)
 206       (datum->syntax ctx (apply symbol-append (map syntax->datum parts))))
 207     (syntax-case x ()
 208       ((_ name (option ...))
 209        #`(begin
 210            (define (#,(id-append #'name #'name #'?) x)
 211              (memq x '(option ...)))
 212            (define (#,(id-append #'name #'serialize- #'name) field-name val)
 213              (serialize-field field-name val)))))))
 214
 215 (define-enumerated-field-type access-log-level
 216   (config actions all))
 217 (define-enumerated-field-type browse-local-protocols
 218   (all dnssd none))
 219 (define-enumerated-field-type default-auth-type
 220   (Basic Negotiate))
 221 (define-enumerated-field-type default-encryption
 222   (Never IfRequested Required))
 223 (define-enumerated-field-type error-policy
 224   (abort-job retry-job retry-this-job stop-printer))
 225 (define-enumerated-field-type log-level
 226   (none emerg alert crit error warn notice info debug debug2))
 227 (define-enumerated-field-type log-time-format
 228   (standard usecs))
 229 (define-enumerated-field-type server-tokens
 230   (None ProductOnly Major Minor Minimal OS Full))
 231 (define-enumerated-field-type method
 232   (DELETE GET HEAD OPTIONS POST PUT TRACE))
 233 (define-enumerated-field-type sandboxing
 234   (relaxed strict))
 235
 236 (define (method-list? val)
 237   (and (list? val) (and-map method? val)))
 238 (define (serialize-method-list field-name val)
 239   (serialize-field field-name (string-join (map symbol->string val) " ")))
 240
 241 (define (host-name-lookups? val)
 242   (memq val '(#f #t 'double)))
 243 (define (serialize-host-name-lookups field-name val)
 244   (serialize-field field-name
 245                    (match val (#f "No") (#t "Yes") ('double "Double"))))
 246
 247 (define (host-name-list-or-*? x)
 248     (or (eq? x '*)
 249         (and (list? x) (and-map string? x))))
 250 (define (serialize-host-name-list-or-* field-name val)
 251   (serialize-field field-name (match val
 252                                 ('* '*)
 253                                 (names (string-join names " ")))))
 254
 255 (define (boolean-or-non-negative-integer? x)
 256   (or (boolean? x) (non-negative-integer? x)))
 257 (define (serialize-boolean-or-non-negative-integer field-name x)
 258   (if (boolean? x)
 259       (serialize-boolean field-name x)
 260       (serialize-non-negative-integer field-name x)))
 261
 262 (define (ssl-options? x)
 263   (and (list? x)
 264        (and-map (lambda (elt) (memq elt '(AllowRC4 AllowSSL3))) x)))
 265 (define (serialize-ssl-options field-name val)
 266   (serialize-field field-name
 267                    (match val
 268                      (() "None")
 269                      (opts (string-join (map symbol->string opts) " ")))))
 270
 271 (define (serialize-access-control x)
 272   (display x)
 273   (newline))
 274 (define (serialize-access-control-list field-name val)
 275   (for-each serialize-access-control val))
 276 (define (access-control-list? val)
 277   (and (list? val) (and-map string? val)))
 278
 279 (define-configuration operation-access-control
 280   (operations
 281    (space-separated-symbol-list '())
 282    "IPP operations to which this access control applies.")
 283   (access-controls
 284    (access-control-list '())
 285    "Access control directives, as a list of strings.  Each string should be one directive, such as \"Order allow,deny\"."))
 286
 287 (define-configuration method-access-control
 288   (reverse?
 289    (boolean #f)
 290    "If @code{#t}, apply access controls to all methods except the listed
 291 methods.  Otherwise apply to only the listed methods.")
 292   (methods
 293    (method-list '())
 294    "Methods to which this access control applies.")
 295   (access-controls
 296    (access-control-list '())
 297    "Access control directives, as a list of strings.  Each string should be one directive, such as \"Order allow,deny\"."))
 298
 299 (define (serialize-operation-access-control x)
 300   (format #t "<Limit ~a>\n"
 301           (string-join (map symbol->string
 302                             (operation-access-control-operations x)) " "))
 303   (serialize-configuration
 304    x
 305    (filter (lambda (field)
 306              (not (eq? (configuration-field-name field) 'operations)))
 307            operation-access-control-fields))
 308   (format #t "</Limit>\n"))
 309
 310 (define (serialize-method-access-control x)
 311   (let ((limit (if (method-access-control-reverse? x) "LimitExcept" "Limit")))
 312     (format #t "<~a ~a>\n" limit
 313             (string-join (map symbol->string
 314                               (method-access-control-methods x)) " "))
 315     (serialize-configuration
 316      x
 317      (filter (lambda (field)
 318                (case (configuration-field-name field)
 319                  ((reverse? methods) #f)
 320                  (else #t)))
 321              method-access-control-fields))
 322     (format #t "</~a>\n" limit)))
 323
 324 (define (operation-access-control-list? val)
 325   (and (list? val) (and-map operation-access-control? val)))
 326 (define (serialize-operation-access-control-list field-name val)
 327   (for-each serialize-operation-access-control val))
 328
 329 (define (method-access-control-list? val)
 330   (and (list? val) (and-map method-access-control? val)))
 331 (define (serialize-method-access-control-list field-name val)
 332   (for-each serialize-method-access-control val))
 333
 334 (define-configuration location-access-control
 335   (path
 336    (file-name (cups-configuration-missing-field 'location-access-control 'path))
 337    "Specifies the URI path to which the access control applies.")
 338   (access-controls
 339    (access-control-list '())
 340    "Access controls for all access to this path, in the same format as the
 341 @code{access-controls} of @code{operation-access-control}.")
 342   (method-access-controls
 343    (method-access-control-list '())
 344    "Access controls for method-specific access to this path."))
 345
 346 (define (serialize-location-access-control x)
 347   (format #t "<Location ~a>\n" (location-access-control-path x))
 348   (serialize-configuration
 349    x
 350    (filter (lambda (field)
 351              (not (eq? (configuration-field-name field) 'path)))
 352            location-access-control-fields))
 353   (format #t "</Location>\n"))
 354
 355 (define (location-access-control-list? val)
 356   (and (list? val) (and-map location-access-control? val)))
 357 (define (serialize-location-access-control-list field-name val)
 358   (for-each serialize-location-access-control val))
 359
 360 (define-configuration policy-configuration
 361   (name
 362    (string (cups-configuration-missing-field 'policy-configuration 'name))
 363    "Name of the policy.")
 364   (job-private-access
 365    (string "@OWNER @SYSTEM")
 366    "Specifies an access list for a job's private values.  @code{@@ACL} maps to
 367 the printer's requesting-user-name-allowed or requesting-user-name-denied
 368 values.  @code{@@OWNER} maps to the job's owner.  @code{@@SYSTEM} maps to the
 369 groups listed for the @code{system-group} field of the @code{files-config}
 370 configuration, which is reified into the @code{cups-files.conf(5)} file.
 371 Other possible elements of the access list include specific user names, and
 372 @code{@@@var{group}} to indicate members of a specific group.  The access list
 373 may also be simply @code{all} or @code{default}.")
 374   (job-private-values
 375    (string (string-join '("job-name" "job-originating-host-name"
 376                           "job-originating-user-name" "phone")))
 377    "Specifies the list of job values to make private, or @code{all},
 378 @code{default}, or @code{none}.")
 379
 380   (subscription-private-access
 381    (string "@OWNER @SYSTEM")
 382    "Specifies an access list for a subscription's private values.
 383 @code{@@ACL} maps to the printer's requesting-user-name-allowed or
 384 requesting-user-name-denied values.  @code{@@OWNER} maps to the job's owner.
 385 @code{@@SYSTEM} maps to the groups listed for the @code{system-group} field of
 386 the @code{files-config} configuration, which is reified into the
 387 @code{cups-files.conf(5)} file.  Other possible elements of the access list
 388 include specific user names, and @code{@@@var{group}} to indicate members of a
 389 specific group.  The access list may also be simply @code{all} or
 390 @code{default}.")
 391   (subscription-private-values
 392    (string (string-join '("notify-events" "notify-pull-method"
 393                           "notify-recipient-uri" "notify-subscriber-user-name"
 394                           "notify-user-data")
 395                         " "))
 396    "Specifies the list of job values to make private, or @code{all},
 397 @code{default}, or @code{none}.")
 398
 399   (access-controls
 400    (operation-access-control-list '())
 401    "Access control by IPP operation."))
 402
 403 (define (serialize-policy-configuration x)
 404   (format #t "<Policy ~a>\n" (policy-configuration-name x))
 405   (serialize-configuration
 406    x
 407    (filter (lambda (field)
 408              (not (eq? (configuration-field-name field) 'name)))
 409            policy-configuration-fields))
 410   (format #t "</Policy>\n"))
 411
 412 (define (policy-configuration-list? x)
 413   (and (list? x) (and-map policy-configuration? x)))
 414 (define (serialize-policy-configuration-list field-name x)
 415   (for-each serialize-policy-configuration x))
 416
 417 (define (log-location? x)
 418   (or (file-name? x)
 419       (eq? x 'stderr)
 420       (eq? x 'syslog)))
 421 (define (serialize-log-location field-name x)
 422   (if (string? x)
 423       (serialize-file-name field-name x)
 424       (serialize-field field-name x)))
 425
 426 (define-configuration files-configuration
 427   (access-log
 428    (log-location "/var/log/cups/access_log")
 429    "Defines the access log filename.  Specifying a blank filename disables
 430 access log generation.  The value @code{stderr} causes log entries to be sent
 431 to the standard error file when the scheduler is running in the foreground, or
 432 to the system log daemon when run in the background.  The value @code{syslog}
 433 causes log entries to be sent to the system log daemon.  The server name may
 434 be included in filenames using the string @code{%s}, as in
 435 @code{/var/log/cups/%s-access_log}.")
 436   (cache-dir
 437    (file-name "/var/cache/cups")
 438    "Where CUPS should cache data.")
 439   (config-file-perm
 440    (string "0640")
 441    "Specifies the permissions for all configuration files that the scheduler
 442 writes.
 443
 444 Note that the permissions for the printers.conf file are currently masked to
 445 only allow access from the scheduler user (typically root).  This is done
 446 because printer device URIs sometimes contain sensitive authentication
 447 information that should not be generally known on the system.  There is no way
 448 to disable this security feature.")
 449   ;; Not specifying data-dir and server-bin options as we handle these
 450   ;; manually.  For document-root, the CUPS package has that path
 451   ;; preconfigured.
 452   (error-log
 453    (log-location "/var/log/cups/error_log")
 454    "Defines the error log filename.  Specifying a blank filename disables
 455 access log generation.  The value @code{stderr} causes log entries to be sent
 456 to the standard error file when the scheduler is running in the foreground, or
 457 to the system log daemon when run in the background.  The value @code{syslog}
 458 causes log entries to be sent to the system log daemon.  The server name may
 459 be included in filenames using the string @code{%s}, as in
 460 @code{/var/log/cups/%s-error_log}.")
 461   (fatal-errors
 462    (string "all -browse")
 463    "Specifies which errors are fatal, causing the scheduler to exit.  The kind
 464 strings are:
 465 @table @code
 466 @item none
 467 No errors are fatal.
 468 @item all
 469 All of the errors below are fatal.
 470 @item browse
 471 Browsing initialization errors are fatal, for example failed connections to
 472 the DNS-SD daemon.
 473 @item config
 474 Configuration file syntax errors are fatal.
 475 @item listen
 476 Listen or Port errors are fatal, except for IPv6 failures on the loopback or
 477 @code{any} addresses.
 478 @item log
 479 Log file creation or write errors are fatal.
 480 @item permissions
 481 Bad startup file permissions are fatal, for example shared TLS certificate and
 482 key files with world-read permissions.
 483 @end table")
 484   (file-device?
 485    (boolean #f)
 486    "Specifies whether the file pseudo-device can be used for new printer
 487 queues.  The URI @url{file:///dev/null} is always allowed.")
 488   (group
 489    (string "lp")
 490    "Specifies the group name or ID that will be used when executing external
 491 programs.")
 492   (log-file-perm
 493    (string "0644")
 494    "Specifies the permissions for all log files that the scheduler writes.")
 495   (page-log
 496    (log-location "/var/log/cups/page_log")
 497    "Defines the page log filename.  Specifying a blank filename disables
 498 access log generation.  The value @code{stderr} causes log entries to be sent
 499 to the standard error file when the scheduler is running in the foreground, or
 500 to the system log daemon when run in the background.  The value @code{syslog}
 501 causes log entries to be sent to the system log daemon.  The server name may
 502 be included in filenames using the string @code{%s}, as in
 503 @code{/var/log/cups/%s-page_log}.")
 504   (remote-root
 505    (string "remroot")
 506    "Specifies the username that is associated with unauthenticated accesses by
 507 clients claiming to be the root user.  The default is @code{remroot}.")
 508   (request-root
 509    (file-name "/var/spool/cups")
 510    "Specifies the directory that contains print jobs and other HTTP request
 511 data.")
 512   (sandboxing
 513    (sandboxing 'strict)
 514    "Specifies the level of security sandboxing that is applied to print
 515 filters, backends, and other child processes of the scheduler; either
 516 @code{relaxed} or @code{strict}.  This directive is currently only
 517 used/supported on macOS.")
 518   (server-keychain
 519    (file-name "/etc/cups/ssl")
 520    "Specifies the location of TLS certificates and private keys.  CUPS will
 521 look for public and private keys in this directory: a @code{.crt} files for
 522 PEM-encoded certificates and corresponding @code{.key} files for PEM-encoded
 523 private keys.")
 524   (server-root
 525    (file-name "/etc/cups")
 526    "Specifies the directory containing the server configuration files.")
 527   (sync-on-close?
 528    (boolean #f)
 529    "Specifies whether the scheduler calls fsync(2) after writing configuration
 530 or state files.")
 531   (system-group
 532    (space-separated-string-list '("lpadmin" "wheel" "root"))
 533    "Specifies the group(s) to use for @code{@@SYSTEM} group authentication.")
 534   (temp-dir
 535    (file-name "/var/spool/cups/tmp")
 536    "Specifies the directory where temporary files are stored.")
 537   (user
 538    (string "lp")
 539    "Specifies the user name or ID that is used when running external
 540 programs."))
 541
 542 (define (serialize-files-configuration field-name val)
 543   #f)
 544
 545 (define (environment-variables? vars)
 546   (space-separated-string-list? vars))
 547 (define (serialize-environment-variables field-name vars)
 548   (unless (null? vars)
 549     (serialize-space-separated-string-list field-name vars)))
 550
 551 (define (package-list? val)
 552   (and (list? val) (and-map package? val)))
 553 (define (serialize-package-list field-name val)
 554   #f)
 555
 556 (define-configuration cups-configuration
 557   (cups
 558    (package cups)
 559    "The CUPS package.")
 560   (extensions
 561    (package-list (list cups-filters))
 562    "Drivers and other extensions to the CUPS package.")
 563   (files-configuration
 564    (files-configuration (files-configuration))
 565    "Configuration of where to write logs, what directories to use for print
 566 spools, and related privileged configuration parameters.")
 567   (access-log-level
 568    (access-log-level 'actions)
 569    "Specifies the logging level for the AccessLog file.  The @code{config}
 570 level logs when printers and classes are added, deleted, or modified and when
 571 configuration files are accessed or updated.  The @code{actions} level logs
 572 when print jobs are submitted, held, released, modified, or canceled, and any
 573 of the conditions for @code{config}.  The @code{all} level logs all
 574 requests.")
 575   (auto-purge-jobs?
 576    (boolean #f)
 577    "Specifies whether to purge job history data automatically when it is no
 578 longer required for quotas.")
 579   (browse-local-protocols
 580    (browse-local-protocols 'dnssd)
 581    "Specifies which protocols to use for local printer sharing.")
 582   (browse-web-if?
 583    (boolean #f)
 584    "Specifies whether the CUPS web interface is advertised.")
 585   (browsing?
 586    (boolean #f)
 587    "Specifies whether shared printers are advertised.")
 588   (classification
 589    (string "")
 590    "Specifies the security classification of the server.
 591 Any valid banner name can be used, including \"classified\", \"confidential\",
 592 \"secret\", \"topsecret\", and \"unclassified\", or the banner can be omitted
 593 to disable secure printing functions.")
 594   (classify-override?
 595    (boolean #f)
 596    "Specifies whether users may override the classification (cover page) of
 597 individual print jobs using the @code{job-sheets} option.")
 598   (default-auth-type
 599     (default-auth-type 'Basic)
 600     "Specifies the default type of authentication to use.")
 601   (default-encryption
 602     (default-encryption 'Required)
 603     "Specifies whether encryption will be used for authenticated requests.")
 604   (default-language
 605     (string "en")
 606     "Specifies the default language to use for text and web content.")
 607   (default-paper-size
 608     (string "Auto")
 609     "Specifies the default paper size for new print queues.  @samp{\"Auto\"}
 610 uses a locale-specific default, while @samp{\"None\"} specifies there is no
 611 default paper size.  Specific size names are typically @samp{\"Letter\"} or
 612 @samp{\"A4\"}.")
 613   (default-policy
 614     (string "default")
 615     "Specifies the default access policy to use.")
 616   (default-shared?
 617     (boolean #t)
 618     "Specifies whether local printers are shared by default.")
 619   (dirty-clean-interval
 620    (non-negative-integer 30)
 621    "Specifies the delay for updating of configuration and state files, in
 622 seconds.  A value of 0 causes the update to happen as soon as possible,
 623 typically within a few milliseconds.")
 624   (error-policy
 625    (error-policy 'stop-printer)
 626    "Specifies what to do when an error occurs.  Possible values are
 627 @code{abort-job}, which will discard the failed print job; @code{retry-job},
 628 which will retry the job at a later time; @code{retry-this-job}, which retries
 629 the failed job immediately; and @code{stop-printer}, which stops the
 630 printer.")
 631   (filter-limit
 632    (non-negative-integer 0)
 633    "Specifies the maximum cost of filters that are run concurrently, which can
 634 be used to minimize disk, memory, and CPU resource problems.  A limit of 0
 635 disables filter limiting.  An average print to a non-PostScript printer needs
 636 a filter limit of about 200.  A PostScript printer needs about half
 637 that (100).  Setting the limit below these thresholds will effectively limit
 638 the scheduler to printing a single job at any time.")
 639   (filter-nice
 640    (non-negative-integer 0)
 641    "Specifies the scheduling priority of filters that are run to print a job.
 642 The nice value ranges from 0, the highest priority, to 19, the lowest
 643 priority.")
 644   ;; Add this option if the package is built with Kerberos support.
 645   ;; (gss-service-name
 646   ;;  (string "http")
 647   ;;  "Specifies the service name when using Kerberos authentication.")
 648   (host-name-lookups
 649    (host-name-lookups #f)
 650    "Specifies whether to do reverse lookups on connecting clients.
 651 The @code{double} setting causes @code{cupsd} to verify that the hostname
 652 resolved from the address matches one of the addresses returned for that
 653 hostname.  Double lookups also prevent clients with unregistered addresses
 654 from connecting to your server.  Only set this option to @code{#t} or
 655 @code{double} if absolutely required.")
 656   ;; Add this option if the package is built with launchd/systemd support.
 657   ;;   (idle-exit-timeout
 658   ;;    (non-negative-integer 60)
 659   ;;    "Specifies the length of time to wait before shutting down due to
 660   ;; inactivity.  Note: Only applicable when @code{cupsd} is run on-demand
 661   ;; (e.g., with @code{-l}).")
 662   (job-kill-delay
 663    (non-negative-integer 30)
 664    "Specifies the number of seconds to wait before killing the filters and
 665 backend associated with a canceled or held job.")
 666   (job-retry-interval
 667    (non-negative-integer 30)
 668    "Specifies the interval between retries of jobs in seconds.  This is
 669 typically used for fax queues but can also be used with normal print queues
 670 whose error policy is @code{retry-job} or @code{retry-current-job}.")
 671   (job-retry-limit
 672    (non-negative-integer 5)
 673    "Specifies the number of retries that are done for jobs.  This is typically
 674 used for fax queues but can also be used with normal print queues whose error
 675 policy is @code{retry-job} or @code{retry-current-job}.")
 676   (keep-alive?
 677    (boolean #t)
 678    "Specifies whether to support HTTP keep-alive connections.")
 679   (keep-alive-timeout
 680    (non-negative-integer 30)
 681    "Specifies how long an idle client connection remains open, in seconds.")
 682   (limit-request-body
 683    (non-negative-integer 0)
 684    "Specifies the maximum size of print files, IPP requests, and HTML form
 685 data.  A limit of 0 disables the limit check.")
 686   (listen
 687    (multiline-string-list '("localhost:631" "/var/run/cups/cups.sock"))
 688    "Listens on the specified interfaces for connections.  Valid values are of
 689 the form @var{address}:@var{port}, where @var{address} is either an IPv6
 690 address enclosed in brackets, an IPv4 address, or @code{*} to indicate all
 691 addresses.  Values can also be file names of local UNIX domain sockets.  The
 692 Listen directive is similar to the Port directive but allows you to restrict
 693 access to specific interfaces or networks.")
 694   (listen-back-log
 695    (non-negative-integer 128)
 696    "Specifies the number of pending connections that will be allowed.  This
 697 normally only affects very busy servers that have reached the MaxClients
 698 limit, but can also be triggered by large numbers of simultaneous connections.
 699 When the limit is reached, the operating system will refuse additional
 700 connections until the scheduler can accept the pending ones.")
 701   (location-access-controls
 702    (location-access-control-list
 703     (list (location-access-control
 704            (path "/")
 705            (access-controls '("Order allow,deny"
 706                               "Allow localhost")))
 707           (location-access-control
 708            (path "/admin")
 709            (access-controls '("Order allow,deny"
 710                               "Allow localhost")))
 711           (location-access-control
 712            (path "/admin/conf")
 713            (access-controls '("Order allow,deny"
 714                               "AuthType Basic"
 715                               "Require user @SYSTEM"
 716                               "Allow localhost")))))
 717    "Specifies a set of additional access controls.")
 718   (log-debug-history
 719    (non-negative-integer 100)
 720    "Specifies the number of debugging messages that are retained for logging
 721 if an error occurs in a print job.  Debug messages are logged regardless of
 722 the LogLevel setting.")
 723   (log-level
 724    (log-level 'info)
 725    "Specifies the level of logging for the ErrorLog file.  The value
 726 @code{none} stops all logging while @code{debug2} logs everything.")
 727   (log-time-format
 728    (log-time-format 'standard)
 729    "Specifies the format of the date and time in the log files.  The value
 730 @code{standard} logs whole seconds while @code{usecs} logs microseconds.")
 731   (max-clients
 732    (non-negative-integer 100)
 733    "Specifies the maximum number of simultaneous clients that are allowed by
 734 the scheduler.")
 735   (max-clients-per-host
 736    (non-negative-integer 100)
 737    "Specifies the maximum number of simultaneous clients that are allowed from
 738 a single address.")
 739   (max-copies
 740    (non-negative-integer 9999)
 741    "Specifies the maximum number of copies that a user can print of each
 742 job.")
 743   (max-hold-time
 744    (non-negative-integer 0)
 745    "Specifies the maximum time a job may remain in the @code{indefinite} hold
 746 state before it is canceled.  A value of 0 disables cancellation of held
 747 jobs.")
 748   (max-jobs
 749    (non-negative-integer 500)
 750    "Specifies the maximum number of simultaneous jobs that are allowed.  Set
 751 to 0 to allow an unlimited number of jobs.")
 752   (max-jobs-per-printer
 753    (non-negative-integer 0)
 754    "Specifies the maximum number of simultaneous jobs that are allowed per
 755 printer.  A value of 0 allows up to MaxJobs jobs per printer.")
 756   (max-jobs-per-user
 757    (non-negative-integer 0)
 758    "Specifies the maximum number of simultaneous jobs that are allowed per
 759 user.  A value of 0 allows up to MaxJobs jobs per user.")
 760   (max-job-time
 761    (non-negative-integer 10800)
 762    "Specifies the maximum time a job may take to print before it is canceled,
 763 in seconds.  Set to 0 to disable cancellation of \"stuck\" jobs.")
 764   (max-log-size
 765    (non-negative-integer 1048576)
 766    "Specifies the maximum size of the log files before they are rotated, in
 767 bytes.  The value 0 disables log rotation.")
 768   (multiple-operation-timeout
 769    (non-negative-integer 300)
 770    "Specifies the maximum amount of time to allow between files in a multiple
 771 file print job, in seconds.")
 772   (page-log-format
 773    (string "")
 774    "Specifies the format of PageLog lines.  Sequences beginning with
 775 percent (@samp{%}) characters are replaced with the corresponding information,
 776 while all other characters are copied literally.  The following percent
 777 sequences are recognized:
 778
 779 @table @samp
 780 @item %%
 781 insert a single percent character
 782 @item %@{name@}
 783 insert the value of the specified IPP attribute
 784 @item %C
 785 insert the number of copies for the current page
 786 @item %P
 787 insert the current page number
 788 @item %T
 789 insert the current date and time in common log format
 790 @item %j
 791 insert the job ID
 792 @item %p
 793 insert the printer name
 794 @item %u
 795 insert the username
 796 @end table
 797
 798 A value of the empty string disables page logging.  The string @code{%p %u %j
 799 %T %P %C %@{job-billing@} %@{job-originating-host-name@} %@{job-name@}
 800 %@{media@} %@{sides@}} creates a page log with the standard items.")
 801   (environment-variables
 802    (environment-variables '())
 803    "Passes the specified environment variable(s) to child processes; a list of
 804 strings.")
 805   (policies
 806    (policy-configuration-list
 807     (list (policy-configuration
 808            (name "default")
 809            (access-controls
 810             (list
 811              (operation-access-control
 812               (operations
 813                '(Send-Document
 814                  Send-URI Hold-Job Release-Job Restart-Job Purge-Jobs
 815                  Cancel-Job Close-Job Cancel-My-Jobs Set-Job-Attributes
 816                  Create-Job-Subscription Renew-Subscription
 817                  Cancel-Subscription Get-Notifications
 818                  Reprocess-Job Cancel-Current-Job Suspend-Current-Job
 819                  Resume-Job CUPS-Move-Job Validate-Job
 820                  CUPS-Get-Document))
 821               (access-controls '("Require user @OWNER @SYSTEM"
 822                                  "Order deny,allow")))
 823              (operation-access-control
 824               (operations
 825                '(Pause-Printer
 826                  Cancel-Jobs
 827                  Resume-Printer Set-Printer-Attributes Enable-Printer
 828                  Disable-Printer Pause-Printer-After-Current-Job
 829                  Hold-New-Jobs Release-Held-New-Jobs Deactivate-Printer
 830                  Activate-Printer Restart-Printer Shutdown-Printer
 831                  Startup-Printer Promote-Job Schedule-Job-After
 832                  CUPS-Authenticate-Job CUPS-Add-Printer
 833                  CUPS-Delete-Printer CUPS-Add-Class CUPS-Delete-Class
 834                  CUPS-Accept-Jobs CUPS-Reject-Jobs CUPS-Set-Default))
 835               (access-controls '("AuthType Basic"
 836                                  "Require user @SYSTEM"
 837                                  "Order deny,allow")))
 838              (operation-access-control
 839               (operations '(All))
 840               (access-controls '("Order deny,allow"))))))))
 841    "Specifies named access control policies.")
 842   #;
 843   (port
 844    (non-negative-integer 631)
 845    "Listens to the specified port number for connections.")
 846   (preserve-job-files
 847    (boolean-or-non-negative-integer 86400)
 848    "Specifies whether job files (documents) are preserved after a job is
 849 printed.  If a numeric value is specified, job files are preserved for the
 850 indicated number of seconds after printing.  Otherwise a boolean value applies
 851 indefinitely.")
 852   (preserve-job-history
 853    (boolean-or-non-negative-integer #t)
 854    "Specifies whether the job history is preserved after a job is printed.
 855 If a numeric value is specified, the job history is preserved for the
 856 indicated number of seconds after printing.  If @code{#t}, the job history is
 857 preserved until the MaxJobs limit is reached.")
 858   (reload-timeout
 859    (non-negative-integer 30)
 860    "Specifies the amount of time to wait for job completion before restarting
 861 the scheduler.")
 862   (rip-cache
 863    (string "128m")
 864    "Specifies the maximum amount of memory to use when converting documents into bitmaps for a printer.")
 865   (server-admin
 866    (string "root@localhost.localdomain")
 867    "Specifies the email address of the server administrator.")
 868   (server-alias
 869    (host-name-list-or-* '*)
 870    "The ServerAlias directive is used for HTTP Host header validation when
 871 clients connect to the scheduler from external interfaces.  Using the special
 872 name @code{*} can expose your system to known browser-based DNS rebinding
 873 attacks, even when accessing sites through a firewall.  If the auto-discovery
 874 of alternate names does not work, we recommend listing each alternate name
 875 with a ServerAlias directive instead of using @code{*}.")
 876   (server-name
 877    (string "localhost")
 878    "Specifies the fully-qualified host name of the server.")
 879   (server-tokens
 880    (server-tokens 'Minimal)
 881    "Specifies what information is included in the Server header of HTTP
 882 responses.  @code{None} disables the Server header.  @code{ProductOnly}
 883 reports @code{CUPS}.  @code{Major} reports @code{CUPS 2}.  @code{Minor}
 884 reports @code{CUPS 2.0}.  @code{Minimal} reports @code{CUPS 2.0.0}.  @code{OS}
 885 reports @code{CUPS 2.0.0 (@var{uname})} where @var{uname} is the output of the
 886 @code{uname} command.  @code{Full} reports @code{CUPS 2.0.0 (@var{uname})
 887 IPP/2.0}.")
 888   (set-env
 889    (string "variable value")
 890    "Set the specified environment variable to be passed to child processes.")
 891   (ssl-listen
 892    (multiline-string-list '())
 893    "Listens on the specified interfaces for encrypted connections.  Valid
 894 values are of the form @var{address}:@var{port}, where @var{address} is either
 895 an IPv6 address enclosed in brackets, an IPv4 address, or @code{*} to indicate
 896 all addresses.")
 897   (ssl-options
 898    (ssl-options '())
 899    "Sets encryption options.
 900 By default, CUPS only supports encryption using TLS v1.0 or higher using known
 901 secure cipher suites.  The @code{AllowRC4} option enables the 128-bit RC4
 902 cipher suites, which are required for some older clients that do not implement
 903 newer ones.  The @code{AllowSSL3} option enables SSL v3.0, which is required
 904 for some older clients that do not support TLS v1.0.")
 905   #;
 906   (ssl-port
 907    (non-negative-integer 631)
 908    "Listens on the specified port for encrypted connections.")
 909   (strict-conformance?
 910    (boolean #f)
 911    "Specifies whether the scheduler requires clients to strictly adhere to the
 912 IPP specifications.")
 913   (timeout
 914    (non-negative-integer 300)
 915    "Specifies the HTTP request timeout, in seconds.")
 916   (web-interface?
 917    (boolean #f)
 918    "Specifies whether the web interface is enabled."))
 919
 920 (define-configuration opaque-cups-configuration
 921   (cups
 922    (package cups)
 923    "The CUPS package.")
 924   (extensions
 925    (package-list '())
 926    "Drivers and other extensions to the CUPS package.")
 927   (cupsd.conf
 928    (string (cups-configuration-missing-field 'opaque-cups-configuration
 929                                              'cupsd.conf))
 930    "The contents of the @code{cupsd.conf} to use.")
 931   (cups-files.conf
 932    (string (cups-configuration-missing-field 'opaque-cups-configuration
 933                                              'cups-files.conf))
 934    "The contents of the @code{cups-files.conf} to use."))
 935
 936 (define %cups-activation
 937   ;; Activation gexp.
 938   (with-imported-modules '((guix build utils))
 939     #~(begin
 940         (define (mkdir-p/perms directory owner perms)
 941           (mkdir-p directory)
 942           (chown "/var/run/cups" (passwd:uid owner) (passwd:gid owner))
 943           (chmod directory perms))
 944         (define (build-subject parameters)
 945           (string-concatenate
 946            (map (lambda (pair)
 947                   (let ((k (car pair)) (v (cdr pair)))
 948                     (define (escape-char str chr)
 949                       (string-join (string-split str chr) (string #\\ chr)))
 950                     (string-append "/" k "="
 951                                    (escape-char (escape-char v #\=) #\/))))
 952                 (filter (lambda (pair) (cdr pair)) parameters))))
 953         (define* (create-self-signed-certificate-if-absent
 954                   #:key private-key public-key (owner (getpwnam "root"))
 955                   (common-name (gethostname))
 956                   (organization-name "GuixSD")
 957                   (organization-unit-name "Default Self-Signed Certificate")
 958                   (subject-parameters `(("CN" . ,common-name)
 959                                         ("O" . ,organization-name)
 960                                         ("OU" . ,organization-unit-name)))
 961                   (subject (build-subject subject-parameters)))
 962           ;; Note that by default, OpenSSL outputs keys in PEM format.  This
 963           ;; is what we want.
 964           (unless (file-exists? private-key)
 965             (cond
 966              ((zero? (system* (string-append #$openssl "/bin/openssl")
 967                               "genrsa" "-out" private-key "2048"))
 968               (chown private-key (passwd:uid owner) (passwd:gid owner))
 969               (chmod private-key #o400))
 970              (else
 971               (format (current-error-port)
 972                       "Failed to create private key at ~a.\n" private-key))))
 973           (unless (file-exists? public-key)
 974             (cond
 975              ((zero? (system* (string-append #$openssl "/bin/openssl")
 976                               "req" "-new" "-x509" "-key" private-key
 977                               "-out" public-key "-days" "3650"
 978                               "-batch" "-subj" subject))
 979               (chown public-key (passwd:uid owner) (passwd:gid owner))
 980               (chmod public-key #o444))
 981              (else
 982               (format (current-error-port)
 983                       "Failed to create public key at ~a.\n" public-key)))))
 984         (let ((user (getpwnam "lp")))
 985           (mkdir-p/perms "/var/run/cups" user #o755)
 986           (mkdir-p/perms "/var/spool/cups" user #o755)
 987           (mkdir-p/perms "/var/spool/cups/tmp" user #o755)
 988           (mkdir-p/perms "/var/log/cups" user #o755)
 989           (mkdir-p/perms "/etc/cups" user #o755)
 990           (mkdir-p/perms "/etc/cups/ssl" user #o700)
 991           ;; This certificate is used for HTTPS connections to the CUPS web
 992           ;; interface.
 993           (create-self-signed-certificate-if-absent
 994            #:private-key "/etc/cups/ssl/localhost.key"
 995            #:public-key "/etc/cups/ssl/localhost.crt"
 996            #:owner (getpwnam "root")
 997            #:common-name (format #f "CUPS service on ~a" (gethostname)))))))
 998
 999 (define (union-directory name packages paths)
1000   (computed-file
1001    name
1002    (with-imported-modules '((guix build utils))
1003      #~(begin
1004          (use-modules (guix build utils)
1005                       (srfi srfi-1))
1006          (mkdir #$output)
1007          (for-each
1008           (lambda (package)
1009             (for-each
1010              (lambda (path)
1011                (for-each
1012                 (lambda (src)
1013                   (let* ((tail (substring src (string-length package)))
1014                          (dst (string-append #$output tail)))
1015                     (mkdir-p (dirname dst))
1016                     ;; CUPS currently symlinks in some data from cups-filters
1017                     ;; to its output dir.  Probably we should stop doing this
1018                     ;; and instead rely only on the CUPS service to union the
1019                     ;; relevant set of CUPS packages.
1020                     (if (file-exists? dst)
1021                         (format (current-error-port) "warning: ~a exists\n" dst)
1022                         (symlink src dst))))
1023                 (find-files (string-append package path))))
1024              (list #$@paths)))
1025           (list #$@packages))
1026          #t))))
1027
1028 (define (cups-server-bin-directory extensions)
1029   "Return the CUPS ServerBin directory, containing binaries for CUPS and all
1030 extensions that it uses."
1031   (union-directory "cups-server-bin" extensions
1032                    ;; /bin
1033                    '("/lib/cups" "/share/ppd" "/share/cups")))
1034
1035 (define (cups-shepherd-service config)
1036   "Return a list of <shepherd-service> for CONFIG."
1037   (let* ((cupsd.conf-str
1038           (cond
1039            ((opaque-cups-configuration? config)
1040             (opaque-cups-configuration-cupsd.conf config))
1041            (else
1042             (with-output-to-string
1043               (lambda ()
1044                 (serialize-configuration config
1045                                          cups-configuration-fields))))))
1046          (cups-files.conf-str
1047           (cond
1048            ((opaque-cups-configuration? config)
1049             (opaque-cups-configuration-cups-files.conf config))
1050            (else
1051             (with-output-to-string
1052               (lambda ()
1053                 (serialize-configuration
1054                  (cups-configuration-files-configuration config)
1055                  files-configuration-fields))))))
1056          (cups (if (opaque-cups-configuration? config)
1057                    (opaque-cups-configuration-cups config)
1058                    (cups-configuration-cups config)))
1059          (server-bin
1060           (cups-server-bin-directory
1061            (cons cups
1062                  (cond
1063                   ((opaque-cups-configuration? config)
1064                    (opaque-cups-configuration-extensions config))
1065                   (else
1066                    (cups-configuration-extensions config))))))
1067          ;;"SetEnv PATH " server-bin "/bin" "\n"
1068          (cupsd.conf
1069           (plain-file "cupsd.conf" cupsd.conf-str))
1070          (cups-files.conf
1071           (mixed-text-file
1072            "cups-files.conf"
1073            cups-files.conf-str
1074            "CacheDir /var/cache/cups\n"
1075            "StateDir /var/run/cups\n"
1076            "DataDir " server-bin "/share/cups" "\n"
1077            "ServerBin " server-bin "/lib/cups" "\n")))
1078     (list (shepherd-service
1079            (documentation "Run the CUPS print server.")
1080            (provision '(cups))
1081            (requirement '(networking))
1082            (start #~(make-forkexec-constructor
1083                      (list (string-append #$cups "/sbin/cupsd")
1084                            "-f" "-c" #$cupsd.conf "-s" #$cups-files.conf)))
1085            (stop #~(make-kill-destructor))))))
1086
1087 (define cups-service-type
1088   (service-type (name 'cups)
1089                 (extensions
1090                  (list (service-extension shepherd-root-service-type
1091                                           cups-shepherd-service)
1092                        (service-extension activation-service-type
1093                                           (const %cups-activation))
1094                        (service-extension account-service-type
1095                                           (const %cups-accounts))))
1096
1097                 ;; Extensions consist of lists of packages (representing CUPS
1098                 ;; drivers, etc) that we just concatenate.
1099                 (compose append)
1100
1101                 ;; Add extension packages by augmenting the cups-configuration
1102                 ;; 'extensions' field.
1103                 (extend
1104                  (lambda (config extensions)
1105                    (cond
1106                     ((cups-configuration? config)
1107                      (cups-configuration
1108                       (inherit config)
1109                       (extensions
1110                        (append (cups-configuration-extensions config)
1111                                extensions))))
1112                     (else
1113                      (opaque-cups-configuration
1114                       (inherit config)
1115                       (extensions
1116                        (append (opaque-cups-configuration-extensions config)
1117                                extensions)))))))))
1118
1119 ;; A little helper to make it easier to document all those fields.
1120 (define (generate-documentation)
1121   (define documentation
1122     `((cups-configuration
1123        ,cups-configuration-fields
1124        (files-configuration files-configuration)
1125        (policies policy-configuration)
1126        (location-access-controls location-access-controls))
1127       (files-configuration ,files-configuration-fields)
1128       (policy-configuration
1129        ,policy-configuration-fields
1130        (operation-access-controls operation-access-controls))
1131       (location-access-controls
1132        ,location-access-control-fields
1133        (method-access-controls method-access-controls))
1134       (operation-access-controls ,operation-access-control-fields)
1135       (method-access-controls ,method-access-control-fields)))
1136   (define (str x) (object->string x))
1137   (define (generate configuration-name)
1138     (match (assq-ref documentation configuration-name)
1139       ((fields . sub-documentation)
1140        `((para "Available " (code ,(str configuration-name)) " fields are:")
1141          ,@(map
1142             (lambda (f)
1143               (let ((field-name (configuration-field-name f))
1144                     (field-type (configuration-field-type f))
1145                     (field-docs (cdr (texi-fragment->stexi
1146                                       (configuration-field-documentation f))))
1147                     (default (catch #t
1148                                (configuration-field-default-value-thunk f)
1149                                (lambda _ '%invalid))))
1150                 (define (show-default? val)
1151                   (or (string? default) (number? default) (boolean? default)
1152                       (and (symbol? val) (not (eq? val '%invalid)))
1153                       (and (list? val) (and-map show-default? val))))
1154                 `(deftypevr (% (category
1155                                 (code ,(str configuration-name)) " parameter")
1156                                (data-type ,(str field-type))
1157                                (name ,(str field-name)))
1158                    ,@field-docs
1159                    ,@(if (show-default? default)
1160                          `((para "Defaults to " (samp ,(str default)) "."))
1161                          '())
1162                    ,@(append-map
1163                       generate
1164                       (or (assq-ref sub-documentation field-name) '())))))
1165             fields)))))
1166   (stexi->texi `(*fragment* . ,(generate 'cups-configuration))))