mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2025-01-11 13:49:23 -05:00
system: vm: Move operating-system-uuid.
* gnu/system/vm.scm (operating-system-uuid): Move to ... * gnu/system.scm: ... here.
This commit is contained in:
Mathieu Othacehe
parent
051f3254cd
commit
78fbf2bd70
2 changed files with 50 additions and 48 deletions
|
|
@ -120,6 +120,7 @@ (define-module (gnu system)
|
||||||
operating-system-etc-directory
|
operating-system-etc-directory
|
||||||
operating-system-locale-directory
|
operating-system-locale-directory
|
||||||
operating-system-boot-script
|
operating-system-boot-script
|
||||||
|
operating-system-uuid
|
||||||
|
|
||||||
system-linux-image-file-name
|
system-linux-image-file-name
|
||||||
operating-system-with-gc-roots
|
operating-system-with-gc-roots
|
||||||
|
|
@ -989,6 +990,55 @@ (define make-initrd
|
||||||
#:mapped-devices mapped-devices
|
#:mapped-devices mapped-devices
|
||||||
#:keyboard-layout (operating-system-keyboard-layout os)))
|
#:keyboard-layout (operating-system-keyboard-layout os)))
|
||||||
|
|
||||||
|
(define* (operating-system-uuid os #:optional (type 'dce))
|
||||||
|
"Compute UUID object with a deterministic \"UUID\" for OS, of the given
|
||||||
|
TYPE (one of 'iso9660 or 'dce). Return a UUID object."
|
||||||
|
;; Note: For this to be deterministic, we must not hash things that contains
|
||||||
|
;; (directly or indirectly) procedures, for example. That rules out
|
||||||
|
;; anything that contains gexps, thunk or delayed record fields, etc.
|
||||||
|
|
||||||
|
(define service-name
|
||||||
|
(compose service-type-name service-kind))
|
||||||
|
|
||||||
|
(define (file-system-digest fs)
|
||||||
|
;; Return a hashable digest that does not contain 'dependencies' since
|
||||||
|
;; this field can contain procedures.
|
||||||
|
(let ((device (file-system-device fs)))
|
||||||
|
(list (file-system-mount-point fs)
|
||||||
|
(file-system-type fs)
|
||||||
|
(file-system-device->string device)
|
||||||
|
(file-system-options fs))))
|
||||||
|
|
||||||
|
(if (eq? type 'iso9660)
|
||||||
|
(let ((pad (compose (cut string-pad <> 2 #\0)
|
||||||
|
number->string))
|
||||||
|
(h (hash (map service-name (operating-system-services os))
|
||||||
|
3600)))
|
||||||
|
(bytevector->uuid
|
||||||
|
(string->iso9660-uuid
|
||||||
|
(string-append "1970-01-01-"
|
||||||
|
(pad (hash (operating-system-host-name os) 24)) "-"
|
||||||
|
(pad (quotient h 60)) "-"
|
||||||
|
(pad (modulo h 60)) "-"
|
||||||
|
(pad (hash (map file-system-digest
|
||||||
|
(operating-system-file-systems os))
|
||||||
|
100))))
|
||||||
|
'iso9660))
|
||||||
|
(bytevector->uuid
|
||||||
|
(uint-list->bytevector
|
||||||
|
(list (hash (map file-system-digest
|
||||||
|
(operating-system-file-systems os))
|
||||||
|
(- (expt 2 32) 1))
|
||||||
|
(hash (operating-system-host-name os)
|
||||||
|
(- (expt 2 32) 1))
|
||||||
|
(hash (map service-name (operating-system-services os))
|
||||||
|
(- (expt 2 32) 1))
|
||||||
|
(hash (map file-system-digest (operating-system-file-systems os))
|
||||||
|
(- (expt 2 32) 1)))
|
||||||
|
(endianness little)
|
||||||
|
4)
|
||||||
|
type)))
|
||||||
|
|
||||||
(define (locale-name->definition* name)
|
(define (locale-name->definition* name)
|
||||||
"Variant of 'locale-name->definition' that raises an error upon failure."
|
"Variant of 'locale-name->definition' that raises an error upon failure."
|
||||||
(match (locale-name->definition name)
|
(match (locale-name->definition name)
|
||||||
|
|
|
||||||
|
|
@ -604,54 +604,6 @@ (define build
|
||||||
;;; VM and disk images.
|
;;; VM and disk images.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define* (operating-system-uuid os #:optional (type 'dce))
|
|
||||||
"Compute UUID object with a deterministic \"UUID\" for OS, of the given
|
|
||||||
TYPE (one of 'iso9660 or 'dce). Return a UUID object."
|
|
||||||
;; Note: For this to be deterministic, we must not hash things that contains
|
|
||||||
;; (directly or indirectly) procedures, for example. That rules out
|
|
||||||
;; anything that contains gexps, thunk or delayed record fields, etc.
|
|
||||||
|
|
||||||
(define service-name
|
|
||||||
(compose service-type-name service-kind))
|
|
||||||
|
|
||||||
(define (file-system-digest fs)
|
|
||||||
;; Return a hashable digest that does not contain 'dependencies' since
|
|
||||||
;; this field can contain procedures.
|
|
||||||
(let ((device (file-system-device fs)))
|
|
||||||
(list (file-system-mount-point fs)
|
|
||||||
(file-system-type fs)
|
|
||||||
(file-system-device->string device)
|
|
||||||
(file-system-options fs))))
|
|
||||||
|
|
||||||
(if (eq? type 'iso9660)
|
|
||||||
(let ((pad (compose (cut string-pad <> 2 #\0)
|
|
||||||
number->string))
|
|
||||||
(h (hash (map service-name (operating-system-services os))
|
|
||||||
3600)))
|
|
||||||
(bytevector->uuid
|
|
||||||
(string->iso9660-uuid
|
|
||||||
(string-append "1970-01-01-"
|
|
||||||
(pad (hash (operating-system-host-name os) 24)) "-"
|
|
||||||
(pad (quotient h 60)) "-"
|
|
||||||
(pad (modulo h 60)) "-"
|
|
||||||
(pad (hash (map file-system-digest
|
|
||||||
(operating-system-file-systems os))
|
|
||||||
100))))
|
|
||||||
'iso9660))
|
|
||||||
(bytevector->uuid
|
|
||||||
(uint-list->bytevector
|
|
||||||
(list (hash (map file-system-digest
|
|
||||||
(operating-system-file-systems os))
|
|
||||||
(- (expt 2 32) 1))
|
|
||||||
(hash (operating-system-host-name os)
|
|
||||||
(- (expt 2 32) 1))
|
|
||||||
(hash (map service-name (operating-system-services os))
|
|
||||||
(- (expt 2 32) 1))
|
|
||||||
(hash (map file-system-digest (operating-system-file-systems os))
|
|
||||||
(- (expt 2 32) 1)))
|
|
||||||
(endianness little)
|
|
||||||
4)
|
|
||||||
type)))
|
|
||||||
|
|
||||||
(define* (system-disk-image os
|
(define* (system-disk-image os
|
||||||
#:key
|
#:key
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue