[bug#52603] [PATCH 0/2] Flag missing netmasks early on

[bug#52603] [PATCH 0/2] Flag missing netmasks early on

[Ludovic Courtès]

Hi!

As discussed yesterday on IRC, I mistakenly configured a machine with
something like:

  (network-address
    (device "eno1")
    (value "1.2.3.4"))

This results in having a “/0” subnet, thereby preventing the addition
of a route without a clear diagnostic from Guile-Netlink or ‘ip’.

To avoid this, this patch flags it at expansion time (if possible) or
at run time, before the machine configuration is built.

Did I go overboard with ‘define-compile-time-procedure’?  I don’t think
so :-), I think it will serve us more than once.

Thoughts?

Ludo’.

Ludovic Courtès (2):
  combinators: Add 'define-compile-time-procedure'.
  services: static-networking: Sanitize <network-address> values.

 gnu/services/base.scm | 28 ++++++++++++++++++++++--
 guix/combinators.scm  | 50 +++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 74 insertions(+), 4 deletions(-)


base-commit: 4204156eb4c1afd5365ef505e356f87daa91787d
-- 
2.33.0

[bug#52603] [PATCH 1/2] combinators: Add 'define-compile-time-procedure'.

[Ludovic Courtès]

* guix/combinators.scm (procedure-call-location): New syntax parameter.
(define-compile-time-procedure): New macro.
---
 guix/combinators.scm | 50 ++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 48 insertions(+), 2 deletions(-)

diff --git a/guix/combinators.scm b/guix/combinators.scm
index 88ad09dbe6..261d6bb57e 100644
--- a/guix/combinators.scm
+++ b/guix/combinators.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2017, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
@@ -24,7 +24,9 @@ (define-module (guix combinators)
   #:export (fold2
             fold-tree
             fold-tree-leaves
-            compile-time-value))
+            compile-time-value
+            procedure-call-location
+            define-compile-time-procedure))
 
 ;;; Commentary:
 ;;;
@@ -100,4 +102,48 @@ (define-syntax compile-time-value                 ;not quite at home
                            (_ #`'#,(datum->syntax s val)))))))
        v))))
 
