Add node management CLI and split Tribes launcher

README.md

@@ -44,5 +44,5 @@ For pinned bootstrap usage, generate a `channels.scm` that combines upstream
 Guix with this repository's current commit.
 
 The deployment scripts default to the checked-in base-channel lock at
-`pins/base-channels.sexpr`.  Refresh that lock intentionally with
+`pins/base-channels.sexp`.  Refresh that lock intentionally with
 `../guix-deploy/scripts/update-base-channels-pin`.

tribes/packages/cli.scm

@@ -0,0 +1,126 @@
+(define-module (tribes packages cli)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix build-system trivial)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:export (tribes-command-package))
+
+(define tribes-command-program
+  (program-file
+   "tribes"
+   #~(begin
+       (use-modules (ice-9 format)
+                    (ice-9 ftw)
+                    (ice-9 match)
+                    (ice-9 posix)
+                    (srfi srfi-1))
+
+       (define channels-file "/etc/tribes/channels.sexp")
+       (define host-config-file "/etc/tribes/host-config.sexp")
+       (define system-guix "/run/current-system/profile/bin/guix")
+
+       (define (home-directory)
+         (let ((entry (getpwuid (getuid))))
+           (if entry
+               (passwd:dir entry)
+               "/root")))
+
+       (define (pulled-guix)
+         (string-append (home-directory) "/.config/guix/current/bin/guix"))
+
+       (define (guix-binary)
+         (cond
+          ((file-exists? (pulled-guix)) (pulled-guix))
+          ((file-exists? system-guix) system-guix)
+          (else "guix")))
+
+       (define (print-usage port)
+         (format port "Usage: tribes <command>~%")
+         (format port "~%Commands:~%")
+         (format port "  help         Show this help.~%")
+         (format port "  os status    Show node update state.~%")
+         (format port "  os update    Pull channels and reconfigure the OS.~%"))
+
+       (define (require-root)
+         (unless (zero? (getuid))
+           (format (current-error-port)
+                   "tribes os update must run as root.~%")
+           (exit 1)))
+
+       (define (ensure-managed-file path)
+         (unless (file-exists? path)
+           (format (current-error-port)
+                   "missing managed file: ~a~%"
+                   path)
+           (exit 1)))
+
+       (define (run command . args)
+         (let ((status (apply system* command args)))
+           (if (and (integer? status) (zero? status))
+               0
+               (if (integer? status) status 1))))
+
+       (define (os-status)
+         (format #t "channels: ~a~%" channels-file)
+         (format #t "  exists: ~a~%" (file-exists? channels-file))
+         (format #t "host config: ~a~%" host-config-file)
+         (format #t "  exists: ~a~%" (file-exists? host-config-file))
+         (format #t "system guix: ~a~%" system-guix)
+         (format #t "  exists: ~a~%" (file-exists? system-guix))
+         (format #t "selected guix: ~a~%" (guix-binary))
+         (format #t "current system: ~a~%"
+                 (or (false-if-exception (readlink "/run/current-system"))
+                     "unknown"))
+         (exit (run (guix-binary) "describe")))
+
+       (define (os-update)
+         (require-root)
+         (ensure-managed-file channels-file)
+         (ensure-managed-file host-config-file)
+         (let ((bootstrap-guix (if (file-exists? system-guix)
+                                   system-guix
+                                   (guix-binary))))
+           (let ((pull-status
+                  (run bootstrap-guix
+                       "pull"
+                       "--allow-downgrades"
+                       "-C"
+                       channels-file)))
+             (unless (zero? pull-status)
+               (exit pull-status))))
+         (exit (run (guix-binary)
+                    "system"
+                    "reconfigure"
+                    host-config-file)))
+
+       (match (cdr (command-line))
+         (() (print-usage (current-output-port)))
+         (("help") (print-usage (current-output-port)))
+         (("os" "status") (os-status))
+         (("os" "update") (os-update))
+         (_
+          (print-usage (current-error-port))
+          (exit 1))))))
+
+(define tribes-command-package
+  (package
+    (name "tribes-command")
+    (version "0.1")
+    (source #f)
+    (build-system trivial-build-system)
+    (arguments
+     (list
+      #:modules '((guix build utils))
+      #:builder
+      #~(begin
+          (use-modules (guix build utils))
+          (let ((bin-dir (string-append #$output "/bin")))
+            (mkdir-p bin-dir)
+            (copy-file #+tribes-command-program
+                       (string-append bin-dir "/tribes"))
+            (chmod (string-append bin-dir "/tribes") #o555)))))
+    (home-page "https://git.teralink.net/tribes/guix-tribes.git")
+    (synopsis "Tribes node administration command")
+    (description
+     "Command-line helper for updating and inspecting a deployed Tribes node.")
+    (license license:asl2.0)))

tribes/packages/source.scm

@@ -38,7 +38,7 @@
   "https://git.teralink.net/tribes/tribes.git")
 
 (define %tribes-commit
-  "32c64bfba5bb3bf4741e37a3297b249c4cacc76e")
+  "1e026a60fdabcec8b9ec0a850a03f903d02496e7")
 
 (define %tribes-revision "1")
 
@@ -46,7 +46,7 @@
   (git-version "0.2.0" %tribes-revision %tribes-commit))
 
 (define %tribes-source-sha256
-  "08sx47qpis1h758iwmdnld9x8975wyp1fx96bmly0n723mhx3b60")
+  "1lqls1ngy3vpf0hh9jn44h1g9rx1hglj9ik3zi1ywcr4q01pmv68")
 
 (define %tribes-upstream-source
   (origin
@@ -283,7 +283,14 @@ using MIX-DEPS as the pre-fetched Mix dependency tree resolved from mix.lock."
            (if existing-erl-flags
                (setenv "ERL_FLAGS" existing-erl-flags)
                (unsetenv "ERL_FLAGS")))
-         (invoke "mix" "deps.compile")))))
+         (invoke "mix" "deps.compile"))
+     #:install-gexp
+     #~(begin
+         (invoke "mix" "release" "--no-deps-check" "--path" out)
+         (let ((launcher (string-append out "/bin/" #$name))
+               (launcher-app (string-append out "/bin/" #$name "-app")))
+           (when (file-exists? launcher)
+             (rename-file launcher launcher-app)))))))
 
 (define* (local-tribes-package directory
                                #:key

tribes/services/hitch.scm

@@ -1,5 +1,7 @@
 (define-module (tribes services hitch)
   #:use-module (gnu packages admin)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages linux)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system shadow)
@@ -7,6 +9,7 @@
   #:use-module (guix records)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-13)
   #:use-module (tribes packages web)
   #:export (hitch-configuration
             hitch-configuration?
@@ -78,7 +81,6 @@
        "ciphers = \"" ciphers "\"\n"
        "user = \"" user "\"\n"
        "group = \"" group "\"\n"
-       "pidfile = \"" pid-file "\"\n"
        "ocsp-dir = \"" ocsp-dir "\"\n"
        (string-concatenate
         (map (lambda (line)
@@ -91,9 +93,27 @@
       (mkdir-p "/var/run/hitch")
       (mkdir-p #$(hitch-configuration-ocsp-dir config))))
 
+(define (hitch-reload-procedure package)
+  #~(lambda _
+      (use-modules (ice-9 popen)
+                   (ice-9 rdelim))
+      (let* ((port (open-pipe* OPEN_READ
+                               #$(file-append procps "/bin/pidof")
+                               "hitch"))
+             (line (read-line port))
+             (status (close-pipe port)))
+        (and (zero? status)
+             (string? line)
+             (not (eof-object? line))
+             (let ((pid (string->number
+                         (car (string-tokenize line)))))
+               (and pid
+                    (zero? (system* #$(file-append coreutils "/bin/kill")
+                                    "-HUP"
+                                    (number->string pid)))))))))
+
 (define (hitch-shepherd-services config)
   (let ((config-file (hitch-config-file config))
-        (pid-file (hitch-configuration-pid-file config))
         (package (hitch-configuration-package config)))
     (list
      (shepherd-service
@@ -103,22 +123,15 @@
       (start
        #~(make-forkexec-constructor
           (list #$(file-append package "/sbin/hitch")
-                "--daemon"
                 "--config"
-                #$config-file)
+                #$config-file)))
-          #:pid-file #$pid-file))
       (stop #~(make-kill-destructor))
       (actions
        (list
         (shepherd-action
          (name 'reload)
          (documentation "Reload Hitch certificates and listeners.")
-         (procedure
+         (procedure (hitch-reload-procedure package)))))))))
-          #~(lambda _
-              (use-modules (ice-9 posix))
-              (let ((pid (call-with-input-file #$pid-file read)))
-                (kill pid SIGHUP)
-                #t))))))))))
 
 (define hitch-service-type
   (service-type

tribes/services/tribes.scm

@@ -13,6 +13,7 @@
   #:use-module (guix records)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-13)
+  #:use-module (tribes packages cli)
   #:use-module (tribes packages terminals)
   #:export (tribes-configuration
             tribes-configuration?
@@ -241,8 +242,8 @@
        (setenv "RELEASE_COOKIE" (read-secret release-cookie-file))
        #$@env-setters
        (apply execl
-              #$(file-append package "/bin/tribes")
+              #$(file-append package "/bin/tribes-app")
-              "tribes"
+              "tribes-app"
               (cons #$command '#$args)))))
 
 (define (tribes-activation config)
@@ -306,8 +307,16 @@
 
 (define (tribes-profile-packages config)
   (match (tribes-configuration-package config)
-    (#f (list rsync ripgrep fd tmux neovim btop ghostty-terminfo))
+    (#f (list tribes-command-package
+              rsync
+              ripgrep
+              fd
+              tmux
+              neovim
+              btop
+              ghostty-terminfo))
     (package (list package
+                   tribes-command-package
                    rsync
                    ripgrep
                    fd

tribes/services/vinyl.scm

@@ -75,8 +75,7 @@
      (match config
        (($ <vinyl-configuration> package name backend vcl listen storage
                                  parameters extra-options)
-        (let ((state-dir (vinyl-state-directory name))
+        (let ((state-dir (vinyl-state-directory name)))
-              (pid-file (string-append (vinyl-state-directory name) "/_.pid")))
           (list
            (shepherd-service
             (documentation (string-append "Run the Vinyl cache service (" name ")."))
@@ -85,9 +84,9 @@
             (start
              #~(make-forkexec-constructor
                 (list #$(file-append package "/sbin/vinyld")
+                      "-F"
                       "-n" #$state-dir
                       "-i" #$name
-                      "-P" #$pid-file
                       #$@(if vcl
                              #~("-f" #$vcl)
                              #~("-b" #$backend))
@@ -103,8 +102,7 @@
                                                      (car parameter)
                                                      (cdr parameter))))
                                      parameters)
-                      #$@extra-options)
+                      #$@extra-options)))
-                #:pid-file #$pid-file))
             (stop #~(make-kill-destructor))))))))
    configs))