pkgs/applications/editors/emacs/elisp-packages/update-melpa.el

   1 ;; -*- lexical-binding: t -*-
   2
   3 ;; This is the updater for recipes-archive-melpa.json
   4
   5 (require 'promise)
   6 (require 'semaphore-promise)
   7 (require 'url)
   8 (require 'json)
   9 (require 'cl-lib)
  10 (require 'subr-x)
  11 (require 'seq)
  12
  13 ;; # Lib
  14
  15 (defun alist-set (key value alist)
  16   (cons
  17    (cons key value)
  18    (assq-delete-all
  19     key alist)))
  20
  21 (defun alist-update (key f alist)
  22   (let ((value (alist-get key alist)))
  23     (cons
  24      (cons key (funcall f value))
  25      (assq-delete-all
  26       key alist))))
  27
  28
  29 (defun process-promise (semaphore program &rest args)
  30   "Generate an asynchronous process and
  31 return Promise to resolve in that process."
  32   (promise-then
  33    (semaphore-promise-gated
  34     semaphore
  35     (lambda (resolve reject)
  36       (funcall resolve (apply #'promise:make-process program args))))
  37    #'car))
  38
  39 (defun mangle-name (s)
  40   (if (string-match "^[a-zA-Z].*" s)
  41       s
  42     (concat "_" s)))
  43
  44 ;; ## Shell promise + env
  45
  46 (defun as-string (o)
  47   (with-output-to-string (princ o)))
  48
  49 (defun assocenv (env &rest namevals)
  50   (let ((process-environment (copy-sequence env)))
  51     (mapc (lambda (e)
  52             (setenv (as-string (car e))
  53                     (cadr e)))
  54           (seq-partition namevals 2))
  55     process-environment))
  56
  57 (defun shell-promise (semaphore env script)
  58   (semaphore-promise-gated
  59    semaphore
  60    (lambda (resolve reject)
  61      (let ((process-environment env))
  62        (funcall resolve (promise:make-shell-command script))))))
  63
  64 ;; # Updater
  65
  66 ;; ## Previous Archive Reader
  67
  68 (defun previous-commit (index ename variant)
  69   (when-let (pdesc (and index (gethash ename index)))
  70     (when-let (desc (and pdesc (gethash variant pdesc)))
  71       (gethash 'commit desc))))
  72
  73 (defun previous-sha256 (index ename variant)
  74   (when-let (pdesc (and index (gethash ename index)))
  75     (when-let (desc (and pdesc (gethash variant pdesc)))
  76       (gethash 'sha256 desc))))
  77
  78 (defun parse-previous-archive (filename)
  79   (let ((idx (make-hash-table :test 'equal)))
  80     (cl-loop for desc in
  81           (let ((json-object-type 'hash-table)
  82                 (json-array-type 'list)
  83                 (json-key-type 'symbol))
  84             (json-read-file filename))
  85           do (puthash (gethash 'ename desc)
  86                       desc idx))
  87     idx))
  88
  89 ;; ## Prefetcher
  90
  91 ;; (defun latest-git-revision (url)
  92 ;;   (process-promise "git" "ls-remote" url))
  93
  94 (defun prefetch (semaphore fetcher repo commit)
  95   (promise-then
  96    (apply 'process-promise
  97           semaphore
  98           (pcase fetcher
  99             ("github"    (list "nix-prefetch-url"
 100                                "--unpack" (concat "https://github.com/" repo "/archive/" commit ".tar.gz")))
 101             ("gitlab"    (list "nix-prefetch-url"
 102                                "--unpack" (concat "https://gitlab.com/api/v4/projects/"
 103                                                   (url-hexify-string repo)
 104                                                   "/repository/archive.tar.gz?ref="
 105                                                   commit)))
 106             ("sourcehut" (list "nix-prefetch-url"
 107                                "--unpack" (concat "https://git.sr.ht/~" repo "/archive/" commit ".tar.gz")))
 108             ("codeberg" (list "nix-prefetch-url"
 109                               "--unpack" (concat "https://codeberg.org/" repo "/archive/" commit ".tar.gz")))
 110             ("bitbucket" (list "nix-prefetch-hg"
 111                                (concat "https://bitbucket.com/" repo) commit))
 112             ("hg"        (list "nix-prefetch-hg"
 113                                repo commit))
 114             ("git"       (list "nix-prefetch-git"
 115                                "--fetch-submodules"
 116                                "--url" repo
 117                                "--rev" commit))
 118             (_           (throw 'unknown-fetcher fetcher))))
 119    (lambda (res)
 120      (pcase fetcher
 121        ("git" (alist-get 'sha256 (json-read-from-string res)))
 122        (_ (car (split-string res)))))))
 123
 124 (defun source-sha (semaphore ename eprops aprops previous variant)
 125   (let* ((fetcher (alist-get 'fetcher eprops))
 126          (url     (alist-get 'url eprops))
 127          (repo    (alist-get 'repo eprops))
 128          (commit  (gethash 'commit aprops))
 129          (prev-commit (previous-commit previous ename variant))
 130          (prev-sha256 (previous-sha256 previous ename variant)))
 131     (if (and commit prev-sha256
 132              (equal prev-commit commit))
 133         (progn
 134           (message "INFO: %s: re-using %s %s" ename prev-commit prev-sha256)
 135           (promise-resolve `((sha256 . ,prev-sha256))))
 136       (if (and commit (or repo url))
 137           (promise-then
 138            (prefetch semaphore fetcher (or repo url) commit)
 139            (lambda (sha256)
 140              (message "INFO: %s: prefetched repository %s %s" ename commit sha256)
 141              `((sha256 . ,sha256)))
 142            (lambda (err)
 143              (message "ERROR: %s: during prefetch %s" ename err)
 144              (promise-resolve
 145               `((error . ,err)))))
 146         (progn
 147           (message "ERROR: %s: no commit information" ename)
 148           (promise-resolve
 149            `((error . "No commit information"))))))))
 150
 151 (defun source-info (recipe archive source-sha)
 152   (let* ((esym    (car recipe))
 153          (ename   (symbol-name esym))
 154          (eprops  (cdr recipe))
 155          (aentry  (gethash esym archive))
 156          (version (and aentry (gethash 'ver aentry)))
 157          (deps    (when-let (deps (gethash 'deps aentry))
 158                     (remove 'emacs (hash-table-keys deps))))
 159          (aprops  (and aentry (gethash 'props aentry)))
 160          (commit  (gethash 'commit aprops)))
 161     (append `((version . ,version))
 162             (when (< 0 (length deps))
 163               `((deps . ,(sort deps 'string<))))
 164             `((commit . ,commit))
 165             source-sha)))
 166
 167 (defun recipe-info (recipe-index ename)
 168   (if-let (desc (gethash ename recipe-index))
 169       (cl-destructuring-bind (rcp-commit . rcp-sha256) desc
 170         `((commit . ,rcp-commit)
 171           (sha256 . ,rcp-sha256)))
 172     `((error . "No recipe info"))))
 173
 174 (defun start-fetch (semaphore recipe-index-promise recipes unstable-archive stable-archive previous)
 175   (promise-all
 176    (mapcar (lambda (entry)
 177              (let* ((esym    (car entry))
 178                     (ename   (symbol-name esym))
 179                     (eprops  (cdr entry))
 180                     (fetcher (alist-get 'fetcher eprops))
 181                     (url     (alist-get 'url eprops))
 182                     (repo    (alist-get 'repo eprops))
 183
 184                     (unstable-aentry  (gethash esym unstable-archive))
 185                     (unstable-aprops  (and unstable-aentry (gethash 'props unstable-aentry)))
 186                     (unstable-commit  (and unstable-aprops (gethash 'commit unstable-aprops)))
 187
 188                     (stable-aentry (gethash esym stable-archive))
 189                     (stable-aprops (and stable-aentry (gethash 'props stable-aentry)))
 190                     (stable-commit  (and stable-aprops (gethash 'commit stable-aprops)))
 191
 192                     (unstable-shap (if unstable-aprops
 193                                        (source-sha semaphore ename eprops unstable-aprops previous 'unstable)
 194                                      (promise-resolve nil)))
 195                     (stable-shap (if (equal unstable-commit stable-commit)
 196                                      unstable-shap
 197                                    (if stable-aprops
 198                                        (source-sha semaphore ename eprops stable-aprops previous 'stable)
 199                                      (promise-resolve nil)))))
 200
 201                (promise-then
 202                 (promise-all (list recipe-index-promise unstable-shap stable-shap))
 203                 (lambda (res)
 204                   (seq-let [recipe-index unstable-sha stable-sha] res
 205                     (append `((ename   . ,ename))
 206                             (if-let (desc (gethash ename recipe-index))
 207                                 (cl-destructuring-bind (rcp-commit . rcp-sha256) desc
 208                                   (append `((commit . ,rcp-commit)
 209                                             (sha256 . ,rcp-sha256))
 210                                           (when (not unstable-aprops)
 211                                             (message "ERROR: %s: not in archive" ename)
 212                                             `((error . "Not in archive")))))
 213                               `((error . "No recipe info")))
 214                             `((fetcher . ,fetcher))
 215                             (if (or (equal "github" fetcher)
 216                                     (equal "bitbucket" fetcher)
 217                                     (equal "gitlab" fetcher)
 218                                     (equal "sourcehut" fetcher)
 219                                     (equal "codeberg" fetcher))
 220                                 `((repo . ,repo))
 221                               `((url . ,url)))
 222                             (when unstable-aprops `((unstable . ,(source-info entry unstable-archive unstable-sha))))
 223                             (when stable-aprops `((stable . ,(source-info entry stable-archive stable-sha))))))))))
 224            recipes)))
 225
 226 ;; ## Emitter
 227
 228 (defun emit-json (prefetch-semaphore recipe-index-promise recipes archive stable-archive previous)
 229   (promise-then
 230    (start-fetch
 231     prefetch-semaphore
 232     recipe-index-promise
 233     (sort recipes (lambda (a b)
 234                     (string-lessp
 235                      (symbol-name (car a))
 236                      (symbol-name (car b)))))
 237     archive stable-archive
 238     previous)
 239    (lambda (descriptors)
 240      (message "Finished downloading %d descriptors" (length descriptors))
 241      (let ((buf (generate-new-buffer "*recipes-archive*")))
 242        (with-current-buffer buf
 243          ;; (switch-to-buffer buf)
 244          ;; (json-mode)
 245          (insert
 246           (let ((json-encoding-pretty-print t)
 247                 (json-encoding-default-indentation " "))
 248             (json-encode descriptors)))
 249          buf)))))
 250
 251 ;; ## Recipe indexer
 252
 253 (defun http-get (url parser)
 254   (promise-new
 255    (lambda (resolve reject)
 256      (url-retrieve
 257       url (lambda (status)
 258             (funcall resolve (condition-case err
 259                                  (progn
 260                                    (url-http-parse-headers)
 261                                    (goto-char url-http-end-of-headers)
 262                                    (message (buffer-substring (point-min) (point)))
 263                                    (funcall parser))
 264                                (funcall reject err))))))))
 265
 266 (defun json-read-buffer (buffer)
 267   (with-current-buffer buffer
 268     (save-excursion
 269       (mark-whole-buffer)
 270       (json-read))))
 271
 272 (defun error-count (recipes-archive)
 273   (length
 274    (seq-filter
 275     (lambda (desc)
 276       (alist-get 'error desc))
 277     recipes-archive)))
 278
 279 ;; (error-count (json-read-buffer "recipes-archive-melpa.json"))
 280
 281 (defun latest-recipe-commit (semaphore repo base-rev recipe)
 282   (shell-promise
 283    semaphore (assocenv process-environment
 284                        "GIT_DIR" repo
 285                        "BASE_REV" base-rev
 286                        "RECIPE" recipe)
 287    "exec git log --first-parent -n1 --pretty=format:%H $BASE_REV -- recipes/$RECIPE"))
 288
 289 (defun latest-recipe-sha256 (semaphore repo base-rev recipe)
 290   (promise-then
 291    (shell-promise
 292     semaphore (assocenv process-environment
 293                         "GIT_DIR" repo
 294                         "BASE_REV" base-rev
 295                         "RECIPE" recipe)
 296     "exec nix-hash --flat --type sha256 --base32 <(
 297        git cat-file blob $(
 298          git ls-tree $BASE_REV recipes/$RECIPE | cut -f1 | cut -d' ' -f3
 299        )
 300      )")
 301    (lambda (res)
 302      (car
 303       (split-string res)))))
 304
 305 (defun index-recipe-commits (semaphore repo base-rev recipes)
 306   (promise-then
 307    (promise-all
 308     (mapcar (lambda (recipe)
 309               (promise-then
 310                (latest-recipe-commit semaphore repo base-rev recipe)
 311                (let ((sha256p (latest-recipe-sha256 semaphore repo base-rev recipe)))
 312                  (lambda (commit)
 313                    (promise-then sha256p
 314                                  (lambda (sha256)
 315                                    (message "Indexed Recipe %s %s %s" recipe commit sha256)
 316                                    (cons recipe (cons commit sha256))))))))
 317             recipes))
 318    (lambda (rcp-commits)
 319      (let ((idx (make-hash-table :test 'equal)))
 320        (mapc (lambda (rcpc)
 321                (puthash (car rcpc) (cdr rcpc) idx))
 322              rcp-commits)
 323        idx))))
 324
 325 (defun with-melpa-checkout (resolve)
 326   (let ((tmpdir (make-temp-file "melpa-" t)))
 327     (promise-finally
 328      (promise-then
 329       (shell-promise
 330        (semaphore-create 1 "dummy")
 331        (assocenv process-environment "MELPA_DIR" tmpdir)
 332        "cd $MELPA_DIR
 333        (git init --bare
 334         git remote add origin https://github.com/melpa/melpa.git
 335         git fetch origin) 1>&2
 336        echo -n $MELPA_DIR")
 337       (lambda (dir)
 338         (message "Created melpa checkout %s" dir)
 339         (funcall resolve dir)))
 340      (lambda ()
 341        (delete-directory tmpdir t)
 342        (message "Deleted melpa checkout %s" tmpdir)))))
 343
 344 (defun list-recipes (repo base-rev)
 345   (promise-then
 346    (shell-promise nil (assocenv process-environment
 347                                 "GIT_DIR" repo
 348                                 "BASE_REV" base-rev)
 349                   "git ls-tree --name-only $BASE_REV recipes/")
 350    (lambda (s)
 351      (mapcar (lambda (n)
 352                (substring n 8))
 353              (split-string s)))))
 354
 355 ;; ## Main runner
 356
 357 (defvar recipe-indexp)
 358 (defvar archivep)
 359
 360 (defun run-updater ()
 361   (message "Turning off logging to *Message* buffer")
 362   (setq message-log-max nil)
 363   (setenv "GIT_ASKPASS")
 364   (setenv "SSH_ASKPASS")
 365   (setq process-adaptive-read-buffering nil)
 366
 367   ;; Indexer and Prefetcher run in parallel
 368
 369   ;; Recipe Indexer
 370   (setq recipe-indexp
 371         (with-melpa-checkout
 372          (lambda (repo)
 373            (promise-then
 374             (promise-then
 375              (list-recipes repo "origin/master")
 376              (lambda (recipe-names)
 377                (promise:make-thread #'index-recipe-commits
 378                                     ;; The indexer runs on a local git repository,
 379                                     ;; so it is CPU bound.
 380                                     ;; Adjust for core count + 2
 381                                     (semaphore-create 6 "local-indexer")
 382                                     repo "origin/master"
 383                                     ;; (seq-take recipe-names 20)
 384                                     recipe-names)))
 385             (lambda (res)
 386               (message "Indexed Recipes: %d" (hash-table-count res))
 387               (defvar recipe-index res)
 388               res)
 389             (lambda (err)
 390               (message "ERROR: %s" err))))))
 391
 392   ;; Prefetcher + Emitter
 393   (setq archivep
 394         (promise-then
 395          (promise-then (promise-all
 396                         (list (http-get "https://melpa.org/recipes.json"
 397                                         (lambda ()
 398                                           (let ((json-object-type 'alist)
 399                                                 (json-array-type 'list)
 400                                                 (json-key-type 'symbol))
 401                                             (json-read))))
 402                               (http-get "https://melpa.org/archive.json"
 403                                         (lambda ()
 404                                           (let ((json-object-type 'hash-table)
 405                                                 (json-array-type 'list)
 406                                                 (json-key-type 'symbol))
 407                                             (json-read))))
 408                               (http-get "https://stable.melpa.org/archive.json"
 409                                         (lambda ()
 410                                           (let ((json-object-type 'hash-table)
 411                                                 (json-array-type 'list)
 412                                                 (json-key-type 'symbol))
 413                                             (json-read))))))
 414                        (lambda (resolved)
 415                          (message "Finished download")
 416                          (seq-let [recipes-content archive-content stable-archive-content] resolved
 417                            ;; The prefetcher is network bound, so 64 seems a good estimate
 418                            ;; for parallel network connections
 419                            (promise:make-thread #'emit-json (semaphore-create 64 "prefetch-pool")
 420                                                 recipe-indexp
 421                                                 recipes-content
 422                                                 archive-content
 423                                                 stable-archive-content
 424                                                 (parse-previous-archive "recipes-archive-melpa.json")))))
 425          (lambda (buf)
 426            (with-current-buffer buf
 427              (write-file "recipes-archive-melpa.json")))
 428          (lambda (err)
 429            (message "ERROR: %s" err))))
 430
 431   ;; Shutdown routine
 432   (make-thread
 433    (lambda ()
 434      (promise-finally archivep
 435                       (lambda ()
 436                         ;; (message "Joining threads %s" (all-threads))
 437                         ;; (mapc (lambda (thr)
 438                         ;;         (when (not (eq thr (current-thread)))
 439                         ;;           (thread-join thr)))
 440                         ;;       (all-threads))
 441
 442                         (kill-emacs 0))))))