[bug#60735] [PATCH v2 1/3] services: Add etc-hosts-service-type.

[Bruno Victal]

* 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@protonmail.com>
 ;;; Copyright © 2020 Christine Lemmer-Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2023 Bruno Victal <mirai@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