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

(defpackage org.lispbuilds.nix/database/sqlite
  (:use :cl)
  (:import-from :str)
  (:import-from :sqlite)
  (:import-from :alexandria :read-file-into-string)
  (:import-from :alexandria-2 :line-up-first)
  (:import-from :arrow-macros :->>)
  (:import-from
   :org.lispbuilds.nix/util
   :replace-regexes)
  (:import-from
   :org.lispbuilds.nix/nix
   :nix-eval
   :nixify-symbol
   :system-master
   :make-pname
   :*nix-attrs-depth*)
  (:import-from
   :org.lispbuilds.nix/api
   :database->nix-expression)
  (:export :sqlite-database :init-db)
  (:local-nicknames
   (:hydra :org.lispbuilds.nix/hydra)
   (:json :com.inuoe.jzon)))

(in-package org.lispbuilds.nix/database/sqlite)

(defclass sqlite-database ()
  ((url :initarg :url
        :reader database-url
        :initform (error "url required"))
   (init-file :initarg :init-file
              :reader init-file
              :initform (error "init file required"))))

(defun init-db (db init-file)
  (let ((statements (->> (read-file-into-string init-file)
                         (replace-regexes '(".*--.*") '(""))
                         (substitute #\Space #\Newline)
                         (str:collapse-whitespaces)
                         (str:split #\;)
                         (mapcar #'str:trim)
                         (remove-if #'str:emptyp))))
    (sqlite:with-transaction db
      (dolist (s statements)
        (sqlite:execute-non-query db s)))))


;; Writing Nix

(defparameter prelude "
# This file was auto-generated by nix-quicklisp.lisp

{ runCommand, pkgs, lib, fetchzip, build-asdf-system, ... }:

let

 inherit (builtins) getAttr;

# Ensures that every non-slashy `system` exists in a unique .asd file.
# (Think cl-async-base being declared in cl-async.asd upstream)
#
# This is required because we're building and loading a system called
# `system`, not `asd`, so otherwise `system` would not be loadable
# without building and loading `asd` first.
#
 createAsd = { url, sha256, asd, system }:
   let
     src = fetchzip { inherit url sha256; };
   in
     if asd == system
     then src
     else runCommand \"source\" {} ''
       mkdir -pv $out
       cp -r ${src}/* $out
       find $out -name \"${asd}.asd\" | while read f; do mv -fv $f $(dirname $f)/${system}.asd || true; done
     '';
in lib.makeScope pkgs.newScope (self: {")

;; Random compilation errors
(defparameter +broken-packages+
  (list
   ;; no dispatch function defined for #\t
   "hu.dwim.logger"
   "hu.dwim.serializer"
   "hu.dwim.quasi-quote"
   ;; Tries to write in $HOME
   "ubiquitous"
   ;; Upstream bad packaging, multiple systems in clml.blas.asd
   "clml.blas.hompack"
   ;; Fails on SBCL due to heap exhaustion
   "magicl"
   ;; Missing dependency on c2ffi cffi extension
   "hu.dwim.zlib"
   ;; These require libRmath.so, but I don't know where to get it from
   "cl-random"
   "cl-random-tests"
   ))

(defmethod database->nix-expression ((database sqlite-database) outfile)
  (sqlite:with-open-database (db (database-url database))
    (with-open-file (f outfile
                       :direction :output
                       :if-exists :supersede)

      ;; Fix known problematic packages before dumping the nix file.
      (sqlite:execute-non-query db
       "create temp table fixed_systems as select * from system_view")

      (sqlite:execute-non-query db
       "alter table fixed_systems add column systems")

      (sqlite:execute-non-query db
       "update fixed_systems set systems = json_array(name)")

      (sqlite:execute-non-query db
       "alter table fixed_systems add column asds")

      (sqlite:execute-non-query db
       "update fixed_systems set asds = json_array(name)")

      (sqlite:execute-non-query db
       "delete from fixed_systems where name in ('asdf', 'uiop')")

      (sqlite:execute-non-query db
       "delete from fixed_systems where instr(name, '/')")

      (format f prelude)

      (dolist (p (sqlite:execute-to-list db "select * from fixed_systems"))
        (destructuring-bind (name version asd url sha256 deps systems asds) p
          (format f "~%  ")
          (let ((*nix-attrs-depth* 1))
            (format
             f
             "~a = ~a;"
             (nix-eval `(:symbol ,name))
             (nix-eval
              `(:funcall
                "build-asdf-system"
                (:attrs
                 ("pname" (:string ,(make-pname name)))
                 ("version" (:string ,version))
                 ("asds" (:list
                          ,@(mapcar (lambda (asd)
                                      `(:string ,(system-master asd)))
                                    (coerce (json:parse asds) 'list))))
                 ("src" (:funcall
                         "createAsd"
                         (:attrs
                          ("url" (:string ,url))
                          ("sha256" (:string ,sha256))
                          ("system" (:string ,(system-master name)))
                          ("asd" (:string ,asd)))))
                 ("systems" (:list
                             ,@(mapcar (lambda (sys)
                                         `(:string ,sys))
                                       (coerce (json:parse systems) 'list))))
                 ("lispLibs" (:list
                              ,@(mapcar (lambda (dep)
                                          `(:funcall
                                            "getAttr"
                                            (:string ,(nixify-symbol dep))
                                            (:symbol "self")))
                                        (line-up-first
                                         (str:split-omit-nulls #\, deps)
                                         (set-difference '("asdf" "uiop") :test #'string=)
                                         (sort #'string<)))))
                 ("meta" (:attrs
                          ,@(when (or (find #\/ name)
                                      (find name +broken-packages+ :test #'string=))
                              '(("broken" (:symbol "true"))))
                          ,@(unless (find name hydra:+allowlist+ :test #'string=)
                              '(("hydraPlatforms" (:list)))))))))))))
      (format f "~%})~%"))))