;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Jan Nieuwenhuizen ;;; Copyright © 2018 Clément Lassieur ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (gnu ci) #:use-module (guix config) #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix profiles) #:use-module (guix packages) #:use-module (guix channels) #:use-module (guix derivations) #:use-module (guix build-system) #:use-module (guix monads) #:use-module (guix ui) #:use-module ((guix licenses) #:select (gpl3+ license? license-name)) #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix scripts system) #:select (read-operating-system)) #:use-module ((guix scripts pack) #:select (lookup-compressor self-contained-tarball)) #:use-module (gnu bootloader) #:use-module (gnu bootloader u-boot) #:use-module (gnu packages) #:use-module (gnu packages gcc) #:use-module (gnu packages base) #:use-module (gnu packages gawk) #:use-module (gnu packages guile) #:use-module (gnu packages gettext) #:use-module (gnu packages compression) #:use-module (gnu packages multiprecision) #
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Andy Wingo <wingo@pobox.com>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2023 muradm <mail@muradm.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services cups)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services configuration)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages cups)
  #:use-module (gnu packages tls)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (append-map find))
  #:export (cups-service-type
            cups-configuration
            opaque-cups-configuration

            files-configuration
            policy-configuration
            location-access-control
            operation-access-control
            method-access-control))

;;; Commentary:
;;;
;;; Service defininition for the CUPS printing system.
;;;
;;; Code:

