pkgs/development/lisp-modules/import/database/sqlite.lisp

   1 (defpackage org.lispbuilds.nix/database/sqlite
   2   (:use :cl)
   3   (:import-from :str)
   4   (:import-from :sqlite)
   5   (:import-from :alexandria :read-file-into-string)
   6   (:import-from :alexandria-2 :line-up-first)
   7   (:import-from :arrow-macros :->>)
   8   (:import-from
   9    :org.lispbuilds.nix/util
  10    :replace-regexes)
  11   (:import-from
  12    :org.lispbuilds.nix/nix
  13    :nix-eval
  14    :nixify-symbol
  15    :system-master
  16    :make-pname
  17    :*nix-attrs-depth*)
  18   (:import-from
  19    :org.lispbuilds.nix/api
  20    :database->nix-expression)
  21   (:export :sqlite-database :init-db)
  22   (:local-nicknames
  23    (:hydra :org.lispbuilds.nix/hydra)
  24    (:json :com.inuoe.jzon)))
  25
  26 (in-package org.lispbuilds.nix/database/sqlite)
  27
  28 (defclass sqlite-database ()
  29   ((url :initarg :url
  30         :reader database-url
  31         :initform (error "url required"))
  32    (init-file :initarg :init-file
  33               :reader init-file
  34               :initform (error "init file required"))))
  35
  36 (defun init-db (db init-file)
  37   (let ((statements (->> (read-file-into-string init-file)
  38                          (replace-regexes '(".*--.*") '(""))
  39                          (substitute #\Space #\Newline)
  40                          (str:collapse-whitespaces)
  41                          (str:split #\;)
  42                          (mapcar #'str:trim)
  43                          (remove-if #'str:emptyp))))
  44     (sqlite:with-transaction db
  45       (dolist (s statements)
  46         (sqlite:execute-non-query db s)))))
  47
  48
  49 ;; Writing Nix
  50
  51 (defparameter prelude "
  52 # This file was auto-generated by nix-quicklisp.lisp
  53
  54 { runCommand, pkgs, lib, fetchzip, build-asdf-system, ... }:
  55
  56 let
  57
  58  inherit (builtins) getAttr;
  59
  60 # Ensures that every non-slashy `system` exists in a unique .asd file.
  61 # (Think cl-async-base being declared in cl-async.asd upstream)
  62 #
  63 # This is required because we're building and loading a system called
  64 # `system`, not `asd`, so otherwise `system` would not be loadable
  65 # without building and loading `asd` first.
  66 #
  67  createAsd = { url, sha256, asd, system }:
  68    let
  69      src = fetchzip { inherit url sha256; };
  70    in
  71      if asd == system
  72      then src
  73      else runCommand \"source\" {} ''
  74        mkdir -pv $out
  75        cp -r ${src}/* $out
  76        find $out -name \"${asd}.asd\" | while read f; do mv -fv $f $(dirname $f)/${system}.asd || true; done
  77      '';
  78 in lib.makeScope pkgs.newScope (self: {")
  79
  80 ;; Random compilation errors
  81 (defparameter +broken-packages+
  82   (list
  83    ;; no dispatch function defined for #\t
  84    "hu.dwim.logger"
  85    "hu.dwim.serializer"
  86    "hu.dwim.quasi-quote"
  87    ;; Tries to write in $HOME
  88    "ubiquitous"
  89    ;; Upstream bad packaging, multiple systems in clml.blas.asd
  90    "clml.blas.hompack"
  91    ;; Fails on SBCL due to heap exhaustion
  92    "magicl"
  93    ;; Missing dependency on c2ffi cffi extension
  94    "hu.dwim.zlib"
  95    ;; These require libRmath.so, but I don't know where to get it from
  96    "cl-random"
  97    "cl-random-tests"
  98    ))
  99
 100 (defmethod database->nix-expression ((database sqlite-database) outfile)
 101   (sqlite:with-open-database (db (database-url database))
 102     (with-open-file (f outfile
 103                        :direction :output
 104                        :if-exists :supersede)
 105
 106       ;; Fix known problematic packages before dumping the nix file.
 107       (sqlite:execute-non-query db
 108        "create temp table fixed_systems as select * from system_view")
 109
 110       (sqlite:execute-non-query db
 111        "alter table fixed_systems add column systems")
 112
 113       (sqlite:execute-non-query db
 114        "update fixed_systems set systems = json_array(name)")
 115
 116       (sqlite:execute-non-query db
 117        "alter table fixed_systems add column asds")
 118
 119       (sqlite:execute-non-query db
 120        "update fixed_systems set asds = json_array(name)")
 121
 122       (sqlite:execute-non-query db
 123        "delete from fixed_systems where name in ('asdf', 'uiop')")
 124
 125       (sqlite:execute-non-query db
 126        "delete from fixed_systems where instr(name, '/')")
 127
 128       (format f prelude)
 129
 130       (dolist (p (sqlite:execute-to-list db "select * from fixed_systems"))
 131         (destructuring-bind (name version asd url sha256 deps systems asds) p
 132           (format f "~%  ")
 133           (let ((*nix-attrs-depth* 1))
 134             (format
 135              f
 136              "~a = ~a;"
 137              (nix-eval `(:symbol ,name))
 138              (nix-eval
 139               `(:funcall
 140                 "build-asdf-system"
 141                 (:attrs
 142                  ("pname" (:string ,(make-pname name)))
 143                  ("version" (:string ,version))
 144                  ("asds" (:list
 145                           ,@(mapcar (lambda (asd)
 146                                       `(:string ,(system-master asd)))
 147                                     (coerce (json:parse asds) 'list))))
 148                  ("src" (:funcall
 149                          "createAsd"
 150                          (:attrs
 151                           ("url" (:string ,url))
 152                           ("sha256" (:string ,sha256))
 153                           ("system" (:string ,(system-master name)))
 154                           ("asd" (:string ,asd)))))
 155                  ("systems" (:list
 156                              ,@(mapcar (lambda (sys)
 157                                          `(:string ,sys))
 158                                        (coerce (json:parse systems) 'list))))
 159                  ("lispLibs" (:list
 160                               ,@(mapcar (lambda (dep)
 161                                           `(:funcall
 162                                             "getAttr"
 163                                             (:string ,(nixify-symbol dep))
 164                                             (:symbol "self")))
 165                                         (line-up-first
 166                                          (str:split-omit-nulls #\, deps)
 167                                          (set-difference '("asdf" "uiop") :test #'string=)
 168                                          (sort #'string<)))))
 169                  ("meta" (:attrs
 170                           ,@(when (or (find #\/ name)
 171                                       (find name +broken-packages+ :test #'string=))
 172                               '(("broken" (:symbol "true"))))
 173                           ,@(unless (find name hydra:+allowlist+ :test #'string=)
 174                               '(("hydraPlatforms" (:list)))))))))))))
 175       (format f "~%})~%"))))