modules/rosenthal/packages/binaries.scm

@@ -11,13 +11,11 @@
   #:use-module (guix gexp)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix packages)
-  #:use-module (guix platform)
   #:use-module (guix utils)
   #:use-module (rosenthal utils packages)
   ;; Guix origin methods
   #:use-module (guix download)
   ;; Guix build systems
-  #:use-module (guix build-system gnu)
   #:use-module (guix build-system copy)
   ;; Guix packages
   #:use-module (gnu packages base)
@@ -485,49 +483,52 @@ rather a set of labels for each log stream.")
                 "1pxnjzygm2mylipf6cjkqxm4k3i9vnm7v80avxbhv8400p3aszqk"))))))
 
 (define-public alloy-bin
-  (binary-package
-   `(("x86_64-linux"  . ,%alloy-source-x86_64-linux)
-     ("aarch64-linux" . ,%alloy-source-aarch64-linux))
   (package
     (name "alloy-bin")
-     (version "")
+    (version (package-version %alloy-source-x86_64-linux))
     (source #f)
-     (build-system gnu-build-system)
+    (build-system copy-build-system)
     (arguments
+     (let ((binary-source
+            (match (or (%current-target-system)
+                       (%current-system))
+              ((? target-aarch64?)
+               (package-source %alloy-source-aarch64-linux))
+              (_
+               (package-source %alloy-source-x86_64-linux)))))
        (list
+        #:install-plan
+        (match (or (%current-target-system)
+                   (%current-system))
+          ((? target-aarch64?)
+           #~'(("alloy-linux-arm64" "bin/alloy")))
+          (_
+           #~'(("alloy-linux-amd64" "bin/alloy"))))
         #:modules
-       `((ice-9 match)
+        '((ice-9 match)
-         ,@%default-gnu-modules)
+          (guix build copy-build-system)
+          (guix build utils))
         #:phases
         #~(modify-phases %standard-phases
-           (delete 'bootstrap)
+            (replace 'unpack
-           (delete 'configure)
-           (delete 'build)
-           (delete 'check)
-           (replace 'install
               (lambda _
-               (let ((src #$(mapping-for-system
+                ((assoc-ref %standard-phases 'unpack)
-                             '(("x86_64-linux"  . "alloy-linux-amd64")
+                 #:source #+binary-source)))
-                               ("aarch64-linux" . "alloy-linux-arm64"))))
-                     (dst (in-vicinity #$output "bin/alloy")))
-                 (mkdir-p (dirname dst))
-                 (copy-file src dst))))
             (add-after 'install 'patch-elf
-             (lambda* (#:key inputs #:allow-other-keys)
+              (lambda _
-               (let ((ld.so (search-input-file inputs #$(glibc-dynamic-linker)))
+                (let ((name "alloy")
                       (dest (in-vicinity #$output "bin"))
-                     (name "alloy"))
+                      (ld.so #$(file-append glibc (glibc-dynamic-linker))))
                   (with-directory-excursion dest
                     (invoke "patchelf" "--set-interpreter" ld.so name)
                     (chmod name #o555)))))
             (add-after 'patch-elf 'install-extras
-             (lambda* (#:key native-inputs inputs outputs #:allow-other-keys)
+              (lambda* (#:key native-inputs inputs #:allow-other-keys)
                 (let ((alloy
-                      (search-input-file
                        (if #$(%current-target-system)
-                           native-inputs
+                           (search-input-file (or native-inputs inputs)
-                           outputs)
+                                              "bin/alloy")
-                       "bin/alloy")))
+                           (in-vicinity #$output "bin/alloy"))))
                   (for-each
                    (match-lambda
                      ((shell . file)
@@ -537,7 +538,7 @@ rather a set of labels for each log stream.")
                           (invoke alloy "completion" shell)))))
                    '(("bash" . "share/bash-completion/completions/alloy")
                      ("fish" . "share/fish/vendor_completions.d/alloy.fish")
-                    ("zsh"  . "share/zsh/site-functions/_alloy")))))))))
+                     ("zsh"  . "share/zsh/site-functions/_alloy"))))))))))
     (native-inputs
      (append (if (%current-target-system)
                  (list this-package)
@@ -551,6 +552,7 @@ rather a set of labels for each log stream.")
      "Grafana Alloy is an open source OpenTelemetry Collector distribution with
 built-in Prometheus pipelines and support for metrics, logs, traces, and
 profiles.")
-     (license license:agpl3))))
+    (license license:agpl3)
+    (properties '((disable-updater? . #t)))))
 
 (define-deprecated-package alloy-bin-aarch64-linux alloy-bin)

modules/rosenthal/packages/emacs-xyz.scm

@@ -82,28 +82,6 @@ end the search.  Moreover, the search status information in the echo area and
 some keybindings are slightly simplified.")
     (license license:gpl3+)))
 
-(define-public emacs-kdl-mode
-  (let ((commit "2d849e298199f490e4894c01764a8a83decd704a")
-        (revision "0"))
-    (package
-      (name "emacs-kdl-mode")
-      (version (git-version "0.0.1" revision commit))
-      (source (origin
-                (method git-fetch)
-                (uri (git-reference
-                       (url "https://github.com/taquangtrung/emacs-kdl-mode")
-                       (commit commit)))
-                (file-name (git-file-name name version))
-                (sha256
-                 (base32
-                  "18va5ipay9grbv84kwq9ji4dn1sabnzydj4hb1mjd9mbbibw1wg4"))))
-      (build-system emacs-build-system)
-      (arguments (list #:tests? #f))    ;No tests.
-      (home-page "https://github.com/taquangtrung/emacs-kdl-mode")
-      (synopsis "Emacs major mode for editing files in the KDL document language")
-      (description "")
-      (license license:gpl3+))))
-
 (define-public emacs-pcmpl-tailscale
   (let ((commit "acd6bce54af506b0450cf6aa1068f63d4e25c8ce")
         (revision "0"))

modules/rosenthal/services/desktop.scm

@@ -74,6 +74,7 @@
             home-waybar-configuration
             home-waybar-service-type
 
+            %rosenthal-set-keymap
             %rosenthal-skeletons
             %rosenthal-desktop-services/gdm
             %rosenthal-desktop-services/tuigreet
@@ -550,6 +551,116 @@ gtk-key-theme-name = ~a~%"
 ;;; Configuration file presets.
 ;;;
 
+(define %rosenthal-set-keymap-script
+  (program-file "set-keymap"
+    (with-imported-modules (source-module-closure '((guix build utils)))
+      #~(begin
+          (use-modules (srfi srfi-1)
+                       (srfi srfi-26)
+                       (srfi srfi-37)
+                       (ice-9 match)
+                       (ice-9 popen)
+                       (guix build utils))
+
+          (define* (build-keyboard-layout file layout #:optional variant #:key model options)
+            (define pipe
+              (apply open-pipe* OPEN_READ
+                     #$(file-append console-setup "/bin/ckbcomp")
+                     (string-append "-I" #$xkeyboard-config "/share/X11/xkb")
+                     "-rules" "base"
+                     `(,@(if model
+                             '("-model" ,model)
+                             '())
+                       ,layout
+                       ,(or variant "")
+                       ,(string-join options ","))))
+            (mkdir-p (dirname file))
+            (call-with-output-file file
+              (lambda (output)
+                (dump-port pipe output))))
+
+          (define* (set-keyboard-layout layout #:optional variant #:key model options)
+            (define file-name
+              (port-filename
+               (mkstemp "/tmp/console-keymap.XXXXXX")))
+            (build-keyboard-layout file-name layout variant #:model model #:options options)
+            (invoke "sudo" #$(file-append kbd "/bin/loadkeys") file-name)
+            (false-if-exception
+             (substitute*
+                 (in-vicinity
+                  (if (zero? (getuid))
+                      "/home/live/.config"
+                      (getenv "XDG_CONFIG_HOME"))
+                  "niri/config.kdl")
+               (("^            (layout|variant|model|options) .*") "")
+               (("^        xkb \\{.*" line)
+                (string-append
+                 line
+                 (format             #f "            layout ~s~%"  layout)
+                 (if variant (format #f "            variant ~s~%" variant) "")
+                 (if model   (format #f "            model ~s~%"   model)   "")
+                 (format             #f "            options ~s~%" (string-join options ",")))))))
+
+          (define (show-help-and-exit)
+            (display "\
+Usage: set-keymap LAYOUT [VARIANT] [-m MODEL] [-o OPTIONS]
+
+OPTIONS are comma-separated e.g. \"ctrl:nocaps,grp:alt_shift_toggle\"
+
+Examples:
+set-keymap us
+set-keymap us dvorak
+set-keymap us dvorak -o ctrl:nocaps\n")
+            (quit))
+
+          (define (parse-options)
+            (args-fold (cdr (program-arguments))
+                       (list (option '(#\m "model") #t #f
+                                     (lambda (opt name arg result)
+                                       (alist-cons 'model arg result)))
+                             (option '(#\o "options") #t #f
+                                     (lambda (opt name arg result)
+                                       (alist-cons 'options (string-split arg #\,)
+                                                   result)))
+                             (option '("help") #f #f
+                                     (lambda _
+                                       (show-help-and-exit))))
+                       (lambda (opt name arg loads)
+                         (error "Unrecognized option `~A'" name))
+                       (lambda (opt loads) (cons opt loads))
+                       '()))
+
+          (let* ((opts (parse-options))
+                 (model (assoc-ref opts 'model))
+                 (options (or (assoc-ref opts 'options) '()))
+                 (args (remove pair? (reverse opts))))
+            (match args
+              ((layout)
+               (set-keyboard-layout layout #:model model #:options options))
+              ((layout variant)
+               (set-keyboard-layout layout variant #:model model #:options options))
+              (_
+               (show-help-and-exit))))))))
+
+(define %rosenthal-set-keymap
+  (hidden-package
+   (package
+     (name "rosenthal-set-keymap")
+     (version "0.0.0")
+     (source %rosenthal-set-keymap-script)
+     (build-system copy-build-system)
+     (arguments
+      (list
+       #:phases
+       #~(modify-phases %standard-phases
+           (replace 'install
+             (lambda _
+               (install-file "set-keymap" (in-vicinity #$output "bin")))))))
+     (home-page "")
+     (synopsis "")
+     (description "")
+     (license #f))))
+
 (define %rosenthal-skeletons
   `((".config/emacs/init.el"
      ,(local-file "../examples/emacs/init.el"))

modules/rosenthal/utils/packages.scm

@@ -11,13 +11,10 @@
   #:use-module (guix deprecation)
   #:use-module (guix diagnostics)
   #:use-module (guix discovery)
-  #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix memoization)
   #:use-module (guix packages)
-  #:use-module (guix platform)
   #:use-module (guix ui)
-  #:use-module (guix utils)
   ;; Guix packages
   #:use-module (gnu packages)
   #:use-module (gnu packages base)
@@ -35,9 +32,7 @@
             specs->pkgs
             specs->pkgs+out
 
-            %binary-source
+            %binary-source))
-            binary-package
-            mapping-for-system))
 
 (define %rosenthal-root-directory
   ;; This is like %distro-root-directory from (gnu packages), with adjusted
@@ -150,33 +145,4 @@ packages, excluding superseded packages."
   (hidden-package
    (package
      (inherit hello)
-     (supported-systems '())
+     (supported-systems '()))))
-     (home-page "")
-     (synopsis "Binary package source (internal use)")
-     (description "")
-     (license #f))))
-
-(define* (mapping-for-system mapping #:optional (default-system "x86_64-linux"))
-  (let ((system
-         (or (and=> (%current-target-system) platform-target->system)
-             (%current-system))))
-    (or (assoc-ref mapping system)
-        (assoc-ref mapping default-system))))
-
-(define* (binary-package source-mapping p #:optional (default-system "x86_64-linux"))
-  (package
-    (inherit p)
-    (version (package-version (assoc-ref source-mapping default-system)))
-    (source #f)
-    (arguments
-     (substitute-keyword-arguments (package-arguments p)
-       ((#:phases phases #~%standard-phases)
-        #~(modify-phases #$phases
-            (replace 'unpack
-              (lambda _
-                ((assoc-ref %standard-phases 'unpack)
-                 #:source
-                 #+(package-source (mapping-for-system source-mapping)))))))))
-    (properties
-     (cons '(disable-updater? . #t)
-           (package-properties p)))))