me
/
guix
Archived
1
0
Fork 0
Code

machine: ssh: Validate 'system' field. 

* gnu/machine/ssh.scm (<machine-ssh-configuration>)[system]: Add
'sanitize' property.
(validate-system-type): New macro.
master
Ludovic Courtès 2022-11-17 12:35:07 +01:00
parent 983906ab72
commit 17b01d5463
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 29 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gnu/machine/ssh.scm
View File

@ -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))