tjh.dev
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
56let
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 '';
78in 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 ;; Probably missing dependency in QL data
94 "mcclim-bezier"
95 ;; Missing dependency on c2ffi cffi extension
96 "hu.dwim.zlib"
97 ;; These require libRmath.so, but I don't know where to get it from
98 "cl-random"
99 "cl-random-tests"
100 ))
101
102(defmethod database->nix-expression ((database sqlite-database) outfile)
103 (sqlite:with-open-database (db (database-url database))
104 (with-open-file (f outfile
105 :direction :output
106 :if-exists :supersede)
107
108 ;; Fix known problematic packages before dumping the nix file.
109 (sqlite:execute-non-query db
110 "create temp table fixed_systems as select * from system_view")
111
112 (sqlite:execute-non-query db
113 "alter table fixed_systems add column systems")
114
115 (sqlite:execute-non-query db
116 "update fixed_systems set systems = json_array(name)")
117
118 (sqlite:execute-non-query db
119 "alter table fixed_systems add column asds")
120
121 (sqlite:execute-non-query db
122 "update fixed_systems set asds = json_array(name)")
123
124 (sqlite:execute-non-query db
125 "delete from fixed_systems where name in ('asdf', 'uiop')")
126
127 (sqlite:execute-non-query db
128 "delete from fixed_systems where instr(name, '/')")
129
130 (format f prelude)
131
132 (dolist (p (sqlite:execute-to-list db "select * from fixed_systems"))
133 (destructuring-bind (name version asd url sha256 deps systems asds) p
134 (format f "~% ")
135 (let ((*nix-attrs-depth* 1))
136 (format
137 f
138 "~a = ~a;"
139 (nix-eval `(:symbol ,name))
140 (nix-eval
141 `(:funcall
142 "build-asdf-system"
143 (:attrs
144 ("pname" (:string ,(make-pname name)))
145 ("version" (:string ,version))
146 ("asds" (:list
147 ,@(mapcar (lambda (asd)
148 `(:string ,(system-master asd)))
149 (coerce (json:parse asds) 'list))))
150 ("src" (:funcall
151 "createAsd"
152 (:attrs
153 ("url" (:string ,url))
154 ("sha256" (:string ,sha256))
155 ("system" (:string ,(system-master name)))
156 ("asd" (:string ,asd)))))
157 ("systems" (:list
158 ,@(mapcar (lambda (sys)
159 `(:string ,sys))
160 (coerce (json:parse systems) 'list))))
161 ("lispLibs" (:list
162 ,@(mapcar (lambda (dep)
163 `(:funcall
164 "getAttr"
165 (:string ,(nixify-symbol dep))
166 (:symbol "self")))
167 (line-up-first
168 (str:split-omit-nulls #\, deps)
169 (set-difference '("asdf" "uiop") :test #'string=)
170 (sort #'string<)))))
171 ("meta" (:attrs
172 ,@(when (or (find #\/ name)
173 (find name +broken-packages+ :test #'string=))
174 '(("broken" (:symbol "true"))))
175 ,@(unless (find name hydra:+allowlist+ :test #'string=)
176 '(("hydraPlatforms" (:list)))))))))))))
177 (format f "~%})~%"))))