commit c1720769d3147535c3fb708161b49c3d7f036371
parent 76858693fbf9f334ed3cab29ef2824317be5c364
Author: Luke Willis <lukejw@monastech.xyz>
Date: Thu, 30 Apr 2026 21:31:12 -0400
andrew: Setup update-channels-locked-service
Diffstat:
4 files changed, 257 insertions(+), 5 deletions(-)
diff --git a/mt/channels-locked.scm b/mt/channels-locked.scm
@@ -1,3 +1,8 @@
+(define-module (mt channels-locked)
+ #:use-module (guix channels)
+ #:export (%mt-channels-locked))
+
+(define %mt-channels-locked
(list (channel
(name 'nonguix)
(url "https://gitlab.com/nonguix/nonguix")
@@ -18,3 +23,6 @@
"9edb3f66fd807b096b48283debdcddccfea34bad"
(openpgp-fingerprint
"BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA")))))
+)
+
+%mt-channels-locked
diff --git a/mt/channels.scm b/mt/channels.scm
@@ -3,7 +3,7 @@
#:use-module (guix channels)
#:use-module (guix gexp)
#:export (%mt-channels
- %mt-channels-locked
+ ;%mt-channels-locked
%mt-substitute-urls
%mt-authorized-guix-keys))
@@ -26,9 +26,6 @@
(openpgp-fingerprint
"BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA"))))))
-(define %mt-channels-locked
- (include "channels-locked.scm"))
-
(define %mt-substitute-urls
`("https://substitutes.monastech.xyz"
,@%default-substitute-urls
diff --git a/mt/services.scm b/mt/services.scm
@@ -16,6 +16,7 @@
#:use-module (gnu system)
#:use-module (gnu system privilege)
#:use-module (mt channels)
+ #:use-module (mt channels-locked)
#:export (etc-mt-client-service
tuigreet-login-manager
greetd-helper-service
diff --git a/mt/system/andrew.scm b/mt/system/andrew.scm
@@ -1,18 +1,21 @@
(define-module (mt system andrew)
#:use-module (guix gexp)
#:use-module (guix packages)
+ #:use-module (guix modules)
#:use-module (guix git)
#:use-module (gnu bootloader)
#:use-module (gnu bootloader grub)
#:use-module (gnu services)
#:use-module (gnu services certbot)
#:use-module (gnu services version-control)
+ #:use-module (gnu services shepherd)
#:use-module (gnu services web)
#:use-module (gnu system)
#:use-module (gnu system keyboard)
#:use-module (gnu system shadow)
#:use-module (gnu packages rsync)
#:use-module (gnu packages version-control)
+ #:use-module (gnu packages wget)
#:use-module (nongnu packages linux)
#:use-module (nongnu system linux-initrd)
#:use-module (mt services)
@@ -21,6 +24,248 @@
#:use-module (mt artwork)
#:export (andrew-os))
+;;;
+;;; Updating stuff
+;;;
+
+;; TODO: Rewrite into some kind of codegen-service-type?
+
+(define (update-channels-locked-shepherd-service config)
+ (define gitolite-home "/var/lib/gitolite")
+
+ (define code
+ (let ((gitolite-bin (file-append gitolite "/bin/gitolite"))
+ (git-bin (file-append git "/bin/git"))
+ (wget-bin (file-append wget "/bin/wget")))
+ (with-imported-modules (source-module-closure '((guix build utils)))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 rdelim)
+ (ice-9 popen)
+ (ice-9 ftw)
+ (rnrs io ports))
+
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line)
+
+ ;; Utility functions
+ (define (collect-lines port)
+ "Collect all lines from a port in a list"
+ (let loop ((line (read-line port))
+ (acc '()))
+ (if (eof-object? line)
+ (begin (close-port port)
+ acc)
+ (loop (read-line port)
+ (cons line acc)))))
+
+ (define (spawn* prog args search)
+ "Spawn a program and return success as #t or #f"
+ (zero? (cdr (waitpid
+ (spawn prog args
+ #:search-path? #t)))))
+
+ (define (repo-path name)
+ (string-append #$gitolite-home "/repositories/" name ".git"))
+
+ ;; Main code
+ (let ((ogdir (getcwd))
+ (channeldir (mkdtemp "/tmp/mt-channel-XXXXXX")))
+ ;; Initial setup
+ (unless (and (spawn* #$git-bin
+ (list "git" "clone" "--shared"
+ (repo-path "channel")
+ channeldir)
+ #f)
+ ;; hosts.scm codegen
+ (call-with-output-file
+ (string-append channeldir "/mt/hosts.scm")
+ (lambda (file)
+ (display "\
+(define-module (mt hosts)
+ #:use-module (gnu services base)
+ #:export (%hosts-porn-social-only))
+
+(define %hosts-porn-social-only
+ (list" file)
+ (flush-output-port file)
+
+ (let ((output-pipe (pipe)))
+ (spawn #$wget-bin
+ '("wget" "-qO" "-"
+ "https://raw.githubusercontent.com/StevenBlack/hosts/master/alternates/porn-social-only/hosts")
+ #:output (cdr output-pipe)
+ #:search-path? #f)
+ (close-port (cdr output-pipe))
+ (while #t
+ (let ((line (read-line (car output-pipe))))
+ (if (eof-object? line)
+ (break)
+ (unless (or (string-null? line)
+ (string-prefix? "#" line))
+ (display "\n " file)
+ (write (cons 'host (list-head (string-tokenize line) 2))
+ file))))))
+ (display "))\n" file)
+ (flush-output-port file)
+ #t))
+ ;; Update channels
+ ;; TODO: Uncomment when done testing
+ (spawn* "guix"
+ (list "guix" "pull" "-C"
+ (string-append channeldir
+ "/mt/channels.scm"))
+ #t)
+ (call-with-output-file
+ (string-append channeldir "/mt/channels-locked.scm")
+ (lambda (out)
+ (display "\
+(define-module (mt channels-locked)
+ #:use-module (guix channels)
+ #:export (%mt-channels-locked))
+
+(define %mt-channels-locked\n" out)
+ (flush-output-port out)
+ (let ((result (waitpid
+ (spawn "guix"
+ '("guix" "describe"
+ "--format=channels")
+ #:output out))))
+ (display ")\n\n%mt-channels-locked\n" out)
+ (flush-output-port out)
+ (zero? (cdr result))))))
+ (display "Failed to pull and write new channels!\n"
+ (current-error-port))
+ (exit 1))
+
+ ;; Iterate over client configurations
+ (let ((output-pipe (pipe)))
+ (spawn #$gitolite-bin
+ '("gitolite" "list-members" "@client-repos")
+ #:output (cdr output-pipe)
+ #:search-path? #f)
+ (close-port (cdr output-pipe))
+
+ (for-each
+ (lambda (name)
+ (let* ((configdir (mkdtemp "/tmp/mt-config-XXXXXX"))
+ (systemdir (string-append configdir "/system/")))
+ (if (spawn* #$git-bin
+ (list "git" "clone"
+ "--shared"
+ (repo-path name)
+ configdir)
+ #f)
+ (begin
+ (format #t "Building ~a configurations...\n" name)
+
+ ;; System configurations
+ (for-each
+ (lambda (file)
+ (format #t "~a: Building system ~a...\n" name file)
+ (if (spawn* "guix"
+ (list "guix" "system" "build"
+ "-L" channeldir
+ "-L" configdir
+ ;"--verbosity=0"
+ (string-append systemdir file))
+ #t)
+ (format #t "~a: Built system ~a!\n" name file)
+ (format #t "~a: Failed to build system ~a!\n" name file)))
+ (scandir systemdir
+ (lambda (file)
+ (string-suffix? ".scm" file)))))
+ (format #t "Failed to clone ~a repo! Skipping...\n" name))
+
+ ;; Cleanup
+ (delete-file-recursively configdir)))
+ (collect-lines (car output-pipe))))
+
+ ;; Push changes
+ (chdir channeldir)
+ (unless (and (spawn* #$git-bin
+ '("git" "add"
+ "mt/channels-locked.scm")
+ #f)
+ (spawn* #$git-bin
+ '("git" "commit"
+ "-m" "channels: %mt-channels-locked")
+ #f)
+ (spawn* #$git-bin
+ '("git" "add"
+ "mt/hosts.scm")
+ #f)
+ (spawn* #$git-bin
+ '("git" "commit"
+ "-m" "hosts: Update blacklists")
+ #f)
+ (spawn* #$gitolite-bin
+ '("gitolite" "push")
+ #f))
+ (display "Failed to push changes!\n" (current-error-port))
+ (exit 1))
+ (chdir ogdir)
+
+ ;; Cleanup
+ (delete-file-recursively channeldir))))))
+
+ (list (shepherd-service
+ (provision '(update-channels-locked))
+ (requirement '(user-processes networking))
+ (modules '((shepherd service timer)))
+ (start #~(make-timer-constructor
+ (calendar-event #:hours '(0) #:minutes '(0)
+ #:days-of-week '(sunday))
+ (command `(#$(program-file "update-channels-locked" code))
+ ;; We need to use the user's current guix version,
+ ;; and the system default if there's not one yet.
+ #:environment-variables
+ `(#$(string-append "PATH=" gitolite-home "/.config/guix/current/bin"
+ ":" "/run/current-system/profile/bin")
+ #$(string-append "HOME=" gitolite-home))
+ #:user "git"
+ #:group "git")
+ #:log-file "/var/log/update-channels-locked.log"
+ #:wait-for-termination? #t))
+ (stop #~(make-timer-destructor))
+ (actions (list shepherd-trigger-action)))))
+
+(define update-channels-locked-service-type
+ (service-type
+ (name 'update-channels-locked)
+ (extensions
+ (list (service-extension shepherd-root-service-type
+ update-channels-locked-shepherd-service)))
+ (description "Update the locked channels and build user configurations.")
+ (default-value '())))
+
+ ;; Collect list of client configurations
+ ;;(let* ((output-pipe (pipe))
+ ;; (pid (spawn #$(file-append gitolite "/bin/gitolite")
+ ;; '("gitolite" "list-members" "@client-repos")
+ ;; #:output (cdr output-pipe)
+ ;; #:search-path? #f)))
+ ;; (close-port (cdr output-pipe))
+ ;; ;; Attempt to build each
+ ;; (for-each
+ ;; (lambda (name)
+ ;; ;; Clone configuration to current dir
+ ;; (spawn* #$(file-append git "/bin/git")
+ ;; (list "git" "clone"
+ ;; "--shared"
+ ;; (repo-path name))
+ ;; #f)
+ ;; ;; TODO: Build them
+ ;;
+ ;; ;; Cleanup
+ ;; (delete-file-recursively name)
+ ;; )
+ ;; (collect-lines (car output-pipe))))
+
+;;;
+;;; OS Configuration
+;;;
+
(define %issue "
Welcome to \"andrew\" the, first MonasTech server.
")
@@ -65,7 +310,8 @@ Welcome to \"andrew\" the, first MonasTech server.
(services
(append
- (list (service nginx-service-type
+ (list (service update-channels-locked-service-type '())
+ (service nginx-service-type
(nginx-configuration
(server-blocks
(list (nginx-server-configuration
