summaryrefslogtreecommitdiff
path: root/gnu/system.scm
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2020-05-05 20:43:21 +0200
committerMarius Bakke <mbakke@fastmail.com>2020-05-05 20:43:21 +0200
commit87a40d7203a813921b3ef0805c2b46c0026d6c31 (patch)
treecebad70c1df30969005c18c4d9faa39d7d80cbf6 /gnu/system.scm
parentba151b7e1a9cc0baf932b5c5e0c916e54d2e27f4 (diff)
parent751d1f01e4f0607d41e4c859d944753b18466652 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'gnu/system.scm')
-rw-r--r--gnu/system.scm50
1 files changed, 50 insertions, 0 deletions
diff --git a/gnu/system.scm b/gnu/system.scm
index 99ce66aa4f..cd75e4d4ba 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -120,6 +120,7 @@
operating-system-etc-directory
operating-system-locale-directory
operating-system-boot-script
+ operating-system-uuid
system-linux-image-file-name
operating-system-with-gc-roots
@@ -984,6 +985,55 @@ we're running in the final root."
#:mapped-devices mapped-devices
#: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)
"Variant of 'locale-name->definition' that raises an error upon failure."
(match (locale-name->definition name)