Package: guix-patches;
Reported by: Bruno Victal <mirai <at> makinata.eu>
Date: Wed, 11 Jan 2023 17:27:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Bruno Victal <mirai <at> makinata.eu> To: 60735 <at> debbugs.gnu.org Cc: ludo <at> gnu.org, Bruno Victal <mirai <at> makinata.eu> Subject: [bug#60735] [PATCH v2 1/3] services: Add etc-hosts-service-type. Date: Wed, 18 Jan 2023 16:54:11 +0000
* gnu/services.scm (etc-hosts-service-type): New variable.
* doc/guix.texi: Document it.
---
doc/guix.texi | 46 +++++++++++++++++++++++++++++++++++
gnu/services.scm | 63 ++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 109 insertions(+)
diff --git a/doc/guix.texi b/doc/guix.texi
index 9b478733eb..5fb3df441c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -112,6 +112,7 @@
Copyright @copyright{} 2022 Ivan Vilata-i-Balaguer@*
Copyright @copyright{} 2023 Giacomo Leidi@*
Copyright @copyright{} 2022 Antero Mejr@*
+Copyright @copyright{} 2023 Bruno Victal@*
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -40191,6 +40192,51 @@ Service Reference
pointing to the given file.
@end defvr
+@defvar hosts-service-type
+Type of the service that populates the entries for (@file{/etc/hosts}).
+This service type can be extended by passing it a list of
+@code{host-entry} records.
+
+@c TRANSLATORS: The domain names below SHOULD NOT be translated.
+@c They're domains reserved for use in documentation. (RFC6761 Section 6.5)
+@c The addresses used are explained in RFC3849 and RFC5737.
+@lisp
+(simple-service 'add-extra-hosts
+ hosts-service-type
+ (list (host-entry
+ (address "192.0.2.1")
+ (canonical-name "example.com")
+ (aliases '("example.net" "example.org")))
+ (host-entry
+ (address "2001:DB8::1")
+ (canonical-name "example.com")
+ (aliases '("example.net" "example.org")))))
+@end lisp
+
+@deftp {Data Type} host-entry
+Available @code{host-entry} fields are:
+
+@table @asis
+@item @code{address} (type: string)
+IP address.
+
+@item @code{canonical-name} (type: string)
+Hostname.
+
+@item @code{aliases} (default: @code{'()}) (type: list-of-string)
+Additional aliases that map to the same @code{canonical-name}.
+
+@end table
+@end deftp
+
+For convenience, the procedure @code{host} can be for creating
+@code{host-entry} records.
+
+@defun host address canonical-name [aliases]
+Procedure for creating @code{host-entry} records.
+@end defun
+@end defvar
+
@defvr {Scheme Variable} setuid-program-service-type
Type for the ``setuid-program service''. This service collects lists of
executable file names, passed as gexps, and adds them to the set of
diff --git a/gnu/services.scm b/gnu/services.scm
index 2abef557d4..12ecfa4492 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -6,6 +6,7 @@
;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework <at> protonmail.com>
;;; Copyright © 2020 Christine Lemmer-Webber <cwebber <at> dustycloud.org>
;;; Copyright © 2020, 2021 Brice Waegeneire <brice <at> waegenei.re>
+;;; Copyright © 2023 Bruno Victal <mirai <at> makinata.eu>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -51,6 +52,7 @@ (define-module (gnu services)
#:use-module (srfi srfi-35)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
+ #:use-module (ice-9 format)
#:autoload (ice-9 pretty-print) (pretty-print)
#:export (service-extension
service-extension?
@@ -109,6 +111,15 @@ (define-module (gnu services)
extra-special-file
etc-service-type
etc-directory
+
+ host
+ host-entry
+ host-entry?
+ host-entry-address
+ host-entry-canonical-name
+ host-entry-aliases
+ hosts-service-type
+
setuid-program-service-type
profile-service-type
firmware-service-type
@@ -809,6 +820,58 @@ (define (etc-service files)
FILES must be a list of name/file-like object pairs."
(service etc-service-type files))
+(define (valid-name? name)
+ "Return true if @var{name} is likely to be a valid hostname."
+ (false-if-exception (not (string-any char-set:whitespace name))))
+
+(define-compile-time-procedure (assert-valid-name (name valid-name?))
+ "Ensure @var{name} is likely to be a valid hostname."
+ ;; TODO: RFC compliant implementation.
+ (unless (valid-name? name)
+ (raise
+ (make-compound-condition
+ (formatted-message (G_ "hostname '~a' contains invalid characters.")
+ name)
+ (condition (&error-location
+ (location
+ (source-properties->location procedure-call-location)))))))
+ name)
+
+(define-record-type* <host-entry> host-entry
+ make-host-entry host-entry?
+ (address host-entry-address)
+ (canonical-name host-entry-canonical-name
+ (sanitize assert-valid-name))
+ (aliases host-entry-aliases
+ (default '())
+ (sanitize (cut map assert-valid-name <>))))
+
+(define* (host address canonical-name #:optional (aliases '()))
+ "More compact way of creating <host> records"
+ (make-host-entry address canonical-name aliases))
+
+(define hosts-service-type
+ ;; Extend etc-service-type with a entry for @file{/etc/hosts}.
+ (let* ((serialize-host-entry-record
+ (lambda (record)
+ (match-record record <host-entry> (address canonical-name aliases)
+ (format #f "~a~/~a~{~^~/~a~}~%" address canonical-name aliases))))
+ (host-etc-service
+ (lambda (lst)
+ `(("hosts" ,(plain-file "hosts"
+ (format #f "~{~a~}"
+ (map serialize-host-entry-record
+ lst))))))))
+ (service-type
+ (name 'etc-hosts)
+ (extensions
+ (list
+ (service-extension etc-service-type
+ host-etc-service)))
+ (compose concatenate)
+ (extend append)
+ (description "Populate the @file{/etc/hosts} file."))))
+
(define (setuid-program->activation-gexp programs)
"Return an activation gexp for setuid-program from PROGRAMS."
(let ((programs (map (lambda (program)
--
2.38.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.