ci.scm (9202B)
1 (define-module (mt system andrew ci) 2 #:use-module (guix gexp) 3 #:use-module (guix modules) 4 #:use-module (gnu services) 5 #:use-module (gnu services shepherd) 6 #:use-module (gnu packages version-control) 7 #:export (update-channels-locked-service-type)) 8 9 ;;; CI 10 11 ;; TODO: Integrate with the gitolite-service-type 12 13 ;; TODO: Integrate VREFs 14 15 (define (update-channels-locked-shepherd-service config) 16 (define gitolite-home "/var/lib/gitolite") 17 18 (define code 19 (let ((gitolite-bin (file-append gitolite "/bin/gitolite")) 20 (git-bin (file-append git "/bin/git"))) 21 (with-imported-modules (source-module-closure '((guix build utils))) 22 #~(begin 23 (use-modules (guix build utils) 24 (ice-9 rdelim) 25 (ice-9 popen) 26 (ice-9 ftw) 27 (rnrs io ports)) 28 29 (setvbuf (current-output-port) 'line) 30 (setvbuf (current-error-port) 'line) 31 32 ;; Utility functions 33 (define (collect-lines port) 34 "Collect all lines from a port in a list" 35 (let loop ((line (read-line port)) 36 (acc '())) 37 (if (eof-object? line) 38 (begin (close-port port) 39 acc) 40 (loop (read-line port) 41 (cons line acc))))) 42 43 (define (spawn* prog args search) 44 "Spawn a program and return success as #t or #f" 45 (zero? (cdr (waitpid 46 (spawn prog args 47 #:search-path? #t))))) 48 49 (define (repo-path name) 50 (string-append #$gitolite-home "/repositories/" name ".git")) 51 52 ;; Main code 53 (let ((ogdir (getcwd)) 54 (channeldir (mkdtemp "/tmp/mt-channel-XXXXXX"))) 55 ;; Initial setup 56 (unless (and (spawn* #$git-bin 57 (list "git" "clone" "--shared" 58 (repo-path "channel") 59 channeldir) 60 #f) 61 (spawn* "guix" 62 (list "guix" "pull" "-C" 63 (string-append channeldir 64 "/mt/channels.scm")) 65 #t) 66 (call-with-output-file 67 (string-append channeldir "/mt/channels-locked.scm") 68 (lambda (out) 69 (display "\ 70 (define-module (mt channels-locked) 71 #:use-module (guix channels) 72 #:export (%mt-channels-locked)) 73 74 (define %mt-channels-locked\n" out) 75 (flush-output-port out) 76 (let ((result (waitpid 77 (spawn "guix" 78 '("guix" "describe" 79 "--format=channels") 80 #:output out)))) 81 (display ")\n\n%mt-channels-locked\n" out) 82 (flush-output-port out) 83 (zero? (cdr result)))))) 84 (display "Failed to pull / write new channels!\n" 85 (current-error-port)) 86 (delete-file-recursively channeldir) 87 (exit 1)) 88 89 ;; Iterate over clients 90 (let ((output-pipe (pipe))) 91 (spawn #$gitolite-bin 92 '("gitolite" "list-members" "@client-repos") 93 #:output (cdr output-pipe) 94 #:search-path? #f) 95 (close-port (cdr output-pipe)) 96 97 (for-each 98 (lambda (name) 99 (let* ((configdir (mkdtemp "/tmp/mt-config-XXXXXX")) 100 (systemdir (string-append configdir "/system/")) 101 (homedir (string-append configdir "/home/"))) 102 (if (spawn* #$git-bin 103 (list "git" "clone" 104 "--shared" 105 (repo-path name) 106 configdir) 107 #f) 108 (begin 109 (format #t "Building ~a's system configurations...\n" name) 110 (for-each 111 (lambda (file) 112 (format #t "~a: Building \"~a\"...\n" name file) 113 (if (spawn* "guix" 114 (list "guix" "system" "build" 115 "-L" channeldir 116 "-L" configdir 117 "--verbosity=0" 118 (string-append systemdir file)) 119 #t) 120 (format #t "~a: Built \"~a\"!\n" name file) 121 (format #t "~a: Failed to build \"~a\"!\n" name file))) 122 (scandir systemdir 123 (lambda (file) 124 (string-suffix? ".scm" file)))) 125 126 (format #t "Building ~a's home configurations...\n" name) 127 (for-each 128 (lambda (file) 129 (format #t "~a: Building \"~a\"...\n" name file) 130 (if (spawn* "guix" 131 (list "guix" "home" "build" 132 "-L" channeldir 133 "-L" configdir 134 "--verbosity=0" 135 (string-append homedir file)) 136 #t) 137 (format #t "~a: Built \"~a\"!\n" name file) 138 (format #t "~a: Failed to build \"~a\"!\n" name file))) 139 (scandir homedir 140 (lambda (file) 141 (string-suffix? ".scm" file))))) 142 (format #t "Failed to clone ~a repo! Skipping...\n" name)) 143 144 ;; Cleanup 145 (delete-file-recursively configdir))) 146 (collect-lines (car output-pipe)))) 147 148 ;; Push changes 149 (chdir channeldir) 150 (unless (and (spawn* #$git-bin 151 '("git" "add" 152 "mt/channels-locked.scm") 153 #f) 154 (spawn* #$git-bin 155 '("git" "commit" 156 "-m" "channels: %mt-channels-locked") 157 #f) 158 (spawn* #$gitolite-bin 159 '("gitolite" "push") 160 #f)) 161 (display "Failed to push changes!\n" (current-error-port))) 162 (chdir ogdir) 163 164 ;; Cleanup 165 (delete-file-recursively channeldir)))))) 166 167 (list (shepherd-service 168 (provision '(update-channels-locked)) 169 (requirement '(user-processes networking)) 170 (modules '((shepherd service timer))) 171 (start #~(make-timer-constructor 172 (calendar-event #:hours '(0) #:minutes '(0) 173 #:days-of-week '(sunday)) 174 (command `(#$(program-file "update-channels-locked" code)) 175 ;; We need to use the user's current guix version, 176 ;; and the system default if there's not one yet. 177 #:environment-variables 178 `(#$(string-append "PATH=" gitolite-home "/.config/guix/current/bin" 179 ":" "/run/current-system/profile/bin") 180 #$(string-append "HOME=" gitolite-home)) 181 #:user "git" 182 #:group "git") 183 #:log-file "/var/log/update-channels-locked.log" 184 #:wait-for-termination? #t)) 185 (stop #~(make-timer-destructor)) 186 (actions (list shepherd-trigger-action))))) 187 188 (define update-channels-locked-service-type 189 (service-type 190 (name 'update-channels-locked) 191 (extensions 192 (list (service-extension shepherd-root-service-type 193 update-channels-locked-shepherd-service))) 194 (description "Update the locked channels and build user configurations.") 195 (default-value '())))