(define %cups-accounts
  (list (or
         ;; The "lp" group should already exist; try to reuse it.
         (find (lambda (group)
                 (and (user-group? group)
                      (string=? (user-group-name group) "lp")))
               %base-groups)
         (user-group (name "lp") (system? #t)))
        (user-group (name "lpadmin") (system? #t))
        (user-account
         (name "lp")
         (group "lp")
         (system? #t)
         (comment "System user for invoking printing helper programs")
         (home-directory "/var/empty")
         (shell (file-append shadow "/sbin/nologin")))))

(define (uglify-field-name field-name)
  (let ((str (symbol->string field-name)))
    (string-concatenate
     (map string-titlecase
          (string-split (if (string-suffix? "?" str)
                            (substring str 0 (1- (string-length str)))
                            str)
                        #\-)))))

(define (serialize-field field-name val)
  (format #t "~a ~a\n" (uglify-field-name field-name) val))

(define (serialize-string field-name val)
  (serialize-field field-name val))

(define (multiline-string-list? val)
  (and (list? val)
       (and-map (lambda (x)
                  (and (string? x) (not (string-index x #\space))))
                val)))
(define (serialize-multiline-string-list field-name val)
  (for-each (lambda (str) (serialize-field field-name str)) val))

(define (comma-separated-string-list? val)
  (and (list? val)
       (and-map (lambda (x)
                  (and (string? x) (not (string-index x #\,))))
                val)))
(define (serialize-comma-separated-string-list field-name val)
  (serialize-field field-name (string-join val ",")))

;; A special case of the above, where we don't want to emit anything at all
;; when #f, to allow CUPS to pick a default we cannot compute ourselves.
;; XXX Ideally, this could be a generic higher-order function, but it's used
;; only once so far: for ready-paper-sizes to handle "Auto" default-paper-size.
(define (comma-separated-string-list-or-#f? val)
  (if val (comma-separated-string-list? val) #t))
(define (serialize-comma-separated-string-list-or-#f field-name val)
  (if val (serialize-field field-name (string-join val ",")) #f))

(define (space-separated-string-list? val)
  (and (list? val)
       (and-map (lambda (x)
                  (and (string? x) (not (string-index x #\space))))
                val)))
(define (serialize-space-separated-string-list field-name val)
  (serialize-field field-name (string-join val " ")))

(define (space-separated-symbol-list? val)
  (and (list? val) (and-map symbol? val)))
(define (serialize-space-separated-symbol-list field-name val)
  (serialize-field field-name (string-join (map symbol->string val) " ")))

(define (file-name? val)
  (and (string? val)
       (string-prefix? "/" val)))
(define (serialize-file-name field-name val)
  (serialize-string field-name val))

(define (serialize-boolean field-name val)
  (serialize-string field-name (if val "yes" "no")))

(define (non-negative-integer? val)
  (and (exact-integer? val) (not (negative? val))))
(define (serialize-non-negative-integer field-name val)
  (serialize-field field-name val))

(define-syntax define-enumerated-field-type
  (lambda (x)
    (define (id-append ctx . parts)
      (datum->syntax ctx (apply symbol-append (map syntax->datum parts))))
    (syntax-case x ()
      ((_ name (option ...))
       #`(begin
           (define (#,(id-append #'name #'name #'?) x)
             (memq x '(option ...)))
           (define (#,(id-append #'name #'serialize- #'name) field-name val)
             (serialize-field field-name val)))))))

(define-enumerated-field-type access-log-level
  (config actions all))
(define-enumerated-field-type browse-local-protocols
  (all dnssd none))
(define-enumerated-field-type default-auth-type
  (Basic))
(define-enumerated-field-type default-encryption
  (Never IfRequested Required))
(define-enumerated-field-type error-policy
  (abort-job retry-job retry-current-job stop-printer))
(define-enumerated-field-type log-level
  (none emerg alert crit error warn notice info debug debug2))
(define-enumerated-field-type log-time-format
  (standard usecs))
(define-enumerated-field-type server-tokens
  (None ProductOnly Major Minor Minimal OS Full))
(define-enumerated-field-type method
  (DELETE GET HEAD OPTIONS POST PUT TRACE))
(define-enumerated-field-type sandboxing
  (relaxed strict))

(define (method-list? val)
  (and (list? val) (and-map method? val)))
(define (serialize-method-list field-name val)
  (serialize-field field-name (string-join (map symbol->string val) " ")))

(define (host-name-lookups? val)
  (memq val '(#f #t 'double)))
(define (serialize-host-name-lookups field-name val)
  (serialize-field field-name
                   (match val (#f "No") (#t "Yes") ('double "Double"))))
  
(define (host-name-list-or-*? x)
    (or (eq? x '*)
        (and (list? x) (and-map string? x))))
(define (serialize-host-name-list-or-* field-name val)
  (serialize-field field-name (match val
                                ('* '*)
                                (names (string-join names " ")))))

(define (boolean-or-non-negative-integer? x)
  (or (boolean? x) (non-negative-integer? x)))
(define (serialize-boolean-or-non-negative-integer field-name x)
  (if (boolean? x)
      (serialize-boolean field-name x)
      (serialize-non-negative-integer field-name x)))

(define (ssl-options? x)
  (and (list? x)
       (and-map (lambda (elt) (memq elt '(AllowRC4
                                          AllowSSL3
                                          DenyCBC
                                          DenyTLS1.0))) x)))
(define (serialize-ssl-options field-name val)
  (serialize-field field-name
                   (match val
                     (() "None")
                     (opts (string-join (map symbol->string opts) " ")))))

(define (serialize-access-control x)
  (display x)
  (newline))
(define (serialize-access-control-list field-name val)
  (for-each serialize-access-control val))
(define (access-control-list? val)
  (and (list? val) (and-map string? val)))

(define-configuration operation-access-control
  (operations
   (space-separated-symbol-list '())
   "IPP operations to which this access control applies.")
  (access-controls
   (access-control-list '())
   "Access control directives, as a list of strings.  Each string should be one directive, such as \"Order allow,deny\"."))

(define-configuration method-access-control
  (reverse?
   (boolean #f)
   "If @code{#t}, apply access controls to all methods except the listed
methods.  Otherwise apply to only the listed methods.")
  (methods
   (method-list '())
   "Methods to which this access control applies.")
  (access-controls
   (access-control-list '())
   "Access control directives, as a list of strings.  Each string should be one directive, such as \"Order allow,deny\"."))

(define (serialize-operation-access-control x)
  (format #t "<Limit ~a>\n"
          (string-join (map symbol->string
                            (operation-access-control-operations x)) " "))
  (serialize-configuration
   x
   (filter (lambda (field)
             (not (eq? (configuration-field-name field) 'operations)))
           operation-access-control-fields))
  (format #t "</Limit>\n"))

(define (serialize-method-access-control x)
  (let ((limit (if (method-access-control-reverse? x) "LimitExcept" "Limit")))
    (format #t "<~a ~a>\n" limit
            (string-join (map symbol->string
                              (method-access-control-methods x)) " "))
    (serialize-configuration
     x
     (filter (lambda (field)
               (case (configuration-field-name field)
                 ((reverse? methods) #f)
                 (else #t)))
             method-access-control-fields))
    (format #t "</~a>\n" limit)))

(define (operation-access-control-list? val)
  (and (list? val) (and-map operation-access-control? val)))
(define (serialize-operation-access-control-list field-name val)
  (for-each serialize-operation-access-control val))

(define (method-access-control-list? val)
  (and (list? val) (and-map method-access-control? val)))
(define (serialize-method-access-control-list field-name val)
  (for-each serialize-method-access-control val))

(define-configuration location-access-control
  (path
   (file-name (configuration-missing-field 'location-access-control 'path))
   "Specifies the URI path to which the access control applies.")
  (access-controls
   (access-control-list '())
   "Access controls for all access to this path, in the same format as the
@code{access-controls} of @code{operation-access-control}.")
  (method-access-controls
   (method-access-control-list '())
   "Access controls for method-specific access to this path."))

(define (serialize-location-access-control x)
  (format #t "<Location ~a>\n" (location-access-control-path x))
  (serialize-configuration
   x
   (filter (lambda (field)
             (not (eq? (configuration-field-name field) 'path)))
           location-access-control-fields))
  (format #t "</Location>\n"))

(define (location-access-control-list? val)
  (and (list? val) (and-map location-access-control? val)))
(define (serialize-location-access-control-list field-name val)
  (for-each serialize-location-access-control val))

(define-configuration policy-configuration
  (name
   (string (configuration-missing-field 'policy-configuration 'name))
   "Name of the policy.")
  (job-private-access
   (string "@OWNER @SYSTEM")
   "Specifies an access list for a job's private values.
@code{@@ACL} maps to the printer's requesting-user-name-allowed or
requesting-user-name-denied values.  @code{@@OWNER} maps to the job's owner.
@code{@@SYSTEM} maps to the groups listed for the @code{system-group} field of
the @code{files-configuration}, which is reified into the
@code{cups-files.conf(5)} file.
Other possible elements of the access list include specific user names, and
@code{@@@var{group}} to indicate members of a specific group.  The access list
may also be simply @code{all} or @code{default}.")
  (job-private-values
   (string (string-join '("job-name" "job-originating-host-name"
                          "job-originating-user-name" "phone")))
   "Specifies the list of job values to make private, or @code{all},
@code{default}, or @code{none}.")

  (subscription-private-access
   (string "@OWNER @SYSTEM")
   "Specifies an access list for a subscription's private values.
@code{@@ACL} maps to the printer's requesting-user-name-allowed or
requesting-user-name-denied values.  @code{@@OWNER} maps to the job's owner.
@code{@@SYSTEM} maps to the groups listed for the @code{system-group} field of
the @code{files-configuration}, which is reified into the
@code{cups-files.conf(5)} file.
Other possible elements of the access list include specific user names, and
@code{@@@var{group}} to indicate members of a specific group.  The access list
may also be simply @code{all} or @code{default}.")
  (subscription-private-values
   (string (string-join '("notify-events" "notify-pull-method"
                          "notify-recipient-uri" "notify-subscriber-user-name"
                          "notify-user-data")
                        " "))
   "Specifies the list of job values to make private, or @code{all},
@code{default}, or @code{none}.")

  (access-controls
   (operation-access-control-list '())
   "Access control by IPP operation."))

(define (serialize-policy-configuration x)
  (format #t "<Policy ~a>\n" (policy-configuration-name x))
  (serialize-configuration
   x
   (filter (lambda (field)
             (not (eq? (configuration-field-name field) 'name)))
           policy-configuration-fields))
  (format #t "</Policy>\n"))

(define (policy-configuration-list? x)
  (and (list? x) (and-map policy-configuration? x)))
(define (serialize-policy-configuration-list field-name x)
  (for-each serialize-policy-configuration x))

(define (log-location? x)
  (or (file-name? x)
      (eq? x 'stderr)
      (eq? x 'syslog)))
(define (serialize-log-location field-name x)
  (if (string? x)
      (serialize-file-name field-name x)
      (serialize-field field-name x)))

(define-configuration files-configuration
  (access-log
   (log-location "/var/log/cups/access_log")
   "Defines the access log filename.  Specifying a blank filename disables
access log generation.  The value @code{stderr} causes log entries to be sent
to the standard error file when the scheduler is running in the foreground, or
to the system log daemon when run in the background.  The value @code{syslog}
causes log entries to be sent to the system log daemon.  The server name may
be included in filenames using the string @code{%s}, as in
@code{/var/log/cups/%s-access_log}.")
  (cache-dir
   (file-name "/var/cache/cups")
   "Where CUPS should cache data.")
  (config-file-perm
   (string "0640")
   "Specifies the permissions for all configuration files that the scheduler
writes.

Note that the permissions for the printers.conf file are currently masked to
only allow access from the scheduler user (typically root).  This is done
because printer device URIs sometimes contain sensitive authentication
information that should not be generally known on the system.  There is no way
to disable this security feature.")
  ;; Not specifying data-dir and server-bin options as we handle these
  ;; manually.  For document-root, the CUPS package has that path
  ;; preconfigured.
  (error-log
   (log-location "/var/log/cups/error_log")
   "Defines the error log filename.  Specifying a blank filename disables
access log generation.  The value @code{stderr} causes log entries to be sent
to the standard error file when the scheduler is running in the foreground, or
to the system log daemon when run in the background.  The value @code{syslog}
causes log entries to be sent to the system log daemon.  The server name may
be included in filenames using the string @code{%s}, as in
@code{/var/log/cups/%s-error_log}.")
  (fatal-errors
   (string "all -browse")
   "Specifies which errors are fatal, causing the scheduler to exit.  The kind
strings are:
@table @code
@item none
No errors are fatal.
@item all
All of the errors below are fatal.
@item browse
Browsing initialization errors are fatal, for example failed connections to
the DNS-SD daemon.
@item config
Configuration file syntax errors are fatal.
@item listen
Listen or Port errors are fatal, except for IPv6 failures on the loopback or
@code{any} addresses.
@item log
Log file creation or write errors are fatal.
@item permissions
Bad startup file permissions are fatal, for example shared TLS certificate and
key files with world-read permissions.
@end table")
  (file-device?
   (boolean #f)
   "Specifies whether the file pseudo-device can be used for new printer
queues.  The URI @url{file:///dev/null} is always allowed.")
  (group
   (string "lp")
   "Specifies the group name or ID that will be used when executing external
programs.")
  (log-file-group
   (string "lpadmin")
   "Specifies the group name or ID that will be used for log files.")
  (log-file-perm
   (string "0644")
   "Specifies the permissions for all log files that the scheduler writes.")
  (page-log
   (log-location "/var/log/cups/page_log")
   "Defines the page log filename.  Specifying a blank filename disables
access log generation.  The value @code{stderr} causes log entries to be sent
to the standard error file when the scheduler is running in the foreground, or
to the system log daemon when run in the background.  The value @code{syslog}
causes log entries to be sent to the system log daemon.  The server name may
be included in filenames using the string @code{%s}, as in
@code{/var/log/cups/%s-page_log}.")
  (remote-root
   (string "remroot&