add autocommit tooling, update commits

1 files changed, 268 insertions, 0 deletions

diff --git a/scripts/update-commits b/scripts/update-commits
new file mode 100755
index 0000000..9302dcb
--- /dev/null
+++ b/scripts/update-commits
@@ -0,0 +1,268 @@
+#!/run/current-system/profile/bin/guile -s
+!#
+
+(use-modules (guix)
+             (guix channels)
+             (guix import json)
+             (guix git)
+             (ice-9 popen)
+             (ice-9 textual-ports)
+             (ice-9 pretty-print)
+             (srfi srfi-1)) ;; alist
+
+;;
+;; config
+;;
+
+(define %dotfiles-dir
+  (string-append
+    (getenv "HOME")
+    "/.config/guix"))
+
+(define %guix-channels-file
+  (string-append %dotfiles-dir "/channels.scm"))
+
+(define %nix-flake-file
+  (string-append %dotfiles-dir "/home/nix/flake.nix"))
+
+(define %guix-cuirass-servers
+  (list "https://cuirass.nonguix.org"
+        "https://cuirass.freya.cat"))
+
+;;
+;; io functions
+;;
+
+(define (invoke . args)
+  (let* ((command (string-join args " "))
+         (err-cons (pipe))
+         (port (with-error-to-port (cdr err-cons)
+                 (lambda _ (open-input-pipe command))))
+         (_ (setvbuf (car err-cons) 'block
+                     (* 1024 16))) ; 16kib buffer
+         (result (get-string-all port)))
+    (close-port (cdr err-cons))
+    result))
+
+(define (read-file path)
+  (call-with-input-file path get-string-all))
+
+(define (write-file path contents)
+  (call-with-output-file path (lambda (port)
+                                (put-string port contents))))
+
+;;
+;; git functions
+;;
+
+(define (git-checkout git-url)
+  ;; create or update a local bare git checkout from <git-url>
+  ;; - clones checkout if it doesnt exist
+  ;; - fetches newset commits
+  (let* ((home (getenv "HOME"))
+         (name (string-append
+                 (string-replace-substring
+                   (last (string-split git-url #\/))
+                   ".git"
+                   "")
+                 ".git"))
+         (dir (string-append home
+                             "/.cache/checkouts/"
+                             name)))
+    (if (not (access? dir F_OK))
+      (begin
+        (format #t "checking out ~a...\n" name)
+        (invoke "mkdir" "-p" dir)
+        (invoke "git" "clone" "--bare" git-url dir)))
+    (invoke "git" "-C" dir "fetch")
+    dir))
+
+(define (git-latest-commit git-url)
+  (car (string-split
+         (invoke "git" "ls-remote" git-url "HEAD")
+         #\tab)))
+
+(define (commit-timestamp git-url commit)
+  ; get the unix timestamp of a <commit> in git repo <git-url>
+  (let* ((dir (git-checkout git-url))
+         (timestamp
+           (invoke "git" "-C" dir "show" "--quiet" "--format=%at" commit)))
+    (string->number (string-trim-both timestamp #\newline))))
+
+;;
+;; core functions
+;;
+
+(define (merge-commits local-commits remote-commits)
+  ;; create a zipped pair of each <loacl> and <remote> commits
+  ;; - ignores the commit if the remote its older than the local commit
+  ;;
+  ;; local commit format:
+  ;; ('id "git-url" "commit")
+  ;;
+  ;; remote commit format:
+  ;; ('id . "commit")
+  ;;
+  ;; return format:
+  ;; ('id "local-commit" "newest-commit") ;; neweset commit is commit with
+  ;;                                      ;; newer timestamp
+  (fold (lambda (local-repo commits)
+          (let* ((repo-id (car local-repo))
+                 (git-url (cadr local-repo))
+                 ; local
+                 (local-commit (caddr local-repo))
+                 (local-timestamp (commit-timestamp git-url local-commit))
+                 ; remote
+                 (remote-commit (assoc-ref remote-commits repo-id))
+                 (remote-timestamp (if (string? remote-commit)
+                                     (commit-timestamp git-url remote-commit)))
+                 ; newest
+                 (newest-commit (if (and (number? remote-timestamp)
+                                         (> remote-timestamp local-timestamp))
+                                    remote-commit))
+                 ; result
+                 (result (if (string? newest-commit)
+                           (cons (list repo-id local-commit newest-commit)
+                                 commits)
+                           commits)))
+            result))
+        '()
+        local-commits))
+
+(define (update-file local-commits remote-commits path)
+  (let* ((contents (read-file path))
+         (commits (merge-commits local-commits remote-commits))
+         (result (fold (lambda (pair contents)
+                         (let ((repo-id (car pair))
+                               (local-commit (cadr pair))
+                               (remote-commit (caddr pair)))
+                           (format #t "~s\t~a -> ~a\n"
+                                   repo-id
+                                   (string-take local-commit 7)
+                                   (string-take remote-commit 7))
+                           (string-replace-substring contents
+                                                     local-commit
+                                                     remote-commit)))
+                       (read-file path)
+                       commits)))
+    (write-file path result)))
+
+;;
+;; guix functions
+;;
+
+(define (cuirass-latest-evaluation cuirass-url)
+  (json-fetch
+    (string-append
+      cuirass-url
+      "/api/evaluations?nr=1")))
+
+(define (guix-local-commits channels)
+  (map (lambda (channel)
+         (list (channel-name channel)
+               (channel-url channel)
+               (channel-commit channel)))
+       channels))
+
+(define (cuirass-commits cuirass-servers)
+  (fold (lambda (cuirass-url env)
+          (let* ((evaluation (cuirass-latest-evaluation cuirass-url))
+                 (checkouts (vector->list
+                              (assoc-ref
+                                (car (vector->list evaluation))
+                                "checkouts"))))
+            (fold (lambda (checkout env)
+                    (let* ((channel (string->symbol
+                                      (assoc-ref checkout "channel")))
+                           (commit (assoc-ref checkout "commit")))
+                      (if (assoc-ref env channel)
+                        ;; channel already set, skip
+                        env
+                        ;; add commit to env
+                        (assoc-set! env channel commit))))
+                  env
+                  checkouts)))
+        '()
+        cuirass-servers))
+
+;;
+;; nix functions
+;;
+
+(define (nix-local-commits flake-file)
+  (let ((lines (filter
+                 (lambda (line)
+                   (string-contains line "github:"))
+                 (string-split (read-file flake-file)
+                               #\newline))))
+    (map
+      ;; valid line, parse out repo-id, git-url, and commit
+      (lambda (line)
+        (let* ((trimmed (substring line
+                                   (+ (string-index line #\:) 1)
+                                   (string-rindex line #\")))
+               (pair (string-split trimmed #\/))
+               (repo-id (string->symbol (cadr pair)))
+               (git-url (string-append "https://github.com/"
+                                       (car pair) "/"
+                                       (cadr pair) ".git"))
+               (commit (caddr pair)))
+          (list repo-id git-url commit)))
+      lines)))
+
+(define (nix-nixpkgs-commit)
+  (let ((json (json-fetch
+                (string-append
+                  "https://raw.githubusercontent.com/"
+                  "nix-community/home-manager"
+                  "/refs/heads/master/flake.lock")
+                #:timeout 1)))
+        (fold
+          (lambda (key json)
+            (assoc-ref json key))
+          json
+          (list "nodes"
+                "nixpkgs"
+                "locked"
+                "rev"))))
+
+(define (nix-remote-commits local-commits)
+  (fold (lambda (pair env)
+          (let* ((repo-id (car pair))
+                (git-url (cadr pair))
+                (commit (if (eq? repo-id 'nixpkgs)
+                          (nix-nixpkgs-commit)
+                          (git-latest-commit git-url))))
+            (assoc-set! env repo-id commit)))
+        '()
+        local-commits))
+
+;;
+;; update
+;;
+
+(define %guix-local-commits
+  (guix-local-commits
+    (load %guix-channels-file)))
+
+(define %guix-remote-commits
+  (cuirass-commits %guix-cuirass-servers))
+
+(define %nix-local-commits
+  (nix-local-commits %nix-flake-file))
+
+(define %nix-remote-commits
+  (nix-remote-commits %nix-local-commits))
+
+(update-file
+  %guix-local-commits
+  %guix-remote-commits
+  %guix-channels-file)
+
+(update-file
+  %nix-local-commits
+  %nix-remote-commits
+  %nix-flake-file)
+
+(system* "guix" "pull" "-C" %guix-channels-file)
+(system* "nix" "flake" "lock" (dirname %nix-flake-file))