[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] gnu: Add CUPS service.
|
From: |
Andy Wingo |
|
Subject: |
[PATCH] gnu: Add CUPS service. |
|
Date: |
Wed, 5 Oct 2016 23:13:22 +0200 |
* gnu/services/cups.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add gnu/services/cups.scm.
* doc/guix.texi (Printing Services): New section.
---
doc/guix.texi | 552 +++++++++++++++++++++++++++++++++
gnu/local.mk | 1 +
gnu/services/cups.scm | 833 ++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 1386 insertions(+)
create mode 100644 gnu/services/cups.scm
diff --git a/doc/guix.texi b/doc/guix.texi
index 9bd8b43..9a959a7 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -7586,6 +7586,7 @@ declaration.
* Log Rotation:: The rottlog service.
* Networking Services:: Network setup, SSH daemon, etc.
* X Window:: Graphical display.
+* Printing Services:: Local and remote printer support.
* Desktop Services:: D-Bus and desktop services.
* Database Services:: SQL databases.
* Mail Services:: IMAP, POP3, SMTP, and all that.
@@ -8629,6 +8630,557 @@ makes the good ol' XlockMore usable.
@end deffn
address@hidden Printing Services
address@hidden Printing Services
+
+The @code{(gnu services cups)} module provides a Guix service definition
+for the CUPS printing service. To add printer support to a GuixSD
+system, add a @code{cups-service} to the operating system definition:
+
address@hidden {Scheme Procedure} cups-service [#:config (cups-configuration)]
+Return a service that runs the CUPS print server.
address@hidden deffn
+
+The CUPS configuration controls the basic things about your CUPS
+installation: what interfaces it listens on, what to do if a print job
+fails, how much logging to do, and so on. To actually add a printer,
+you have to visit the @url{http://localhost:631} URL, or use a tool such
+as GNOME's printer configuration services. By default, configuring a
+CUPS service will generate a self-signed certificate if needed, for
+secure connections to the print server.
+
+One way you might want to customize CUPS is to enable or disable the web
interface. You can do that directly, like this:
+
address@hidden
+(cups-service #:config
+ (cups-configuration
+ (web-interface? #f)))
address@hidden example
+
+The available configuration parameters follow. Each parameter
+definition is preceded by its type; for example, @samp{string-list foo}
+indicates that the @code{foo} parameter should be specified as a list of
+strings. There is also a way to specify the configuration as a string,
+if you have an old @code{cupsd.conf} file that you want to port over
+from some other system; see the end for more details.
+
address@hidden The following documentation was initially generated by
address@hidden (generate-documentation) in (gnu services cups). Manually
maintained
address@hidden documentation is better, so we shouldn't hesitate to edit below
as
address@hidden needed. However if the change you want to make to this
documentation
address@hidden can be done in an automated way, it's probably easier to change
address@hidden (generate-documentation) than to make it below and have to deal
with
address@hidden the churn as CUPS updates.
+
+
+Available @code{cups-configuration} fields are:
+
address@hidden address@hidden parameter} package cups
+The CUPS package.
address@hidden deftypevr
+
address@hidden address@hidden parameter} access-log-level access-log-level
+Specifies the logging level for the AccessLog file. The @code{config}
+level logs when printers and classes are added, deleted, or modified and when
+configuration files are accessed or updated. The @code{actions} level logs
+when print jobs are submitted, held, released, modified, or canceled, and any
+of the conditions for @code{config}. The @code{all} level logs all
+requests.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean auto-purge-jobs?
+Specifies whether to purge job history data automatically when it is no
+longer required for quotas.
+Defaults to @samp{#f}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} browse-local-protocols
browse-local-protocols
+Specifies which protocols to use for local printer sharing.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean browse-web-if?
+Specifies whether the CUPS web interface is advertised.
+Defaults to @samp{#f}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean browsing?
+Specifies whether shared printers are advertised.
+Defaults to @samp{#f}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string classification
+Specifies the security classification of the server.
+Any valid banner name can be used, including "classified", "confidential",
+"secret", "topsecret", and "unclassified", or the banner can be omitted
+to disable secure printing functions.
+Defaults to @samp{""}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean classify-override?
+Specifies whether users may override the classification (cover page) of
+individual print jobs using the @code{job-sheets} option.
+Defaults to @samp{#f}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} default-auth-type default-auth-type
+Specifies the default type of authentication to use.
address@hidden deftypevr
+
address@hidden address@hidden parameter} default-encryption default-encryption
+Specifies whether encryption will be used for authenticated requests.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string default-language
+Specifies the default language to use for text and web content.
+Defaults to @samp{"en"}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string default-paper-size
+Specifies the default paper size for new print queues. "Auto" uses a
+locale-specific default, while "None" specifies there is no default paper
+size. Specific size names are typically "Letter" or "A4".
+Defaults to @samp{"Auto"}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string default-policy
+Specifies the default access policy to use.
+Defaults to @samp{"default"}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean default-shared?
+Specifies whether local printers are shared by default.
+Defaults to @samp{#t}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer
dirty-clean-interval
+Specifies the delay for updating of configuration and state files, in
+seconds. A value of 0 causes the update to happen as soon as possible,
+typically within a few milliseconds.
+Defaults to @samp{30}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} error-policy error-policy
+Specifies what to do when an error occurs. Possible values are
address@hidden, which will discard the failed print job; @code{retry-job},
+which will retry the job at a later time; @code{retry-this-job}, which retries
+the failed job immediately; and @code{stop-printer}, which stops the
+printer.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer filter-limit
+Specifies the maximum cost of filters that are run concurrently, which can
+be used to minimize disk, memory, and CPU resource problems. A limit of 0
+disables filter limiting. An average print to a non-PostScript printer needs
+a filter limit of about 200. A PostScript printer needs about half
+that (100). Setting the limit below these thresholds will effectively limit
+the scheduler to printing a single job at any time.
+Defaults to @samp{0}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer filter-nice
+Specifies the scheduling priority of filters that are run to print a job.
+The nice value ranges from 0, the highest priority, to 19, the lowest
+priority.
+Defaults to @samp{0}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string gss-service-name
+Specifies the service name when using Kerberos authentication.
+Defaults to @samp{"http"}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} host-name-lookups host-name-lookups
+Specifies whether to do reverse lookups on connecting clients.
+The @code{double} setting causes @code{cupsd} to verify that the hostname
+resolved from the address matches one of the addresses returned for that
+hostname. Double lookups also prevent clients with unregistered addresses
+from connecting to your server. Only set this option to @code{#t} or
address@hidden if absolutely required.
+Defaults to @samp{#f}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer idle-exit-timeout
+Specifies the length of time to wait before shutting down due to
+inactivity. Note: Only applicable when @code{cupsd} is run on-demand (e.g.,
+with @code{-l}).
+Defaults to @samp{60}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer job-kill-delay
+Specifies the number of seconds to wait before killing the filters and
+backend associated with a canceled or held job.
+Defaults to @samp{30}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer job-retry-interval
+Specifies the interval between retries of jobs in seconds. This is
+typically used for fax queues but can also be used with normal print queues
+whose error policy is @code{retry-job} or @code{retry-current-job}.
+Defaults to @samp{30}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer job-retry-limit
+Specifies the number of retries that are done for jobs. This is typically
+used for fax queues but can also be used with normal print queues whose error
+policy is @code{retry-job} or @code{retry-current-job}.
+Defaults to @samp{5}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean keep-alive?
+Specifies whether to support HTTP keep-alive connections.
+Defaults to @samp{#t}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer keep-alive-timeout
+Specifies how long an idle client connection remains open, in seconds.
+Defaults to @samp{30}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer limit-request-body
+Specifies the maximum size of print files, IPP requests, and HTML form
+data. A limit of 0 disables the limit check.
+Defaults to @samp{0}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} multiline-string-list listen
+Listens on the specified interfaces for connections. Valid values are of
+the form @var{address}:@var{port}, where @var{address} is either an IPv6
+address enclosed in brackets, an IPv4 address, or @code{*} to indicate all
+addresses. Values can also be file names of local UNIX domain sockets. The
+Listen directive is similar to the Port directive but allows you to restrict
+access to specific interfaces or networks.
+Defaults to @samp{()}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer listen-back-log
+Specifies the number of pending connections that will be allowed. This
+normally only affects very busy servers that have reached the MaxClients
+limit, but can also be triggered by large numbers of simultaneous connections.
+When the limit is reached, the operating system will refuse additional
+connections until the scheduler can accept the pending ones.
+Defaults to @samp{128}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} location-access-control-list
location-access-controls
+Specifies a set of additional access controls.
+Defaults to @samp{()}.
+
+Available @code{location-configuration} fields are:
+
address@hidden address@hidden parameter} file-name path
+Specifies the URI path to which the access control applies.
address@hidden deftypevr
+
address@hidden address@hidden parameter} access-control-list access-controls
+ACL directives.
+Defaults to @samp{()}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} limited-access-control-list
limited-access-controls
+<Limit OPERATION...> ... </Limit>, <Limit METHOD...> ... </Limit>,
+<LimitExcept METHOD...> ... </LimitExcept> directives.
+Defaults to @samp{()}.
+
+Available @code{operation-access-controls} fields are:
+
address@hidden address@hidden parameter} space-separated-string-list operations
+IPP operations to which this access control applies.
+Defaults to @samp{()}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} access-control-list access-controls
+Access control directives.
+Defaults to @samp{()}.
address@hidden deftypevr
+
+
+Available @code{method-access-controls} fields are:
+
address@hidden address@hidden parameter} boolean reverse?
+If @code{#t}, apply access controls to all methods except the listed
+methods. Otherwise apply to only the listed methods.
+Defaults to @samp{#f}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} method-list methods
+Methods to which this access control applies.
+Defaults to @samp{()}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} access-control-list access-controls
+Access control directives.
+Defaults to @samp{()}.
address@hidden deftypevr
+
address@hidden deftypevr
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer log-debug-history
+Specifies the number of debugging
+messages that are retained for logging if an error occurs in a print
+job. Debug messages are logged regardless of the LogLevel setting.
+Defaults to @samp{100}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} log-level log-level
+Specifies the level of logging for the ErrorLog file. The value
address@hidden stops all logging while @code{debug2} logs everything.
address@hidden deftypevr
+
address@hidden address@hidden parameter} log-time-format log-time-format
+Specifies the format of the date and time in the log files. The value
address@hidden logs whole seconds while @code{usecs} logs microseconds.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer max-clients
+Specifies the maximum number of simultaneous clients that are allowed by
+the scheduler.
+Defaults to @samp{100}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer
max-clients-per-host
+Specifies the maximum number of simultaneous clients that are allowed from
+a single address.
+Defaults to @samp{100}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer max-copies
+Specifies the maximum number of copies that a user can print of each
+job.
+Defaults to @samp{9999}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer max-hold-time
+Specifies the maximum time a job may remain in the @code{indefinite} hold
+state before it is canceled. A value of 0 disables cancellation of held
+jobs.
+Defaults to @samp{0}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer max-jobs
+Specifies the maximum number of simultaneous jobs that are allowed. Set
+to 0 to allow an unlimited number of jobs.
+Defaults to @samp{500}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer
max-jobs-per-printer
+Specifies the maximum number of simultaneous jobs that are allowed per
+printer. A value of 0 allows up to MaxJobs jobs per printer.
+Defaults to @samp{0}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer max-jobs-per-user
+Specifies the maximum number of simultaneous jobs that are allowed per
+user. A value of 0 allows up to MaxJobs jobs per user.
+Defaults to @samp{0}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer max-job-time
+Specifies the maximum time a job may take to print before it is canceled,
+in seconds. Set to 0 to disable cancellation of "stuck" jobs.
+Defaults to @samp{10800}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer max-log-size
+Specifies the maximum size of the log files before they are rotated, in
+bytes. The value 0 disables log rotation.
+Defaults to @samp{1048576}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer
multiple-operation-timeout
+Specifies the maximum amount of time to allow between files in a multiple
+file print job, in seconds.
+Defaults to @samp{300}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string page-log-format
+Specifies the format of PageLog lines. Sequences beginning with
+percent (@samp{%}) characters are replaced with the corresponding information,
+while all other characters are copied literally. The following percent
+sequences are recognized:
+
address@hidden @samp
address@hidden %%
+insert a single percent character
address@hidden address@hidden@}
+insert the value of the specified IPP attribute
address@hidden %C
+insert the number of copies for the current page
address@hidden %P
+insert the current page number
address@hidden %T
+insert the current date and time in common log format
address@hidden %j
+insert the job ID
address@hidden %p
+insert the printer name
address@hidden %u
+insert the username
address@hidden table
+
+A value of the empty string disables page logging. The string @code{%p %u %j
+%T %P %C address@hidden@} address@hidden@} address@hidden@}
address@hidden@} address@hidden@}} creates a page log with the standard items.
+Defaults to @samp{""}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} space-separated-string-list
environment-variables
+Passes the specified environment variable(s) to child processes; a list of
+strings.
+Defaults to @samp{()}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} policy-list policies
+Specifies named access control policies.
+Defaults to @samp{()}.
+
+Available @code{policy-configuration} fields are:
+
address@hidden address@hidden parameter} string name
+Name of the policy.
address@hidden deftypevr
+
address@hidden address@hidden parameter} limited-access-control-list
limited-access-controls
+<Limit OPERATION...> ... </Limit>, <Limit METHOD...> ... </Limit>,
+<LimitExcept METHOD...> ... </LimitExcept> directives.
+Defaults to @samp{()}.
address@hidden deftypevr
+
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer port
+Listens to the specified port number for connections.
+Defaults to @samp{631}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean-or-non-negative-integer
preserve-job-files
+Specifies whether job files (documents) are preserved after a job is
+printed. If a numeric value is specified, job files are preserved for the
+indicated number of seconds after printing. Otherwise a boolean value applies
+indefinitely.
+Defaults to @samp{86400}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean-or-non-negative-integer
preserve-job-history
+Specifies whether the job history is preserved after a job is printed.
+If a numeric value is specified, the job history is preserved for the
+indicated number of seconds after printing. If @code{#t}, the job history is
+preserved until the MaxJobs limit is reached.
+Defaults to @samp{#t}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer reload-timeout
+Specifies the amount of time to wait for job completion before restarting
+the scheduler.
+Defaults to @samp{30}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string rip-cache
+Specifies the maximum amount of memory to use when converting documents into
bitmaps for a printer.
+Defaults to @samp{"128m"}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string server-admin
+Specifies the email address of the server administrator.
+Defaults to @samp{"root@@localhost.localdomain"}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} host-name-list-or-* server-alias
+The ServerAlias directive is used for HTTP Host header validation when
+clients connect to the scheduler from external interfaces. Using the special
+name @code{*} can expose your system to known browser-based DNS rebinding
+attacks, even when accessing sites through a firewall. If the auto-discovery
+of alternate names does not work, we recommend listing each alternate name
+with a ServerAlias directive instead of using @code{*}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string server-name
+Specifies the fully-qualified host name of the server.
+Defaults to @samp{"localhost"}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} server-tokens server-tokens
+Specifies what information is included in the Server header of HTTP
+responses. @code{None} disables the Server header. @code{ProductOnly} reports
address@hidden @code{Major} reports @code{CUPS 2}. @code{Minor} reports
address@hidden 2.0}. @code{Minimal} reports @code{CUPS 2.0.0}. @code{OS} reports
address@hidden 2.0.0 (@var{uname})} where @var{uname} is the output of the
address@hidden command. @code{Full} reports @code{CUPS 2.0.0 (@var{uname})
+IPP/2.0}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string set-env
+Set the specified environment variable to be passed to child processes.
+Defaults to @samp{"variable value"}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} multiline-string-list ssl-listen
+Listens on the specified interfaces for encrypted connections. Valid
+values are of the form @var{address}:@var{port}, where @var{address} is either
+an IPv6 address enclosed in brackets, an IPv4 address, or @code{*} to indicate
+all addresses.
+Defaults to @samp{()}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} ssl-options ssl-options
+Sets encryption options.
+By default, CUPS only supports encryption using TLS v1.0 or higher using known
+secure cipher suites. The @code{AllowRC4} option enables the 128-bit RC4
+cipher suites, which are required for some older clients that do not implement
+newer ones. The @code{AllowSSL3} option enables SSL v3.0, which is required
+for some older clients that do not support TLS v1.0.
+Defaults to @samp{()}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer ssl-port
+Listens on the specified port for encrypted connections.
+Defaults to @samp{631}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean strict-conformance?
+Specifies whether the scheduler requires clients to strictly adhere to the
+IPP specifications.
+Defaults to @samp{#f}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} non-negative-integer timeout
+Specifies the HTTP request timeout, in seconds.
+Defaults to @samp{300}.
address@hidden deftypevr
+
address@hidden address@hidden parameter} boolean web-interface?
+Specifies whether the web interface is enabled.
+Defaults to @samp{#f}.
address@hidden deftypevr
+
+At this point you're probably thinking ``oh dear, Guix manual, I like
+you but you can stop already with the configuration options''. Indeed.
+However, one more point: it could be that you have an existing
address@hidden that you want to use. In that case, you can pass an
address@hidden as the @code{#:config} parameter to
address@hidden
+
+Available @code{opaque-cups-configuration} fields are:
+
address@hidden address@hidden parameter} package cups
+The CUPS package.
address@hidden deftypevr
+
address@hidden address@hidden parameter} string string
+The contents of the @code{cupsd.conf}, as a string.
address@hidden deftypevr
+
+For example, if your @code{cupsd.conf} is just the empty string, you
+could instantiate a cups service like this:
+
address@hidden
+(cups-service #:config
+ (opaque-cups-configuration
+ (string "")))
address@hidden example
+
+
@node Desktop Services
@subsubsection Desktop Services
diff --git a/gnu/local.mk b/gnu/local.mk
index a609bf6..0e35e8a 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -388,6 +388,7 @@ GNU_SYSTEM_MODULES = \
%D%/services/admin.scm \
%D%/services/avahi.scm \
%D%/services/base.scm \
+ %D%/services/cups.scm \
%D%/services/databases.scm \
%D%/services/dbus.scm \
%D%/services/desktop.scm \
diff --git a/gnu/services/cups.scm b/gnu/services/cups.scm
new file mode 100644
index 0000000..cf95749
--- /dev/null
+++ b/gnu/services/cups.scm
@@ -0,0 +1,833 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Wingo <address@hidden>
+;;;
+;;; 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 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 (ice-9 match)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:export (&cups-configuation-error
+ cups-configuration-error?
+
+ cups-service
+ cups-service-type
+ cups-configuration
+ opaque-cups-configuration
+
+ policy
+ location-access-control
+ operation-access-control
+ method-access-control
+ ;access-control
+ ))
+
+;;; Commentary:
+;;;
+;;; Service defininition for the CUPS printing system.
+;;;
+;;; Code:
+
+(define-condition-type &cups-configuration-error &error
+ cups-configuration-error?)
+
+(define (cups-error message)
+ (raise (condition (&message (message message))
+ (&cups-configuration-error))))
+(define (cups-configuration-field-error field val)
+ (cups-error
+ (format #f "Invalid value for field ~a: ~s" field val)))
+(define (cups-configuration-missing-field kind field)
+ (cups-error
+ (format #f "~a configuration missing required field ~a" kind field)))
+
+(define-record-type* <configuration-field>
+ configuration-field make-configuration-field configuration-field?
+ (name configuration-field-name)
+ (type configuration-field-type)
+ (getter configuration-field-getter)
+ (predicate configuration-field-predicate)
+ (serializer configuration-field-serializer)
+ (default-value-thunk configuration-field-default-value-thunk)
+ (documentation configuration-field-documentation))
+
+(define-syntax define-configuration
+ (lambda (stx)
+ (define (id ctx part . parts)
+ (let ((part (syntax->datum part)))
+ (datum->syntax
+ ctx
+ (match parts
+ (() part)
+ (parts (symbol-append part
+ (syntax->datum (apply id ctx parts))))))))
+ (syntax-case stx ()
+ ((_ stem (field (field-type def) doc) ...)
+ (with-syntax (((field-getter ...)
+ (map (lambda (field)
+ (id #'stem #'stem #'- field))
+ #'(field ...)))
+ ((field-predicate ...)
+ (map (lambda (type)
+ (id #'stem type #'?))
+ #'(field-type ...)))
+ ((field-serializer ...)
+ (map (lambda (type)
+ (id #'stem #'serialize- type))
+ #'(field-type ...))))
+ #`(begin
+ (define-record-type* #,(id #'stem #'< #'stem #'>)
+ stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?)
+ (field field-getter (default def))
+ ...)
+ (define #,(id #'stem #'stem #'-fields)
+ (list (configuration-field
+ (name 'field)
+ (type 'field-type)
+ (getter field-getter)
+ (predicate field-predicate)
+ (serializer field-serializer)
+ (default-value-thunk (lambda () def))
+ (documentation doc))
+ ...))))))))
+
+(define (serialize-configuration config fields)
+ (for-each (lambda (field)
+ ((configuration-field-serializer field)
+ (configuration-field-name field)
+ ((configuration-field-getter field) config)))
+ fields))
+
+(define (validate-configuration config fields)
+ (for-each (lambda (field)
+ (let ((val ((configuration-field-getter field) config)))
+ (unless ((configuration-field-predicate field) val)
+ (cups-configuration-field-error
+ (configuration-field-name field) val))))
+ fields))
+
+#;
+(define-record-type* <cups-configuration>
+ cups-configuration make-cups-configuration
+ cups-configuration?
+ (cups cups-configuration-cups ;<package>
+ (default cups))
+ (config-file cups-configuration-file)
+ (data-directory cups-configuration-data-directory))
+
+ (define %cups-accounts
+ (list (user-group (name "cups") (system? #t))
+ (user-account
+ (name "cups")
+ (group "cups")
+ (system? #t)
+ (comment "CUPS print server user")
+ (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-package field-name val)
+ #f)
+
+(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 (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 (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 Negotiate))
+(define-enumerated-field-type default-encryption
+ (Never IfRequested Required))
+(define-enumerated-field-type error-policy
+ (abort-job retry-job retry-this-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 (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))) x)))
+(define (serialize-ssl-options field-name val)
+ (serialize-field field-name
+ (match val
+ (() "None")
+ (opts (string-join (map symbol->string opts) " ")))))
+
+;; FIXME!
+(define (access-control? x) #f)
+(define (serialize-access-control x) #f)
+
+(define (access-control-list? val)
+ (and (list? val) (and-map access-control? val)))
+(define (serialize-access-control-list field-name val)
+ (for-each serialize-access-control val))
+
+(define-configuration operation-access-control
+ (operations
+ (space-separated-string-list '())
+ "IPP operations to which this access control applies.")
+ (access-controls
+ (access-control-list '())
+ "Access control directives."))
+
+(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."))
+
+(define (serialize-operation-access-control x)
+ (format #t "<Limit ~a>\n"
+ (string-join (operation-access-control-operations x) " "))
+ (for-each serialize-access-control
+ (operation-access-control-access-controls x))
+ (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 (method-access-control-methods x) " "))
+ (for-each serialize-access-control
+ (method-access-control-access-controls x))
+ (format #t "</~a>\n" limit)))
+
+(define (limited-access-control? x)
+ (or (operation-access-control? x) (method-access-control? x)))
+(define (serialize-limited-access-control x)
+ (if (operation-access-control? x)
+ (serialize-operation-access-control x)
+ (serialize-method-access-control x)))
+
+(define (limited-access-control-list? val)
+ (and (list? val) (and-map limited-access-control? val)))
+(define (serialize-limited-access-control-list field-name val)
+ (for-each serialize-limited-access-control val))
+
+(define-configuration location-access-control
+ (path
+ (file-name (cups-configuration-missing-field 'location-access-control
'path))
+ "Specifies the URI path to which the access control applies.")
+ (access-controls
+ (access-control-list '())
+ "ACL directives.")
+ (limited-access-controls
+ (limited-access-control-list '())
+ "<Limit OPERATION...> ... </Limit>, <Limit METHOD...> ... </Limit>,
+<LimitExcept METHOD...> ... </LimitExcept> directives."))
+
+(define (serialize-location-access-control x)
+ (format #t "<Location ~a>\n" (location-access-control-path x))
+ (for-each serialize-access-control
+ (location-access-control-access-controls x))
+ (for-each serialize-limited-access-control
+ (location-access-control-limited-access-controls x))
+ (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
+ (name
+ (string (cups-configuration-missing-field 'policy 'name))
+ "Name of the policy.")
+ (limited-access-controls
+ (limited-access-control-list '())
+ "<Limit OPERATION...> ... </Limit>, <Limit METHOD...> ... </Limit>,
+<LimitExcept METHOD...> ... </LimitExcept> directives."))
+
+(define (serialize-policy x)
+ (format #t "<Policy ~a>\n" (policy-name x))
+ (for-each serialize-limited-access-control
+ (policy-limited-access-controls x))
+ (format #t "</Policy>\n"))
+
+(define (policy-list? x)
+ (and (list? x) (and-map policy? x)))
+(define (serialize-policy-list field-name x)
+ (for-each serialize-policy x))
+
+(define-configuration cups-configuration
+ (cups
+ (package cups)
+ "The CUPS package.")
+ (access-log-level
+ (access-log-level 'actions)
+ "Specifies the logging level for the AccessLog file. The @code{config}
+level logs when printers and classes are added, deleted, or modified and when
+configuration files are accessed or updated. The @code{actions} level logs
+when print jobs are submitted, held, released, modified, or canceled, and any
+of the conditions for @code{config}. The @code{all} level logs all
+requests.")
+ (auto-purge-jobs?
+ (boolean #f)
+ "Specifies whether to purge job history data automatically when it is no
+longer required for quotas.")
+ (browse-local-protocols
+ (browse-local-protocols 'dnssd)
+ "Specifies which protocols to use for local printer sharing.")
+ (browse-web-if?
+ (boolean #f)
+ "Specifies whether the CUPS web interface is advertised.")
+ (browsing?
+ (boolean #f)
+ "Specifies whether shared printers are advertised.")
+ (classification
+ (string "")
+ "Specifies the security classification of the server.
+Any valid banner name can be used, including \"classified\", \"confidential\",
+\"secret\", \"topsecret\", and \"unclassified\", or the banner can be omitted
+to disable secure printing functions.")
+ (classify-override?
+ (boolean #f)
+ "Specifies whether users may override the classification (cover page) of
+individual print jobs using the @code{job-sheets} option.")
+ (default-auth-type
+ (default-auth-type 'Basic)
+ "Specifies the default type of authentication to use.")
+ (default-encryption
+ (default-encryption 'Required)
+ "Specifies whether encryption will be used for authenticated requests.")
+ (default-language
+ (string "en")
+ "Specifies the default language to use for text and web content.")
+ (default-paper-size
+ (string "Auto")
+ "Specifies the default paper size for new print queues. \"Auto\" uses a
+locale-specific default, while \"None\" specifies there is no default paper
+size. Specific size names are typically \"Letter\" or \"A4\".")
+ (default-policy
+ (string "default")
+ "Specifies the default access policy to use.")
+ (default-shared?
+ (boolean #t)
+ "Specifies whether local printers are shared by default.")
+ (dirty-clean-interval
+ (non-negative-integer 30)
+ "Specifies the delay for updating of configuration and state files, in
+seconds. A value of 0 causes the update to happen as soon as possible,
+typically within a few milliseconds.")
+ (error-policy
+ (error-policy 'stop-printer)
+ "Specifies what to do when an error occurs. Possible values are
address@hidden, which will discard the failed print job; @code{retry-job},
+which will retry the job at a later time; @code{retry-this-job}, which retries
+the failed job immediately; and @code{stop-printer}, which stops the
+printer.")
+ (filter-limit
+ (non-negative-integer 0)
+ "Specifies the maximum cost of filters that are run concurrently, which can
+be used to minimize disk, memory, and CPU resource problems. A limit of 0
+disables filter limiting. An average print to a non-PostScript printer needs
+a filter limit of about 200. A PostScript printer needs about half
+that (100). Setting the limit below these thresholds will effectively limit
+the scheduler to printing a single job at any time.")
+ (filter-nice
+ (non-negative-integer 0)
+ "Specifies the scheduling priority of filters that are run to print a job.
+The nice value ranges from 0, the highest priority, to 19, the lowest
+priority.")
+ (gss-service-name
+ (string "http")
+ "Specifies the service name when using Kerberos authentication.")
+ (host-name-lookups
+ (host-name-lookups #f)
+ "Specifies whether to do reverse lookups on connecting clients.
+The @code{double} setting causes @code{cupsd} to verify that the hostname
+resolved from the address matches one of the addresses returned for that
+hostname. Double lookups also prevent clients with unregistered addresses
+from connecting to your server. Only set this option to @code{#t} or
address@hidden if absolutely required.")
+ (idle-exit-timeout
+ (non-negative-integer 60)
+ "Specifies the length of time to wait before shutting down due to
+inactivity. Note: Only applicable when @code{cupsd} is run on-demand (e.g.,
+with @code{-l}).")
+ (job-kill-delay
+ (non-negative-integer 30)
+ "Specifies the number of seconds to wait before killing the filters and
+backend associated with a canceled or held job.")
+ (job-retry-interval
+ (non-negative-integer 30)
+ "Specifies the interval between retries of jobs in seconds. This is
+typically used for fax queues but can also be used with normal print queues
+whose error policy is @code{retry-job} or @code{retry-current-job}.")
+ (job-retry-limit
+ (non-negative-integer 5)
+ "Specifies the number of retries that are done for jobs. This is typically
+used for fax queues but can also be used with normal print queues whose error
+policy is @code{retry-job} or @code{retry-current-job}.")
+ (keep-alive?
+ (boolean #t)
+ "Specifies whether to support HTTP keep-alive connections.")
+ (keep-alive-timeout
+ (non-negative-integer 30)
+ "Specifies how long an idle client connection remains open, in seconds.")
+ (limit-request-body
+ (non-negative-integer 0)
+ "Specifies the maximum size of print files, IPP requests, and HTML form
+data. A limit of 0 disables the limit check.")
+ (listen
+ (multiline-string-list '())
+ "Listens on the specified interfaces for connections. Valid values are of
+the form @var{address}:@var{port}, where @var{address} is either an IPv6
+address enclosed in brackets, an IPv4 address, or @code{*} to indicate all
+addresses. Values can also be file names of local UNIX domain sockets. The
+Listen directive is similar to the Port directive but allows you to restrict
+access to specific interfaces or networks.")
+ (listen-back-log
+ (non-negative-integer 128)
+ "Specifies the number of pending connections that will be allowed. This
+normally only affects very busy servers that have reached the MaxClients
+limit, but can also be triggered by large numbers of simultaneous connections.
+When the limit is reached, the operating system will refuse additional
+connections until the scheduler can accept the pending ones.")
+ (location-access-controls
+ (location-access-control-list '())
+ "Specifies a set of additional access controls.")
+ (log-debug-history
+ (non-negative-integer 100)
+ "Specifies the number of debugging
+messages that are retained for logging if an error occurs in a print
+job. Debug messages are logged regardless of the LogLevel setting.")
+ (log-level
+ (log-level 'warn)
+ "Specifies the level of logging for the ErrorLog file. The value
address@hidden stops all logging while @code{debug2} logs everything.")
+ (log-time-format
+ (log-time-format 'standard)
+ "Specifies the format of the date and time in the log files. The value
address@hidden logs whole seconds while @code{usecs} logs microseconds.")
+ (max-clients
+ (non-negative-integer 100)
+ "Specifies the maximum number of simultaneous clients that are allowed by
+the scheduler.")
+ (max-clients-per-host
+ (non-negative-integer 100)
+ "Specifies the maximum number of simultaneous clients that are allowed from
+a single address.")
+ (max-copies
+ (non-negative-integer 9999)
+ "Specifies the maximum number of copies that a user can print of each
+job.")
+ (max-hold-time
+ (non-negative-integer 0)
+ "Specifies the maximum time a job may remain in the @code{indefinite} hold
+state before it is canceled. A value of 0 disables cancellation of held
+jobs.")
+ (max-jobs
+ (non-negative-integer 500)
+ "Specifies the maximum number of simultaneous jobs that are allowed. Set
+to 0 to allow an unlimited number of jobs.")
+ (max-jobs-per-printer
+ (non-negative-integer 0)
+ "Specifies the maximum number of simultaneous jobs that are allowed per
+printer. A value of 0 allows up to MaxJobs jobs per printer.")
+ (max-jobs-per-user
+ (non-negative-integer 0)
+ "Specifies the maximum number of simultaneous jobs that are allowed per
+user. A value of 0 allows up to MaxJobs jobs per user.")
+ (max-job-time
+ (non-negative-integer 10800)
+ "Specifies the maximum time a job may take to print before it is canceled,
+in seconds. Set to 0 to disable cancellation of \"stuck\" jobs.")
+ (max-log-size
+ (non-negative-integer 1048576)
+ "Specifies the maximum size of the log files before they are rotated, in
+bytes. The value 0 disables log rotation.")
+ (multiple-operation-timeout
+ (non-negative-integer 300)
+ "Specifies the maximum amount of time to allow between files in a multiple
+file print job, in seconds.")
+ (page-log-format
+ (string "")
+ "Specifies the format of PageLog lines. Sequences beginning with
+percent (@samp{%}) characters are replaced with the corresponding information,
+while all other characters are copied literally. The following percent
+sequences are recognized:
+
address@hidden @samp
address@hidden %%
+insert a single percent character
address@hidden address@hidden@}
+insert the value of the specified IPP attribute
address@hidden %C
+insert the number of copies for the current page
address@hidden %P
+insert the current page number
address@hidden %T
+insert the current date and time in common log format
address@hidden %j
+insert the job ID
address@hidden %p
+insert the printer name
address@hidden %u
+insert the username
address@hidden table
+
+A value of the empty string disables page logging. The string @code{%p %u %j
+%T %P %C address@hidden@} address@hidden@} address@hidden@}
address@hidden@} address@hidden@}} creates a page log with the standard items.")
+ (environment-variables
+ (space-separated-string-list '())
+ "Passes the specified environment variable(s) to child processes; a list of
+strings.")
+ (policies
+ (policy-list '())
+ "Specifies named access control policies.")
+ (port
+ (non-negative-integer 631)
+ "Listens to the specified port number for connections.")
+ (preserve-job-files
+ (boolean-or-non-negative-integer 86400)
+ "Specifies whether job files (documents) are preserved after a job is
+printed. If a numeric value is specified, job files are preserved for the
+indicated number of seconds after printing. Otherwise a boolean value applies
+indefinitely.")
+ (preserve-job-history
+ (boolean-or-non-negative-integer #t)
+ "Specifies whether the job history is preserved after a job is printed.
+If a numeric value is specified, the job history is preserved for the
+indicated number of seconds after printing. If @code{#t}, the job history is
+preserved until the MaxJobs limit is reached.")
+ (reload-timeout
+ (non-negative-integer 30)
+ "Specifies the amount of time to wait for job completion before restarting
+the scheduler.")
+ (rip-cache
+ (string "128m")
+ "Specifies the maximum amount of memory to use when converting documents
into bitmaps for a printer.")
+ (server-admin
+ (string "address@hidden")
+ "Specifies the email address of the server administrator.")
+ (server-alias
+ (host-name-list-or-* '*)
+ "The ServerAlias directive is used for HTTP Host header validation when
+clients connect to the scheduler from external interfaces. Using the special
+name @code{*} can expose your system to known browser-based DNS rebinding
+attacks, even when accessing sites through a firewall. If the auto-discovery
+of alternate names does not work, we recommend listing each alternate name
+with a ServerAlias directive instead of using @code{*}.")
+ (server-name
+ (string "localhost")
+ "Specifies the fully-qualified host name of the server.")
+ (server-tokens
+ (server-tokens 'Minimal)
+ "Specifies what information is included in the Server header of HTTP
+responses. @code{None} disables the Server header. @code{ProductOnly} reports
address@hidden @code{Major} reports @code{CUPS 2}. @code{Minor} reports
address@hidden 2.0}. @code{Minimal} reports @code{CUPS 2.0.0}. @code{OS} reports
address@hidden 2.0.0 (@var{uname})} where @var{uname} is the output of the
address@hidden command. @code{Full} reports @code{CUPS 2.0.0 (@var{uname})
+IPP/2.0}.")
+ (set-env
+ (string "variable value")
+ "Set the specified environment variable to be passed to child processes.")
+ (ssl-listen
+ (multiline-string-list '())
+ "Listens on the specified interfaces for encrypted connections. Valid
+values are of the form @var{address}:@var{port}, where @var{address} is either
+an IPv6 address enclosed in brackets, an IPv4 address, or @code{*} to indicate
+all addresses.")
+ (ssl-options
+ (ssl-options '())
+ "Sets encryption options.
+By default, CUPS only supports encryption using TLS v1.0 or higher using known
+secure cipher suites. The @code{AllowRC4} option enables the 128-bit RC4
+cipher suites, which are required for some older clients that do not implement
+newer ones. The @code{AllowSSL3} option enables SSL v3.0, which is required
+for some older clients that do not support TLS v1.0.")
+ (ssl-port
+ (non-negative-integer 631)
+ "Listens on the specified port for encrypted connections.")
+ (strict-conformance?
+ (boolean #f)
+ "Specifies whether the scheduler requires clients to strictly adhere to the
+IPP specifications.")
+ (timeout
+ (non-negative-integer 300)
+ "Specifies the HTTP request timeout, in seconds.")
+ (web-interface?
+ (boolean #f)
+ "Specifies whether the web interface is enabled."))
+
+(define-configuration opaque-cups-configuration
+ (cups
+ (package cups)
+ "The CUPS package.")
+ (string
+ (string (cups-configuration-missing-field 'opaque-cups-configuration
+ 'string))
+ "The contents of the @code{cupsd.conf} to use."))
+
+(define %cups-activation
+ ;; Activation gexp.
+ #~(begin
+ (use-modules (guix build utils))
+ (define (mkdir-p/perms directory owner perms)
+ (mkdir-p directory)
+ (chown "/var/run/cups" (passwd:uid owner) (passwd:gid owner))
+ (chmod directory perms))
+ (define (build-subject parameters)
+ (string-concatenate
+ (map (lambda (pair)
+ (let ((k (car pair)) (v (cdr pair)))
+ (define (escape-char str chr)
+ (string-join (string-split str chr) (string #\\ chr)))
+ (string-append "/" k "="
+ (escape-char (escape-char v #\=) #\/))))
+ (filter (lambda (pair) (cdr pair)) parameters))))
+ (define* (create-self-signed-certificate-if-absent
+ #:key private-key public-key (owner (getpwnam "root"))
+ (common-name (gethostname))
+ (organization-name "GuixSD")
+ (organization-unit-name "Default Self-Signed Certificate")
+ (subject-parameters `(("CN" . ,common-name)
+ ("O" . ,organization-name)
+ ("OU" . ,organization-unit-name)))
+ (subject (build-subject subject-parameters)))
+ ;; Note that by default, OpenSSL outputs keys in PEM format. This
+ ;; is what we want.
+ (unless (file-exists? private-key)
+ (cond
+ ((zero? (system* (string-append #$openssl "/bin/openssl")
+ "genrsa" "-out" private-key "2048"))
+ (chown private-key (passwd:uid owner) (passwd:gid owner))
+ (chmod private-key #o400))
+ (else
+ (format (current-error-port)
+ "Failed to create private key at ~a.\n" private-key))))
+ (unless (file-exists? public-key)
+ (cond
+ ((zero? (system* (string-append #$openssl "/bin/openssl")
+ "req" "-new" "-x509" "-key" private-key
+ "-out" public-key "-days" "3650"
+ "-batch" "-subj" subject))
+ (chown public-key (passwd:uid owner) (passwd:gid owner))
+ (chmod public-key #o444))
+ (else
+ (format (current-error-port)
+ "Failed to create public key at ~a.\n" public-key)))))
+ (let ((user (getpwnam "cups")))
+ (mkdir-p/perms "/var/run/cups" user #o755)
+ (mkdir-p/perms "/var/spool/cups" user #o755)
+ (mkdir-p/perms "/var/log/cups" user #o755)
+ (mkdir-p/perms "/etc/cups" user #o755)
+ (mkdir-p/perms "/etc/cups/ssl" user #o700)
+ (create-self-signed-certificate-if-absent
+ #:private-key "/etc/cups/ssl/server.key"
+ #:public-key "/etc/cups/ssl/server.crt"
+ #:owner (getpwnam "root")
+ #:common-name (format #f "CUPS service on ~a" (gethostname))))))
+
+(define (cups-shepherd-service config)
+ "Return a list of <shepherd-service> for CONFIG."
+ (let* ((config-str
+ (cond
+ ((opaque-cups-configuration? config)
+ (opaque-cups-configuration-string config))
+ (else
+ (with-output-to-string
+ (lambda ()
+ (serialize-configuration config
+ cups-configuration-fields))))))
+ (config-file (plain-file "cupsd.conf" config-str))
+ (cups (if (opaque-cups-configuration? config)
+ (opaque-cups-configuration-cups config)
+ (cups-configuration-cups config))))
+ (list (shepherd-service
+ (documentation "Run the CUPS print server.")
+ (provision '(cups))
+ (requirement '(networking))
+ (start #~(make-forkexec-constructor
+ (list (string-append #$cups "/sbin/cupsd")
+ "-f" "-c" #$config-file)))
+ (stop #~(make-kill-destructor))))))
+
+(define cups-service-type
+ (service-type (name 'cups)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ cups-shepherd-service)
+ (service-extension activation-service-type
+ (const %cups-activation))
+ (service-extension account-service-type
+ (const %cups-accounts))))))
+
+(define* (cups-service #:key (config (cups-configuration)))
+ "Return a service that runs @var{cups}, the Cups database server.
+
+The Cups daemon loads its runtime configuration from @var{config-file}
+and stores the database cluster in @var{data-directory}."
+ (validate-configuration config
+ (if (opaque-cups-configuration? config)
+ opaque-cups-configuration-fields
+ cups-configuration-fields))
+ (service cups-service-type config))
+
+;; A litle helper to make it easier to document all those fields.
+;; A little helper to make it easier to document all those fields.
+(define (generate-documentation)
+ (define documentation
+ `((cups-configuration
+ ,cups-configuration-fields
+ (policies policy-configuration)
+ (location-access-controls location-configuration))
+ (policy-configuration ,policy-fields)
+ (location-configuration
+ ,location-access-control-fields
+ ;(access-controls access-controls)
+ (limited-access-controls operation-access-controls
+ method-access-controls))
+ ;(access-controls ,access-control-fields)
+ (operation-access-controls ,operation-access-control-fields)
+ (method-access-controls ,method-access-control-fields)))
+ (define (generate configuration-name)
+ (match (assq-ref documentation configuration-name)
+ ((fields . sub-documentation)
+ (format #t "\nAvailable @code{~a} fields are:\n\n" configuration-name)
+ (for-each
+ (lambda (f)
+ (let ((field-name (configuration-field-name f))
+ (field-type (configuration-field-type f))
+ (field-docs (string-trim-both
+ (configuration-field-documentation f)))
+ (default (catch #t
+ (configuration-field-default-value-thunk f)
+ (lambda _ 'nope))))
+ (define (escape-chars str chars escape)
+ (with-output-to-string
+ (lambda ()
+ (string-for-each (lambda (c)
+ (when (char-set-contains? chars c)
+ (display escape))
+ (display c))
+ str))))
+ (define (show-default? val)
+ (or (string? default) (number? default) (boolean? default)
+ (and (list? val) (and-map show-default? val))))
+ (format #t "@deftypevr address@hidden parameter} ~a ~a\n~a\n"
+ configuration-name field-type field-name field-docs)
+ (when (show-default? default)
+ (format #t "Defaults to @samp{~a}.\n"
+ (escape-chars (format #f "~s" default)
+ (char-set #\@ #\{ #\})
+ #\@)))
+ (for-each generate (or (assq-ref sub-documentation field-name)
'()))
+ (format #t "@end deftypevr\n\n")))
+ fields))))
+ (generate 'cups-configuration))
--
2.10.1
- [PATCH] gnu: Add CUPS service.,
Andy Wingo <=