01/03: machine: ssh: Validate 'system' field.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 17b01d546306885ff3c07e7b6aaffb541a8b9043
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Nov 17 12:35:07 2022 +0100

    machine: ssh: Validate 'system' field.
    
    * gnu/machine/ssh.scm (<machine-ssh-configuration>)[system]: Add
    'sanitize' property.
    (validate-system-type): New macro.
---
 gnu/machine/ssh.scm | 30 +++++++++++++++++++++++++++++-
 1 file changed, 29 insertions(+), 1 deletion(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 1230b1ec0d..343cf74748 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -42,6 +42,7 @@
   #:use-module ((guix inferior)
                 #:select (inferior-exception?
                           inferior-exception-arguments))
+  #:use-module ((guix platform) #:select (systems))
   #:use-module (gcrypt pk-crypto)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
@@ -86,7 +87,8 @@
   machine-ssh-configuration?
   this-machine-ssh-configuration
   (host-name      machine-ssh-configuration-host-name)     ; string
-  (system         machine-ssh-configuration-system)        ; string
+  (system         machine-ssh-configuration-system         ; string
+                  (sanitize validate-system-type))
   (build-locally? machine-ssh-configuration-build-locally? ; boolean
                   (default #t))
   (authorize?     machine-ssh-configuration-authorize?     ; boolean
@@ -109,6 +111,32 @@
   (host-key       machine-ssh-configuration-host-key       ; #f | string
                   (default #f)))
 
+(define-with-syntax-properties (validate-system-type (value properties))
+  ;; Raise an error if VALUE is not a valid system type.
+  (unless (string? value)
+    (raise (make-compound-condition
+            (condition
+             (&error-location
+              (location (source-properties->location properties))))
+            (formatted-message
+             (G_ "~a: invalid system type; must be a string")
+             value))))
+  (unless (member value (systems))
+    (raise (apply make-compound-condition
+                  (condition
+                   (&error-location
+                    (location (source-properties->location properties))))
+                  (formatted-message (G_ "~a: unknown system type") value)
+                  (let ((closest (string-closest value (systems)
+                                                 #:threshold 5)))
+                    (if closest
+                        (list (condition
+                               (&fix-hint
+                                (hint (format #f (G_ "Did you mean @code{~a}?")
+                                              closest)))))
+                        '())))))
+  value)
+
 (define (open-machine-ssh-session config)
   "Open an SSH session for CONFIG, a <machine-ssh-configuration> record."
   (let ((host-name (machine-ssh-configuration-host-name config))