+(define-syntax-parameter procedure-call-location
+  (lambda (s)
+    (syntax-violation 'procedure-call-location
+                      "'procedure-call-location' may only be used \
+within 'define-compile-time-procedure'"
+                      s)))
+
+(define-syntax-rule (define-compile-time-procedure (proc (arg pred) ...)
+                      body ...)
+  "Define PROC as a macro such that, if every actual argument in a \"call\"
+matches PRED, then BODY is evaluated at macro-expansion time.  BODY must
+return a single value in a type that has read syntax--e.g., numbers, strings,
+lists, etc.
+
+BODY can refer to 'procedure-call-location', which is bound to a source
+property alist corresponding to the call site.
+
+This macro is meant to be used primarily for small procedures that validate or
+process its arguments in a way that may be equally well performed at
+macro-expansion time."
+  (define-syntax proc
+    (lambda (s)
+      (define loc
+        #`(identifier-syntax
+           '#,(datum->syntax #'s (syntax-source s))))
+
+      (syntax-case s ()
+        ((_ arg ...)
+         (and (pred (syntax->datum #'arg)) ...)
+         (let ((arg (syntax->datum #'arg)) ...)
+           (syntax-parameterize ((procedure-call-location
+                                  (identifier-syntax (syntax-source s))))
+             body ...)))
+        ((_ actual (... ...))
+         #`((lambda (arg ...)
+              (syntax-parameterize ((procedure-call-location #,loc))
+                body ...))
+            actual (... ...)))
+        (id
+         (identifier? #'id)
+         #`(lambda (arg ...)
+             (syntax-parameterize ((procedure-call-location #,loc))
+               body ...)))))))
+
 ;;; combinators.scm ends here
-- 
2.33.0

[bug#52603] [PATCH 2/2] services: static-networking: Sanitize <network-address> values.

[Ludovic Courtès]

This makes sure users do not mistakenly configuring a network with "/0"
as its netmask.

* gnu/services/base.scm (assert-valid-address): New procedure.
(<network-address>)[value]: Add it as 'sanitize'.
---
 gnu/services/base.scm | 28 ++++++++++++++++++++++++++--
 1 file changed, 26 insertions(+), 2 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 5f93483dda..49ec856de4 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -35,8 +35,9 @@
 (define-module (gnu services base)
   #:use-module (guix store)
   #:use-module (guix deprecation)
-  #:autoload   (guix diagnostics) (warning)
+  #:autoload   (guix diagnostics) (warning &fix-hint)
   #:autoload   (guix i18n) (G_)
+  #:use-module (guix combinators)
   #:use-module (gnu services)
   #:use-module (gnu services admin)
   #:use-module (gnu services shepherd)
@@ -72,6 +73,8 @@ (define-module (gnu services base)
   #:use-module (guix i18n)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:re-export (user-processes-service-type        ;backwards compatibility
@@ -2388,6 +2391,26 @@ (define (ipv6-address? str)
   "Return true if STR denotes an IPv6 address."
   (false-if-exception (->bool (inet-pton AF_INET6 str))))
 
+(define-compile-time-procedure (assert-valid-address (address string?))
+  "Ensure ADDRESS has a valid netmask."
+  (unless (or (cidr->netmask address)
+              (and=> (false-if-exception (inet-pton AF_INET address))
+                     (cut = INADDR_LOOPBACK <>))
+              (and=> (false-if-exception (inet-pton AF_INET6 address))
+                     (cut = 1 <>)))
+    (raise
+     (make-compound-condition
+      (formatted-message (G_ "address '~a' lacks a network mask")
+                         address)
+      (condition (&error-location
+                  (location
+                   (source-properties->location procedure-call-location))))
+      (condition (&fix-hint
+                  (hint (format #f (G_ "\
+Write, say, @samp{\"~a/24\"} for a 24-bit network mask.")
+                                address)))))))
+  address)
+
 (define-record-type* <static-networking>
   static-networking make-static-networking
   static-networking?
@@ -2405,7 +2428,8 @@ (define-record-type* <network-address>
   network-address make-network-address
   network-address?
   (device    network-address-device)              ;string--e.g., "en01"
-  (value     network-address-value)               ;string--CIDR notation
+  (value     network-address-value                ;string--CIDR notation
+             (sanitize assert-valid-address))
   (ipv6?     network-address-ipv6?                ;Boolean
              (thunked)
              (default
-- 
2.33.0

[bug#52603] [PATCH 0/2] Flag missing netmasks early on

[Mathieu Othacehe]

Hey Ludo,

> To avoid this, this patch flags it at expansion time (if possible) or
> at run time, before the machine configuration is built.
>
> Did I go overboard with ‘define-compile-time-procedure’?  I don’t think
> so :-), I think it will serve us more than once.

I tested this series, works fine! It is still possible to pass incorrect
netmasks (negative, > 32 for IPv4), but they should be way less frequent
than forgetting to add a netmask.

Thanks,

Mathieu

bug#52603: [PATCH 0/2] Flag missing netmasks early on

[Ludovic Courtès]

Hi,

Mathieu Othacehe <othacehe@gnu.org> skribis:

>> To avoid this, this patch flags it at expansion time (if possible) or
>> at run time, before the machine configuration is built.
>>
>> Did I go overboard with ‘define-compile-time-procedure’?  I don’t think
>> so :-), I think it will serve us more than once.
>
> I tested this series, works fine! It is still possible to pass incorrect
> netmasks (negative, > 32 for IPv4), but they should be way less frequent
> than forgetting to add a netmask.

Yeah…

Pushed as 4df584aeac56fb6575ba43bc94f60f04522caf88, thanks for testing!

Ludo’.