~ruther/guix-config: feat: gc root operating system non grafted os without new store connections

b30ce989dbc0261cc28601ae1ad19ef22babaf72 — Rutherther 5 days ago 5d24039

feat: gc root operating system non grafted os without new store connections

Multiple store connections are bad, especially if they are
unnecessary, which is like always. I just didn't know how to make it
without them, now I do. So this commit does that. But still, the
non-grafting is behaving strangely, the derivations aren't the same as
with --no-grafts.

patch browse .tar.gz

1 files changed, 36 insertions(+), 13 deletions(-)

M config.scm

M config.scm => config.scm +36 -13

@@ 237,6 237,40 @@
     ;; Allow resolution of '.local' host names with mDNS.
     (name-service-switch %mdns-host-lookup-nss)))
 
+(define (derivation->drv-name drv)
+  (mlet* %store-monad
+      ((drv drv))
+    (return (derivation-file-name drv))))
+
+(use-modules (srfi srfi-9)
+             (ice-9 match)
+             (guix records))
+
+(define-record-type <non-grafted>
+  (non-grafted derivation)
+  non-grafted?
+  (derivation non-grafted-derivation))
+
+(define-gexp-compiler (non-grafted-compiler (non-grafted <non-grafted>) system target)
+  (without-grafting (non-grafted-derivation non-grafted)))
+
+(define-record-type* <drv-name>
+  drv-name-record drv-name
+  drv-name?
+  (derivation drv-name-derivation)
+  (override-grafts? drv-name-override-grafts?
+                    (default #f)))
+
+(define-gexp-compiler (drv-name-compiler (drv-name <drv-name>) system target)
+  (let ((drv-name-store (derivation->drv-name (drv-name-derivation drv-name))))
+    (if (drv-name-override-grafts? drv-name)
+        (without-grafting drv-name-store)
+        drv-name-store)))
+
+(define <operating-system> (@@ (gnu system) <operating-system>))
+(define-gexp-compiler (os-compiler (os <operating-system>) system target)
+  (operating-system-derivation os))
+
 ;; Takes an operating system and gc roots its derivation
 (define (operating-system-with-build-inputs os)
   (operating-system


@@ 247,19 281,8 @@
       (simple-service 'gc-root-system-derivation
                       gc-root-service-type
                       (list
-                       (derivation-file-name
-                        (with-store %store
-                          (run-with-store %store
-                            (operating-system-derivation os))))
-                       (with-store %store
-                         (run-with-store %store
-                           (without-grafting
-                            (operating-system-derivation os))))
-                       (derivation-file-name
-                        (with-store %store
-                          (run-with-store %store
-                            (without-grafting
-                             (operating-system-derivation os)))))))
+                       (drv-name (operating-system-derivation os) #t)
+                       (non-grafted (operating-system-derivation os))))
       (operating-system-user-services os)))))
 
 (operating-system-with-build-inputs %ruther/base-laptop-os)