275 lines
8.6 KiB
Scheme
Executable file
275 lines
8.6 KiB
Scheme
Executable file
#!/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 (git-rev-list git-url local-commit remote-commit)
|
|
;; get how many commits ahead the remote commit is
|
|
;; from the current local commit
|
|
;; - returns 0 if remote-commit is the same or older
|
|
(if (and (string? local-commit)
|
|
(string? remote-commit))
|
|
(let* ((dir (git-checkout git-url))
|
|
(timestamp
|
|
;; git rev-list counts #commits
|
|
;; - returns zero if commits out of order (remote older)
|
|
(invoke "git" "-C" dir "rev-list" "--count"
|
|
(string-append local-commit
|
|
".."
|
|
remote-commit))))
|
|
(string->number (string-trim-both timestamp #\newline)))
|
|
;; return zero of one of the commit
|
|
;; hashes provided is invalid
|
|
0))
|
|
|
|
;;
|
|
;; 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-commit (caddr local-repo))
|
|
(remote-commit (assoc-ref remote-commits repo-id))
|
|
(commit-diff (git-rev-list git-url
|
|
local-commit
|
|
remote-commit)))
|
|
;; dont append these commits to the updated
|
|
;; merge list if the remote-commit is not better then
|
|
;; what we already have locally
|
|
(if (> commit-diff 0)
|
|
(cons (list repo-id local-commit remote-commit)
|
|
commits)
|
|
commits)))
|
|
'()
|
|
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)
|
|
(length commits)))
|
|
|
|
;;
|
|
;; 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))
|
|
|
|
(if (> (update-file
|
|
%guix-local-commits
|
|
%guix-remote-commits
|
|
%guix-channels-file) 0)
|
|
(system* "guix-retry" "guix" "pull" "-C" %guix-channels-file))
|
|
|
|
(if (> (update-file
|
|
%nix-local-commits
|
|
%nix-remote-commits
|
|
%nix-flake-file) 0)
|
|
(system* "nix" "flake" "lock" (dirname %nix-flake-file)))
|