ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-12 14:16:55 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

machine: ssh: Validate 'system' field.

Browse source 
* gnu/machine/ssh.scm (<machine-ssh-configuration>)[system]: Add
'sanitize' property.
(validate-system-type): New macro.
This commit is contained in:
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 @@ (define-module (gnu machine ssh)
#:use-module ((guix inferior) #:use-module ((guix inferior)
#:select (inferior-exception? #:select (inferior-exception?
inferior-exception-arguments)) inferior-exception-arguments))
#:use-module ((guix platform) #:select (systems))
#:use-module (gcrypt pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -86,7 +87,8 @@ (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
machine-ssh-configuration? machine-ssh-configuration?
this-machine-ssh-configuration this-machine-ssh-configuration
(host-name machine-ssh-configuration-host-name) ; string (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 (build-locally? machine-ssh-configuration-build-locally? ; boolean
(default #t)) (default #t))
(authorize? machine-ssh-configuration-authorize? ; boolean (authorize? machine-ssh-configuration-authorize? ; boolean
@ -109,6 +111,32 @@ (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
(host-key machine-ssh-configuration-host-key ; #f | string (host-key machine-ssh-configuration-host-key ; #f | string
(default #f))) (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) (define (open-machine-ssh-session config)
"Open an SSH session for CONFIG, a <machine-ssh-configuration> record." "Open an SSH session for CONFIG, a <machine-ssh-configuration> record."
(let ((host-name (machine-ssh-configuration-host-name config)) (let ((host-name (machine-ssh-configuration-host-name config))