path: root/scripts/update-commits

#!/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
  (dirname (dirname (current-filename))))

(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)))