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