path: root/pkgs/applications/editors/emacs-modes/update-melpa.el

;; -*- lexical-binding: t -*-

;; This is the updater for recipes-archive-melpa.json

(require 'promise)
(require 'semaphore-promise)
(require 'url)
(require 'json)
(require 'cl)
(require 'subr-x)
(require 'seq)

;; # Lib

(defun alist-set (key value alist)
  (cons
   (cons key value)
   (assq-delete-all
    key alist)))

(defun alist-update (key f alist)
  (let ((value (alist-get key alist)))
    (cons
     (cons key (funcall f value))
     (assq-delete-all
      key alist))))


(defun process-promise (semaphore program &rest args)
  "Generate an asynchronous process and
return Promise to resolve in that process."
  (promise-then
   (semaphore-promise-gated
    semaphore
    (lambda (resolve reject)
      (funcall resolve (apply #'promise:make-process program args))))
   #'car))

(defun mangle-name (s)
  (if (string-match "^[a-zA-Z].*" s)
      s
    (concat "_" s)))

;; ## Shell promise + env

(defun as-string (o)
  (with-output-to-string (princ o)))

(defun assocenv (env &rest namevals)
  (let ((process-environment (copy-sequence env)))
    (mapc (lambda (e)
            (setenv (as-string (car e))
                    (cadr e)))
          (seq-partition namevals 2))
    process-environment))

(defun shell-promise (semaphore env script)
  (semaphore-promise-gated
   semaphore
   (lambda (resolve reject)
     (let ((process-environment env))
       (funcall resolve (promise:make-shell-command script))))))

;; # Updater

;; ## Previous Archive Reader

(defun previous-commit (index ename variant)
  (when-let (pdesc (and index (gethash ename index)))
    (when-let (desc (and pdesc (gethash variant pdesc)))
      (gethash 'commit desc))))

(defun previous-sha256 (index ename variant)
  (when-let (pdesc (and index (gethash ename index)))
    (when-let (desc (and pdesc (gethash variant pdesc)))
      (gethash 'sha256 desc))))

(defun parse-previous-archive (filename)
  (let ((idx (make-hash-table :test 'equal)))
    (loop for desc in
          (let ((json-object-type 'hash-table)
                (json-array-type 'list)
                (json-key-type 'symbol))
            (json-read-file filename))
          do (puthash (gethash 'ename desc)
                      desc idx))
    idx))

;; ## Prefetcher

;; (defun latest-git-revision (url)
;;   (process-promise "git" "ls-remote" url))

(defun prefetch (semaphore fetcher repo commit)
  (promise-then
   (apply 'process-promise
          semaphore
          (pcase fetcher
            ("github"    (list "nix-prefetch-url"
                               "--unpack" (concat "https://github.com/" repo "/archive/" commit ".tar.gz")))
            ("gitlab"    (list "nix-prefetch-url"
                               "--unpack" (concat "https://gitlab.com/" repo "/repository/archive.tar.gz?ref=" commit)))
            ("bitbucket" (list "nix-prefetch-hg"
                               (concat "https://bitbucket.com/" repo) commit))
            ("hg"        (list "nix-prefetch-hg"
                               repo commit))
            ("git"       (list "nix-prefetch-git"
                               "--fetch-submodules"
                               "--url" repo
                               "--rev" commit))
            (_           (throw 'unknown-fetcher fetcher))))
   (lambda (res)
     (pcase fetcher
       ("git" (alist-get 'sha256 (json-read-from-string res)))
       (_ (car (split-string res)))))))

(defun source-sha (semaphore ename eprops aprops previous variant)
  (let* ((fetcher (alist-get 'fetcher eprops))
         (url     (alist-get 'url eprops))
         (repo    (alist-get 'repo eprops))
         (commit  (gethash 'commit aprops))
         (prev-commit (previous-commit previous ename variant))
         (prev-sha256 (previous-sha256 previous ename variant)))
    (if (and commit prev-sha256
             (equal prev-commit commit))
        (progn
          (message "INFO: %s: re-using %s %s" ename prev-commit prev-sha256)
          (promise-resolve `((sha256 . ,prev-sha256))))
      (if (and commit (or repo url))
          (promise-then
           (prefetch semaphore fetcher (or repo url) commit)
           (lambda (sha256)
             (message "INFO: %s: prefetched repository %s %s" ename commit sha256)
             `((sha256 . ,sha256)))
           (lambda (err)
             (message "ERROR: %s: during prefetch %s" ename err)
             (promise-resolve
              `((error . ,err)))))
        (progn
          (message "ERROR: %s: no commit information" ename)
          (promise-resolve
           `((error . "No commit information"))))))))

(defun source-info (recipe archive source-sha)
  (let* ((esym    (car recipe))
         (ename   (symbol-name esym))
         (eprops  (cdr recipe))
         (aentry  (gethash esym archive))
         (version (and aentry (gethash 'ver aentry)))
         (deps    (when-let (deps (gethash 'deps aentry))
                    (remove 'emacs (hash-table-keys deps))))
         (aprops  (and aentry (gethash 'props aentry)))
         (commit  (gethash 'commit aprops)))
    (append `((version . ,version))
            (when (< 0 (length deps))
              `((deps . ,(sort deps 'string<))))
            `((commit . ,commit))
            source-sha)))

(defun recipe-info (recipe-index ename)
  (if-let (desc (gethash ename recipe-index))
      (destructuring-bind (rcp-commit . rcp-sha256) desc
        `((commit . ,rcp-commit)
          (sha256 . ,rcp-sha256)))
    `((error . "No recipe info"))))

(defun start-fetch (semaphore recipe-index-promise recipes unstable-archive stable-archive previous)
  (promise-all
   (mapcar (lambda (entry)
             (let* ((esym    (car entry))
                    (ename   (symbol-name esym))
                    (eprops  (cdr entry))
                    (fetcher (alist-get 'fetcher eprops))
                    (url     (alist-get 'url eprops))
                    (repo    (alist-get 'repo eprops))

                    (unstable-aentry  (gethash esym unstable-archive))
                    (unstable-aprops  (and unstable-aentry (gethash 'props unstable-aentry)))
                    (unstable-commit  (and unstable-aprops (gethash 'commit unstable-aprops)))

                    (stable-aentry (gethash esym stable-archive))
                    (stable-aprops (and stable-aentry (gethash 'props stable-aentry)))
                    (stable-commit  (and stable-aprops (gethash 'commit stable-apr