pyrox.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 ;; 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 "~%})~%"))))