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 (defmethod import-lisp-packages ((repository quicklisp-repository)
  72                                  (database sqlite-database))
  73
  74   ;; If packages.sqlite is missing, we should populate the sha256
  75   ;; table to speed things up.
  76   (unless (probe-file (database-url database))
  77     (init-tarball-hashes database))
  78
  79   (let* ((db (sqlite:connect (database-url database)))
  80          (systems-url (str:concat (dist-url repository) "systems.txt"))
  81          (releases-url (str:concat (dist-url repository) "releases.txt"))
  82          (systems-lines (rest (butlast (str:split #\Newline (dex:get systems-url)))))
  83          (releases-lines (rest (butlast (str:split #\Newline (dex:get releases-url))))))
  84
  85     (flet ((sql-query (sql &rest params)
  86              (apply #'sqlite:execute-to-list (list* db sql params))))
  87
  88       ;; Ensure database schema
  89       (init-db db (init-file database))
  90
  91       ;; Prepare temporary tables for efficient access
  92       (sql-query "create temp table if not exists quicklisp_system
  93                   (project, asd, name unique, deps)")
  94
  95       (sql-query "create temp table if not exists quicklisp_release
  96                   (project unique, url, size, md5, sha1, prefix not null, asds)")
  97
  98       (sqlite:with-transaction db
  99         (dolist (line systems-lines)
 100           (destructuring-bind (project asd name &rest deps)
 101               (str:words line)
 102             (sql-query
 103              "insert or ignore into quicklisp_system values(?,?,?,?)"
 104              project asd name (json:stringify (coerce deps 'vector))))))
 105
 106       (sqlite:with-transaction db
 107         (dolist (line releases-lines)
 108           (destructuring-bind (project url size md5 sha1 prefix &rest asds)
 109               (str:words line)
 110             (sql-query
 111              "insert or ignore into quicklisp_release values(?,?,?,?,?,?,?)"
 112              project url size md5 sha1 prefix (json:stringify (coerce
 113                                                                asds
 114                                                                'vector))))))
 115
 116       (sqlite:with-transaction db
 117         ;; Should these be temp tables, that then get queried by
 118         ;; system name? This looks like it uses a lot of memory.
 119         (let ((systems
 120                 (sql-query
 121                  "with pkgs as (
 122                     select
 123                       name, asd, url, deps,
 124                       ltrim(replace(prefix, r.project, ''), '-_') as version
 125                     from quicklisp_system s, quicklisp_release r
 126                     where s.project = r.project
 127                   )
 128                   select
 129                     name, version, asd, url,
 130                     (select json_group_array(
 131                        json_array(value, (select version from pkgs where name=value))
 132                      )
 133                      from json_each(deps)
 134                      where value <> 'asdf') as deps
 135                   from pkgs"
 136                  )))
 137
 138           ;; First pass: insert system and source tarball informaton.
 139           ;; Can't insert dependency information, because this works
 140           ;; on system ids in the database and they don't exist
 141           ;; yet. Could it be better to just base dependencies on
 142           ;; names? But then ACID is lost.
 143           (dolist (system systems)
 144             (destructuring-bind (name version asd url deps) system
 145               (declare (ignore deps))
 146               (status "importing system '~a-~a'" name version)
 147               (let ((hash (nix-prefetch-tarball url db)))
 148                 (sql-query
 149                  "insert or ignore into system(name,version,asd) values (?,?,?)"
 150                  name version asd)
 151                 (sql-query
 152                  "insert or ignore into sha256(url,hash) values (?,?)"
 153                  url hash)
 154                 (sql-query
 155                  "insert or ignore into src values
 156                   ((select id from sha256 where url=?),
 157                    (select id from system where name=? and version=?))"
 158                  url name version))))
 159
 160           ;; Second pass: connect the in-database systems with
 161           ;; dependency information
 162           (dolist (system systems)
 163             (destructuring-bind (name version asd url deps) system
 164               (declare (ignore asd url))
 165               (dolist (dep (coerce (json:parse deps) 'list))
 166                 (destructuring-bind (dep-name dep-version) (coerce dep 'list)
 167                   (if (eql dep-version 'NULL)
 168                     (warn "Bad data in Quicklisp: ~a has no version" dep-name)
 169                   (sql-query
 170                     "insert or ignore into dep values
 171                      ((select id from system where name=? and version=?),
 172                       (select id from system where name=? and version=?))"
 173                     name version
 174                     dep-name dep-version))))))))))
 175
 176   (write-char #\Newline *error-output*))
 177
 178 (defun shell-command-to-string (cmd)
 179   ;; Clearing the library path is needed to prevent a bug, where the
 180   ;; called subprocess uses a different glibc than the SBCL process
 181   ;; is. In that case, the call to execve attempts to load the
 182   ;; libraries used by SBCL from LD_LIBRARY_PATH using a different
 183   ;; glibc than they expect, which errors out.
 184   (let ((ld-library-path  (uiop:getenv "LD_LIBRARY_PATH")))
 185     (setf (uiop:getenv "LD_LIBRARY_PATH") "")
 186     (unwind-protect
 187          (uiop:run-program cmd :output '(:string :stripped t))
 188       (setf (uiop:getenv "LD_LIBRARY_PATH") ld-library-path))))
 189
 190 (defun nix-prefetch-tarball (url db)
 191   (restart-case
 192       (compute-sha256 url db)
 193     (try-again ()
 194       :report "Try downloading again"
 195       (nix-prefetch-tarball url db))))
 196
 197 (defun compute-sha256 (url db)
 198   (or (sqlite:execute-single db "select hash from sha256 where url=?" url)
 199       (let ((sha256 (shell-command-to-string (str:concat "nix-prefetch-url --unpack " url))))
 200         sha256)))