pkgs/development/lisp-modules/import/repository/quicklisp.lisp

   1 (defpackage org.lispbuilds.nix/repository/quicklisp
   2   (:use :cl)
   3   (:import-from :dex)
   4   (:import-from :alexandria :read-file-into-string :ensure-list)
   5   (:import-from :arrow-macros :->>)
   6   (:import-from :str)
   7   (:import-from
   8    :org.lispbuilds.nix/database/sqlite
   9    :sqlite-database
  10    :init-db
  11    :database-url
  12    :init-file)
  13   (:import-from
  14    :org.lispbuilds.nix/api
  15    :import-lisp-packages)
  16   (:import-from
  17    :org.lispbuilds.nix/util
  18    :replace-regexes)
  19   (:export :quicklisp-repository)
  20   (:local-nicknames
  21    (:json :com.inuoe.jzon)))
  22
  23 (in-package org.lispbuilds.nix/repository/quicklisp)
  24
  25 (defclass quicklisp-repository ()
  26   ((dist-url :initarg :dist-url
  27              :reader dist-url
  28              :initform (error "dist url required"))))
  29
  30 (defun clear-line ()
  31   (write-char #\Return *error-output*)
  32   (write-char #\Escape *error-output*)
  33   (write-char #\[ *error-output*)
  34   (write-char #\K *error-output*))
  35
  36 (defun status (&rest format-args)
  37   (clear-line)
  38   (apply #'format (list* *error-output* format-args))
  39   (force-output *error-output*))
  40
  41 ;; TODO: This should not know about the imported.nix file.
  42 (defun init-tarball-hashes (database)
  43   (status "no packages.sqlite - will pre-fill tarball hashes from ~A to save time~%"
  44           (truename "imported.nix"))
  45   (let* ((lines (uiop:read-file-lines "imported.nix"))
  46          (lines (remove-if-not
  47                   (lambda (line)
  48                     (let ((trimmed (str:trim-left line)))
  49                       (or (str:starts-with-p "url = " trimmed)
  50                           (str:starts-with-p "sha256 = " trimmed))))
  51                   lines))
  52          (lines (mapcar
  53                  (lambda (line)
  54                    (multiple-value-bind (whole groups)
  55                        (ppcre:scan-to-strings "\"\(.*\)\"" line)
  56                      (declare (ignore whole))
  57                      (svref groups 0)))
  58                  lines)))
  59     (sqlite:with-open-database (db (database-url database))
  60       (init-db db (init-file database))
  61       (sqlite:with-transaction db
  62         (loop while lines do
  63           (sqlite:execute-non-query db
  64             "insert or ignore into sha256(url,hash) values (?,?)"
  65             (prog1 (first lines) (setf lines (rest lines)))
  66             (prog1 (first lines) (setf lines (rest lines))))))
  67       (status "OK, imported ~A hashes into DB.~%"
  68               (sqlite:execute-single db
  69                  "select count(*) from sha256")))))
  70
  71 (defparameter *broken-systems*
  72   '(
  73     ;; Infinite recursion through dependencies in 2024-10-12 dist
  74     "cl-quil" "qvm"
  75     )
  76   "List of broken systems, which should be omitted from the package graph")
  77
  78 (defmethod import-lisp-packages ((repository quicklisp-repository)
  79                                  (database sqlite-database))
  80
  81   ;; If packages.sqlite is missing, we should populate the sha256
  82   ;; table to speed things up.
  83   (unless (probe-file (database-url database))
  84     (init-tarball-hashes database))
  85
  86   (let* ((db (sqlite:connect (database-url database)))
  87          (systems-url (str:concat (dist-url repository) "systems.txt"))
  88          (releases-url (str:concat (dist-url repository) "releases.txt"))
  89          (systems-lines (rest (butlast (str:split #\Newline (dex:get systems-url)))))
  90          (releases-lines (rest (butlast (str:split #\Newline (dex:get releases-url))))))
  91
  92     (flet ((sql-query (sql &rest params)
  93              (apply #'sqlite:execute-to-list (list* db sql params))))
  94
  95       ;; Ensure database schema
  96       (init-db db (init-file database))
  97
  98       ;; Prepare temporary tables for efficient access
  99       (sql-query "create temp table if not exists quicklisp_system
 100                   (project, asd, name unique, deps)")
 101
 102       (sql-query "create temp table if not exists quicklisp_release
 103                   (project unique, url, size, md5, sha1, prefix not null, asds)")
 104
 105       (sqlite:with-transaction db
 106         (dolist (line systems-lines)
 107           (destructuring-bind (project asd name &rest deps)
 108               (str:words line)
 109             (sql-query
 110              "insert or ignore into quicklisp_system values(?,?,?,?)"
 111              project asd name (json:stringify (coerce deps 'vector))))))
 112
 113       (sqlite:with-transaction db
 114         (dolist (line releases-lines)
 115           (destructuring-bind (project url size md5 sha1 prefix &rest asds)
 116               (str:words line)
 117             (sql-query
 118              "insert or ignore into quicklisp_release values(?,?,?,?,?,?,?)"
 119              project url size md5 sha1 prefix (json:stringify (coerce
 120                                                                asds
 121                                                                'vector))))))
 122
 123       ;; Skip known broken systems and their dependents
 124       (dolist (system *broken-systems*)
 125         (sql-query
 126          "with recursive broken(name) as (
 127             select ?
 128             union
 129             select s.name from quicklisp_system s, broken b
 130             where b.name in (select value from json_each(deps))
 131           ) delete from quicklisp_system where name in (select name from broken)"
 132           system))
 133
 134       (sqlite:with-transaction db
 135         ;; Should these be temp tables, that then get queried by
 136         ;; system name? This looks like it uses a lot of memory.
 137         (let ((systems
 138                 (sql-query
 139                  "with pkgs as (
 140                     select
 141                       name, asd, url, deps,
 142                       ltrim(replace(prefix, r.project, ''), '-_') as version
 143                     from quicklisp_system s, quicklisp_release r
 144                     where s.project = r.project
 145                   )
 146                   select
 147                     name, version, asd, url,
 148                     (select json_group_array(
 149                        json_array(value, (select version from pkgs where name=value))
 150                      )
 151                      from json_each(deps)
 152                      where value <> 'asdf') as deps
 153                   from pkgs"
 154                  )))
 155
 156           ;; First pass: insert system and source tarball informaton.
 157           ;; Can't insert dependency information, because this works
 158           ;; on system ids in the database and they don't exist
 159           ;; yet. Could it be better to just base dependencies on
 160           ;; names? But then ACID is lost.
 161           (dolist (system systems)
 162             (destructuring-bind (name version asd url deps) system
 163               (declare (ignore deps))
 164               (status "importing system '~a-~a'" name version)
 165               (let ((hash (nix-prefetch-tarball url db)))
 166                 (sql-query
 167                  "insert or ignore into system(name,version,asd) values (?,?,?)"
 168                  name version asd)
 169                 (sql-query
 170                  "insert or ignore into sha256(url,hash) values (?,?)"
 171                  url hash)
 172                 (sql-query
 173                  "insert or ignore into src values
 174                   ((select id from sha256 where url=?),
 175                    (select id from system where name=? and version=?))"
 176                  url name version))))
 177
 178           ;; Second pass: connect the in-database systems with
 179           ;; dependency information
 180           (dolist (system systems)
 181             (destructuring-bind (name version asd url deps) system
 182               (declare (ignore asd url))
 183               (dolist (dep (coerce (json:parse deps) 'list))
 184                 (destructuring-bind (dep-name dep-version) (coerce dep 'list)
 185                   (if (eql dep-version 'NULL)
 186                     (warn "Bad data in Quicklisp: ~a has no version" dep-name)
 187                   (sql-query
 188                     "insert or ignore into dep values
 189                      ((select id from system where name=? and version=?),
 190                       (select id from system where name=? and version=?))"
 191                     name version
 192                     dep-name dep-version))))))))))
 193
 194   (write-char #\Newline *error-output*))
 195
 196 (defun shell-command-to-string (cmd)
 197   ;; Clearing the library path is needed to prevent a bug, where the
 198   ;; called subprocess uses a different glibc than the SBCL process
 199   ;; is. In that case, the call to execve attempts to load the
 200   ;; libraries used by SBCL from LD_LIBRARY_PATH using a different
 201   ;; glibc than they expect, which errors out.
 202   (let ((ld-library-path  (uiop:getenv "LD_LIBRARY_PATH")))
 203     (setf (uiop:getenv "LD_LIBRARY_PATH") "")
 204     (unwind-protect
 205          (uiop:run-program cmd :output '(:string :stripped t))
 206       (setf (uiop:getenv "LD_LIBRARY_PATH") ld-library-path))))
 207
 208 (defun nix-prefetch-tarball (url db)
 209   (restart-case
 210       (compute-sha256 url db)
 211     (try-again ()
 212       :report "Try downloading again"
 213       (nix-prefetch-tarball url db))))
 214
 215 (defun compute-sha256 (url db)
 216   (or (sqlite:execute-single db "select hash from sha256 where url=?" url)
 217       (let ((sha256 (shell-command-to-string (str:concat "nix-prefetch-url --unpack " url))))
 218         sha256)))