BoomMicrophone/nixpkgs-suyu
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Overhaul quicklisp-to-nix

Browse source 
1. Detect (and automatically handle) parasitic systems.
2. Each nix package has only one asd, and (almost) every parasitic
   package inside it builds.
3. Ensure that parasitic systems are compiled.
4. Remove unnecessary testnames lisp override mechanism (the
   testnae/testSystem is replaced by parasites/buildSystems).
5. Parasitic systems (if included in the system closure) become
   aliases to their host package.
6. Support caching fasl files in a known directory (for faster
   re-generation after modifying quicklisp-to-nix-system-info).
7. Eliminate unnecessary overrides.  We're going to determine ALL
   lisp dependencies correctly.
8. Don't try to "build" lisp packages with make.  lispPackages should
   be about bringing in a lisp library.
9. Eliminate the hand-maintained list of aliases.  Parasites should
   become aliases.  Everything else should be a real package.
This commit is contained in:
Brad Jensen 2017-07-31 19:29:53 -07:00
parent 86e6e8016d
commit f0c8027ae3
13 changed files with 1116 additions and 313 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

53
pkgs/development/lisp-modules/define-package.nix
View file

@ -1,7 +1,10 @@
args @ {stdenv, clwrapper, baseName, packageName ? baseName, testSystems ? [packageName]
args @ {stdenv, clwrapper, baseName, packageName ? baseName
, parasites ? []
, buildSystems ? ([packageName] ++ parasites)
, version ? "latest"
, src, description, deps, buildInputs ? [], meta ? {}, overrides?(x: {})
, propagatedBuildInputs ? []}:
, propagatedBuildInputs ? []
, asdFilesToKeep ? [(builtins.concatStringsSep "" [packageName ".asd"])]}:
let
deployConfigScript = ''
outhash="$out"
@ -43,11 +46,34 @@ let
echo "export LD_LIBRARY_PATH=\"\$NIX_LISP_LD_LIBRARY_PATH\''${NIX_LISP_LD_LIBRARY_PATH:+:}\$LD_LIBRARY_PATH\"" >> "$launch_script"
echo '"${clwrapper}/bin/common-lisp.sh" "$@"' >> "$launch_script"
'';
moveAsdFiles = ''
find $out/lib/common-lisp/ -name '*.asd' | while read ASD_FILE; do
KEEP_THIS_ASD=0
for ALLOWED_ASD in $asdFilesToKeep; do
ALLOWED_ASD="/$ALLOWED_ASD"
ALLOWED_ASD_LENGTH=${"$"}{#ALLOWED_ASD}
ASD_FILE_LENGTH=${"$"}{#ASD_FILE}
ASD_FILE_SUFFIX_INDEX=$(expr "$ASD_FILE_LENGTH" - "$ALLOWED_ASD_LENGTH")
ASD_FILE_SUFFIX_INDEX=$(expr "$ASD_FILE_SUFFIX_INDEX" + 1)
echo $ALLOWED_ASD $ASD_FILE $ASD_FILE_SUFFIX_INDEX $(expr substr "$ASD_FILE" "$ASD_FILE_SUFFIX_INDEX" "$ASD_FILE_LENGTH")
if [ "$(expr substr "$ASD_FILE" "$ASD_FILE_SUFFIX_INDEX" "$ASD_FILE_LENGTH")" == "$ALLOWED_ASD" ]; then
KEEP_THIS_ASD=1
break
fi
done
if [ "$KEEP_THIS_ASD" == 0 ]; then
mv "$ASD_FILE"{,.sibling}
fi
done
'';
basePackage = {
name = "lisp-${baseName}-${version}";
inherit src;
dontBuild = true;
inherit deployConfigScript deployLaunchScript;
inherit asdFilesToKeep moveAsdFiles;
installPhase = ''
eval "$preInstall"
@ -58,18 +84,19 @@ basePackage = {
${deployConfigScript}
${deployLaunchScript}
${moveAsdFiles}
${stdenv.lib.concatMapStrings (testSystem: ''
env -i \
NIX_LISP="$NIX_LISP" \
NIX_LISP_PRELAUNCH_HOOK='nix_lisp_run_single_form "(progn
(asdf:compile-system :${testSystem})
(asdf:load-system :${testSystem})
(asdf:operate (quote asdf::compile-bundle-op) :${testSystem})
(ignore-errors (asdf:operate (quote asdf::deploy-asd-op) :${testSystem}))
)"' \
"$out/bin/${args.baseName}-lisp-launcher.sh"
'') testSystems}
env -i \
NIX_LISP="$NIX_LISP" \
NIX_LISP_PRELAUNCH_HOOK='nix_lisp_run_single_form "(progn
${stdenv.lib.concatMapStrings (system: ''
(asdf:compile-system :${system})
(asdf:load-system :${system})
(asdf:operate (quote asdf::compile-bundle-op) :${system})
(ignore-errors (asdf:operate (quote asdf::deploy-asd-op) :${system}))
'') buildSystems}
)"' \
"$out/bin/${args.baseName}-lisp-launcher.sh"
eval "$postInstall"
'';

51
pkgs/development/lisp-modules/lisp-packages.nix
View file

@ -1,4 +1,4 @@
{stdenv, clwrapper, pkgs}:
{stdenv, clwrapper, pkgs, sbcl, coreutils, nix, asdf}:
let lispPackages = rec {
inherit pkgs clwrapper stdenv;
nixLib = pkgs.lib;
@ -20,7 +20,6 @@ let lispPackages = rec {
clx-xkeyboard = buildLispPackage rec {
baseName = "clx-xkeyboard";
testSystems = ["xkeyboard"];
version = "git-20150523";
description = "CLX support for X Keyboard extensions";
deps = with (pkgs.quicklispPackagesFor clwrapper); [clx];
@ -30,13 +29,14 @@ let lispPackages = rec {
sha256 = "11b34da7d354a709a24774032e85a8947be023594f8a333eaff6d4aa79f2b3db";
rev = ''11455d36283ef31c498bd58ffebf48c0f6b86ea6'';
};
buildSystems = ["xkeyboard"];
};
quicklisp = buildLispPackage rec {
baseName = "quicklisp";
version = "2017-03-06";
testSystems = [];
buildSystems = [];
description = "The Common Lisp package manager";
deps = [];
@ -50,8 +50,8 @@ let lispPackages = rec {
quicklispdist = pkgs.fetchurl {
# Will usually be replaced with a fresh version anyway, but needs to be
# a valid distinfo.txt
url = "http://beta.quicklisp.org/dist/quicklisp/2016-03-18/distinfo.txt";
sha256 = "13mvign4rsicfvg3vs3vj1qcjvj2m1aqhq93ck0sgizxfcj5167m";
url = "http://beta.quicklisp.org/dist/quicklisp/2017-07-25/distinfo.txt";
sha256 = "165fd4a10zc3mxyy7wr4i2r3n6fzd1wd2hgzfyp32xlc41qj2ajf";
};
buildPhase = '' true; '';
postInstall = ''
@ -61,5 +61,46 @@ let lispPackages = rec {
'';
};
};
quicklisp-to-nix-system-info = stdenv.mkDerivation rec {
name = "quicklisp-to-nix-system-info-${version}";
version = "1.0.0";
src = ./quicklisp-to-nix;
nativeBuildInputs = [sbcl];
buildInputs = [
lispPackages.quicklisp coreutils
];
touch = coreutils;
nix-prefetch-url = nix;
inherit quicklisp;
buildPhase = ''
${sbcl}/bin/sbcl --eval '(load #P"${asdf}/lib/common-lisp/asdf/build/asdf.lisp")' --load $src/system-info.lisp --eval '(ql-to-nix-system-info::dump-image)'
'';
installPhase = ''
mkdir -p $out/bin
cp quicklisp-to-nix-system-info $out/bin
'';
dontStrip = true;
};
quicklisp-to-nix = stdenv.mkDerivation rec {
name = "quicklisp-to-nix-${version}";
version = "1.0.0";
src = ./quicklisp-to-nix;
buildDependencies = [sbcl quicklisp-to-nix-system-info];
touch = coreutils;
nix-prefetch-url = nix;
inherit quicklisp;
deps = [];
system-info = quicklisp-to-nix-system-info;
buildPhase = ''
${sbcl}/bin/sbcl --eval '(load #P"${asdf}/lib/common-lisp/asdf/build/asdf.lisp")' --load $src/ql-to-nix.lisp --eval '(ql-to-nix::dump-image)'
'';
installPhase = ''
mkdir -p $out/bin
cp quicklisp-to-nix $out/bin
'';
dontStrip = true;
};
};
in lispPackages

13
pkgs/development/lisp-modules/quicklisp-to-nix-aliases.nix
View file

@ -1,13 +0,0 @@
{quicklisp-to-nix-packages}:
with quicklisp-to-nix-packages;
rec {
cffi-grovel = cffi;
cxml-test = null;
cxml-dom = null;
cxml-klacks = null;
cxml-xml = null;
cl-async-util = cl-async-base;
cl-async = cl-async-base;
}

7
pkgs/development/lisp-modules/quicklisp-to-nix-overrides.lisp
View file

@ -1,7 +0,0 @@
(setf
(gethash "cxml-xml" testnames) "cxml"
(gethash "cxml-dom" testnames) "cxml"
(gethash "cxml-test" testnames) "cxml"
(gethash "cxml-klacks" testnames) "cxml"
(gethash "cl-async-base" testnames) "cl-async"
)

130
pkgs/development/lisp-modules/quicklisp-to-nix-overrides.nix
View file

@ -5,7 +5,6 @@ let
skipBuildPhase = x: {
overrides = y: ((x.overrides y) // { buildPhase = "true"; });
};
qlnp = quicklisp-to-nix-packages;
multiOverride = l: x: if l == [] then {} else
((builtins.head l) x) // (multiOverride (builtins.tail l) x);
in
@ -23,9 +22,6 @@ in
cp "$out/lib/common-lisp/stumpwm/stumpwm" "$out/bin"
'';
};
propagatedBuildInputs = (x.propagatedBuildInputs or []) ++ (with qlnp; [
alexandria cl-ppcre clx
]);
};
iterate = skipBuildPhase;
cl-fuse = x: {
@ -45,84 +41,16 @@ in
iolib = x: rec {
propagatedBuildInputs = (x.propagatedBuildInputs or [])
++ (with pkgs; [libfixposix gcc])
++ (with qlnp; [
alexandria split-sequence cffi bordeaux-threads idna swap-bytes
])
;
testSystems = ["iolib" "iolib/syscalls" "iolib/multiplex" "iolib/streams"
"iolib/zstreams" "iolib/sockets" "iolib/trivial-sockets"
"iolib/pathnames" "iolib/os"];
version = "0.8.3";
src = pkgs.fetchFromGitHub {
owner = "sionescu";
repo = "iolib";
rev = "v${version}";
sha256 = "0pa86bf3jrysnmhasbc0lm6cid9xzril4jsg02g3gziav1xw5x2m";
};
};
iolib_slash_syscalls = x: rec {
propagatedBuildInputs = (x.propagatedBuildInputs or [])
++ (with pkgs; [libfixposix gcc])
++ (with qlnp; [
alexandria split-sequence cffi bordeaux-threads idna swap-bytes
])
;
testSystems = ["iolib" "iolib/syscalls" "iolib/multiplex" "iolib/streams"
"iolib/zstreams" "iolib/sockets" "iolib/trivial-sockets"
"iolib/pathnames" "iolib/os"];
version = "0.8.3";
src = pkgs.fetchFromGitHub {
owner = "sionescu";
repo = "iolib";
rev = "v${version}";
sha256 = "0pa86bf3jrysnmhasbc0lm6cid9xzril4jsg02g3gziav1xw5x2m";
};
};
cl-unicode = addDeps (with qlnp; [cl-ppcre flexi-streams]);
clack = addDeps (with qlnp;[lack bordeaux-threads prove]);
clack-v1-compat = addDeps (with qlnp;[
lack bordeaux-threads prove usocket dexador http-body trivial-backtrace
marshal local-time cl-base64 cl-ppcre quri trivial-mimes trivial-types
flexi-streams circular-streams ironclad cl-syntax-annot alexandria
split-sequence
]);
lack = addDeps (with qlnp; [ironclad]);
cxml = multiOverride [ skipBuildPhase (addDeps (with qlnp; [
closure-common puri trivial-gray-streams
]))];
wookie = multiOverride [(addDeps (with qlnp; [
alexandria blackbird cl-async chunga fast-http quri babel cl-ppcre
cl-fad fast-io vom do-urlencode cl-async-ssl
]))
(addNativeLibs (with pkgs; [libuv openssl]))];
woo = addDeps (with qlnp; [
cffi lev clack swap-bytes static-vectors fast-http proc-parse quri fast-io
trivial-utf-8 vom
]);
cxml = skipBuildPhase;
wookie = addNativeLibs (with pkgs; [libuv openssl]);
lev = addNativeLibs [pkgs.libev];
dexador = addDeps (with qlnp; [
usocket fast-http quri fast-io chunga cl-ppcre cl-cookie trivial-mimes
chipz cl-base64 cl-reexport qlnp."cl+ssl" alexandria bordeaux-threads
]);
fast-http = addDeps (with qlnp; [
alexandria cl-utilities proc-parse xsubseq smart-buffer
]);
cl-emb = addDeps (with qlnp; [cl-ppcre]);
"cl+ssl" = addNativeLibs [pkgs.openssl];
cl-colors = skipBuildPhase;
cl-libuv = addNativeLibs [pkgs.libuv];
cl-async = addDeps (with qlnp; [cl-async-base]);
cl-async-ssl = multiOverride [(addDeps (with qlnp; [cl-async-base]))
(addNativeLibs [pkgs.openssl])];
cl-async-repl = addDeps (with qlnp; [cl-async]);
cl-async-base = addDeps (with qlnp; [
cffi fast-io vom cl-libuv cl-ppcre trivial-features static-vectors
trivial-gray-streams babel
]);
cl-async-util = addDeps (with qlnp; [ cl-async-base ]);
css-lite = addDeps (with qlnp; [parenscript]);
cl-async-ssl = addNativeLibs [pkgs.openssl];
cl-async-test = addNativeLibs [pkgs.openssl];
clsql = x: {
propagatedBuildInputs = with pkgs; [mysql postgresql sqlite zlib];
overrides = y: (x.overrides y) // {
@ -146,17 +74,7 @@ in
'';
};
};
cffi = multiOverride [(addNativeLibs [pkgs.libffi])
(addDeps (with qlnp; [uffi uiop trivial-features]))];
cl-vectors = addDeps (with qlnp; [zpb-ttf]);
cl-paths-ttf = addDeps (with qlnp; [zpb-ttf]);
"3bmd" = addDeps (with qlnp; [esrap split-sequence]);
cl-dbi = addDeps (with qlnp; [
cl-syntax cl-syntax-annot split-sequence closer-mop bordeaux-threads
]);
dbd-sqlite3 = addDeps (with qlnp; [cl-dbi]);
dbd-postgres = addDeps (with qlnp; [cl-dbi]);
dbd-mysql = addDeps (with qlnp; [cl-dbi]);
cffi = addNativeLibs [pkgs.libffi];
cl-mysql = addNativeLibs [pkgs.mysql];
cl-ppcre-template = x: {
overrides = y: (x.overrides y) // {
@ -164,21 +82,10 @@ in
ln -s lib-dependent/*.asd .
'';
};
propagatedBuildInputs = (x.propagatedBuildInputs or []) ++ (with qlnp; [
cl-ppcre
]);
};
cl-unification = addDeps (with qlnp; [cl-ppcre]);
cl-syntax-annot = addDeps (with qlnp; [cl-syntax]);
cl-syntax-anonfun = addDeps (with qlnp; [cl-syntax]);
cl-syntax-markup = addDeps (with qlnp; [cl-syntax]);
cl-test-more = addDeps (with qlnp; [prove]);
babel-streams = addDeps (with qlnp; [babel trivial-gray-streams]);
babel = addDeps (with qlnp; [trivial-features alexandria]);
plump = addDeps (with qlnp; [array-utils trivial-indent]);
sqlite = addNativeLibs [pkgs.sqlite];
uiop = x: {
testSystems = (x.testSystems or ["uiop"]) ++ [
parasites = (x.parasites or []) ++ [
"uiop/version"
];
overrides = y: (x.overrides y) // {
@ -192,28 +99,5 @@ in
postConfigure = "rm GNUmakefile";
};
};
esrap = addDeps (with qlnp; [alexandria]);
fast-io = addDeps (with qlnp; [
alexandria trivial-gray-streams static-vectors
]);
hu_dot_dwim_dot_def = addDeps (with qlnp; [
hu_dot_dwim_dot_asdf alexandria anaphora iterate metabang-bind
]);
ironclad = addDeps (with qlnp; [nibbles flexi-streams]);
ixf = addDeps (with qlnp; [
split-sequence md5 alexandria babel local-time cl-ppcre ieee-floats
]);
jonathan = addDeps (with qlnp; [
cl-syntax cl-syntax-annot fast-io proc-parse cl-ppcre
]);
local-time = addDeps (with qlnp; [cl-fad]);
lquery = addDeps (with qlnp; [array-utils form-fiddle plump clss]);
clss = addDeps (with qlnp; [array-utils plump]);
form-fiddle = addDeps (with qlnp; [documentation-utils]);
documentation-utils = addDeps (with qlnp; [trivial-indent]);
mssql = x: {
testSystems = [];
};
cl-postgres = addDeps (with qlnp; [cl-ppcre md5]);
postmodern = addDeps (with qlnp; [md5]);
mssql = addNativeLibs [pkgs.freetds];
}

23
pkgs/development/lisp-modules/quicklisp-to-nix/nix-package.emb
View file

@ -1,9 +1,9 @@
args @ { fetchurl, ... }:
rec {
baseName = ''<% @var filename %>'';
version = ''<% @var version %>'';<% @if testname %>
version = ''<% @var version %>'';<% @if parasites %>
testSystems = ["<% @var testname %>"];<% @endif %>
parasites = [<% (dolist (p (getf env :parasites)) (format t " \"~A\"" p)) %> ];<% @endif %>
description = ''<% @var description %>'';
@ -13,23 +13,10 @@ rec {
url = ''<% @var url %>'';
sha256 = ''<% @var sha256 %>'';
};
packageName = "<% @var name %>";
overrides = x: {
postInstall = ''
find "$out/lib/common-lisp/" -name '*.asd' | grep -iv '/<% @var name %>[.]asd${"$"}' |
while read f; do
env -i \
NIX_LISP="$NIX_LISP" \
NIX_LISP_PRELAUNCH_HOOK="nix_lisp_run_single_form '(progn
(asdf:load-system :$(basename "$f" .asd))
(asdf:perform (quote asdf:compile-bundle-op) :$(basename "$f" .asd))
(ignore-errors (asdf:perform (quote asdf:deliver-asd-op) :$(basename "$f" .asd)))
)'" \
"$out"/bin/*-lisp-launcher.sh ||
mv "$f"{,.sibling}; done || true
'';
};
asdFilesToKeep = ["<% @var name %>.asd"];
overrides = x: x;
}
/* <%= cl-emb-intern::topenv %> */

1
pkgs/development/lisp-modules/quicklisp-to-nix/parasitic-invocation.emb Normal file
View file

@ -0,0 +1 @@
"<% @var filename %>" = quicklisp-to-nix-packages."<% @var host-filename %>";

407
pkgs/development/lisp-modules/quicklisp-to-nix/ql-to-nix.lisp
View file

@ -1,137 +1,212 @@
; QuickLisp-to-Nix export
; Requires QuickLisp to be loaded
; Installs the QuickLisp version of all the packages processed (in the
; QuickLisp instance it uses)
(unless (find-package :ql-to-nix-util)
(load "util.lisp"))
(unless (find-package :ql-to-nix-quicklisp-bootstrap)
(load "quicklisp-bootstrap.lisp"))
(defpackage :ql-to-nix
(:use :common-lisp :ql-to-nix-util :ql-to-nix-quicklisp-bootstrap))
(in-package :ql-to-nix)
(ql:quickload :cl-emb)
(ql:quickload :external-program)
(ql:quickload :cl-ppcre)
(ql:quickload :alexandria)
(ql:quickload :md5)
;; We're going to pull in our dependencies at image dumping time in an
;; isolated quicklisp installation. Unfortunately, that means that we
;; can't yet access the symbols for our dependencies. We can probably
;; do better (by, say, loading these dependencies before this file),
;; but...
(defvar testnames (make-hash-table :test 'equal))
(defvar *required-systems* nil)
(defun nix-prefetch-url (url)
(let*
((stdout nil)
(stderr nil))
(setf
stdout
(with-output-to-string (so)
(setf
stderr
(with-output-to-string (se)
(external-program:run
"nix-prefetch-url"
(list url)
:search t :output so :error se)))))
(let*
((path-line (first (last (cl-ppcre:split (format nil "~%") stderr))))
(path (cl-ppcre:regex-replace-all "path is .(.*)." path-line "\\1")))
(list
:sha256 (first (cl-ppcre:split (format nil "~%") stdout))
:path path
:md5 (string-downcase
(format nil "~{~16,2,'0r~}"
(map 'list 'identity (md5:md5sum-file path))))))))
(push :cl-emb *required-systems*)
(wrap :cl-emb register-emb)
(wrap :cl-emb execute-emb)
(push :external-program *required-systems*)
(wrap :external-program run)
(push :cl-ppcre *required-systems*)
(wrap :cl-ppcre split)
(wrap :cl-ppcre regex-replace-all)
(wrap :cl-ppcre scan)
(push :alexandria *required-systems*)
(wrap :alexandria read-file-into-string)
(wrap :alexandria write-string-into-file)
(push :md5 *required-systems*)
(wrap :md5 md5sum-file)
(wrap :ql-dist find-system)
(wrap :ql-dist release)
(wrap :ql-dist provided-systems)
(wrap :ql-dist archive-url)
(wrap :ql-dist local-archive-file)
(wrap :ql-dist ensure-local-archive-file)
(wrap :ql-dist archive-md5)
(wrap :ql-dist name)
(wrap :ql-dist short-description)
(defun escape-filename (s)
(format
nil "~a~{~a~}"
(if (cl-ppcre:scan "^[a-zA-Z_]" s) "" "_")
(loop
nil "~a~{~a~}"
(if (scan "^[a-zA-Z_]" s) "" "_")
(loop
for x in (map 'list 'identity s)
collect
(case x
(#\/ "_slash_")
(#\\ "_backslash_")
(#\_ "__")
(#\. "_dot_")
(t x)))))
(case x
(#\/ "_slash_")
(#\\ "_backslash_")
(#\_ "__")
(#\. "_dot_")
(t x)))))
(defun system-depends-on (system-name)
(labels
((decode (name)
(typecase name
(string
name)
(cons
(ecase (car name)
(:version (second name)))))))
(let* ((asdf-dependencies (asdf:system-depends-on (asdf:find-system system-name)))
(decoded-asdf-dependencies (mapcar #'decode asdf-dependencies))
(clean-asdf-dependencies (remove-if-not 'ql-dist:find-system decoded-asdf-dependencies))
(ql-dependencies (ql-dist:required-systems (ql-dist:find-system system-name)))
(all-dependencies (concatenate 'list clean-asdf-dependencies ql-dependencies))
(sorted-dependencies (sort all-dependencies #'string<))
(unique-dependencies (remove-duplicates sorted-dependencies :test #'equal)))
unique-dependencies)))
(defvar *system-info-bin*
(let* ((path (uiop:getenv "system-info"))
(path-dir (if (equal #\/ (aref path (1- (length path))))
path
(concatenate 'string path "/")))
(pathname (parse-namestring path-dir)))
(merge-pathnames #P"bin/quicklisp-to-nix-system-info" pathname))
"The path to the quicklisp-to-nix-system-info binary.")
(defvar *cache-dir* nil
"The folder where fasls will be cached.")
(defun raw-system-info (system-name)
"Run quicklisp-to-nix-system-info on the given system and return the
form produced by the program."
(when *cache-dir*
(let ((command `(,*system-info-bin* "--cacheDir" ,(namestring *cache-dir*) ,system-name)))
(handler-case
(return-from raw-system-info
(read (make-string-input-stream (uiop:run-program command :output :string))))
(error (e)
;; Some systems don't like the funky caching that we're
;; doing. That's okay. Let's try it uncached before we
;; give up.
(warn "Unable to use cache for system ~A.~%~A" system-name e)))))
(read (make-string-input-stream (uiop:run-program `(,*system-info-bin* ,system-name) :output :string))))
(defvar *system-data-memoization-path* nil
"The path to the folder where fully-resolved system information can
be cached.
If information for a system is found in this directory, `system-data'
will use it instead of re-computing the system data.")
(defvar *system-data-in-memory-memoization*
(make-hash-table :test #'equalp))
(defun memoized-system-data-path (system)
"Return the path to the file that (if it exists) contains
pre-computed system data."
(when *system-data-memoization-path*
(merge-pathnames (make-pathname :name system :type "txt") *system-data-memoization-path*)))
(defun memoized-system-data (system)
"Attempts to locate memoized system data in the path specified by
`*system-data-memoization-path*'."
(multiple-value-bind (value found) (gethash system *system-data-in-memory-memoization*)
(when found
(return-from memoized-system-data (values value found))))
(let ((path (memoized-system-data-path system)))
(unless path
(return-from memoized-system-data (values nil nil)))
(with-open-file (s path :if-does-not-exist nil :direction :input)
(unless s
(return-from memoized-system-data (values nil nil)))
(return-from memoized-system-data (values (read s) t)))))
(defun set-memoized-system-data (system data)
"Store system data in the path specified by
`*system-data-memoization-path*'."
(setf (gethash system *system-data-in-memory-memoization*) data)
(let ((path (memoized-system-data-path system)))
(unless path
(return-from set-memoized-system-data data))
(with-open-file (s path :direction :output :if-exists :supersede)
(format s "~W" data)))
data)
(defun system-data (system)
(let*
((asdf-system
(or
(ignore-errors (asdf:find-system system))
(progn
(ql:quickload system)
(asdf:find-system system))))
(ql-system (ql-dist:find-system system))
(ql-release (ql-dist:release ql-system))
(ql-sibling-systems (ql-dist:provided-systems ql-release))
(url (ql-dist:archive-url ql-release))
(local-archive (ql-dist:local-archive-file ql-release))
(local-url (format nil "file://~a" (pathname local-archive)))
(archive-data
(progn
(ql-dist:ensure-local-archive-file ql-release)
(nix-prefetch-url local-url)))
(ideal-md5 (ql-dist:archive-md5 ql-release))
(file-md5 (getf archive-data :md5))
(raw-dependencies (system-depends-on system))
(name (string-downcase (format nil "~a" system)))
(ql-sibling-names
(remove name (mapcar 'ql-dist:name ql-sibling-systems)
:test 'equal))
(dependencies
(set-difference
(remove-duplicates
(remove-if-not 'ql-dist:find-system raw-dependencies)
:test 'equal)
ql-sibling-names
:test 'equal))
(deps (mapcar (lambda (x) (list :name x :filename (escape-filename x)))
dependencies))
(description (asdf:system-description asdf-system))
(release-name (ql-dist:short-description ql-release))
(version (cl-ppcre:regex-replace-all
(format nil "~a-" name) release-name "")))
(assert (equal ideal-md5 file-md5))
(list
:system system
:description description
:sha256 (getf archive-data :sha256)
:url url
:md5 file-md5
:name name
:testname (gethash name testnames)
:filename (escape-filename name)
:deps deps
:dependencies dependencies
:version version
:siblings ql-sibling-names)))
"Examine a quicklisp system name and figure out everything that is
required to produce a nix package.
(defmacro this-file ()
(or *compile-file-truename*
*load-truename*))
This function stores results for memoization purposes in files within
`*system-data-memoization-path*'."
(multiple-value-bind (value found) (memoized-system-data system)
(when found
(return-from system-data value)))
(format t "Examining system ~A~%" system)
(let* ((system-info (raw-system-info system))
(host (getf system-info :host))
(host-name (getf system-info :host-name))
(name (getf system-info :name)))
(when host
(return-from system-data
(set-memoized-system-data
system
(list
:system (getf system-info :system)
:host host
:filename (escape-filename name)
:host-filename (escape-filename host-name)))))
(let* ((url (getf system-info :url))
(sha256 (getf system-info :sha256))
(archive-data (nix-prefetch-url url :expected-sha256 sha256))
(archive-path (getf archive-data :path))
(archive-md5 (string-downcase
(format nil "~{~16,2,'0r~}"
(map 'list 'identity (md5sum-file archive-path)))))
(stated-md5 (getf system-info :md5))
(dependencies (getf system-info :dependencies))
(deps (mapcar (lambda (x) (list :name x :filename (escape-filename x)))
dependencies))
(description (getf system-info :description))
(siblings (getf system-info :siblings))
(release-name (getf system-info :release-name))
(parasites (getf system-info :parasites))
(version (regex-replace-all
(format nil "~a-" name) release-name "")))
(assert (equal archive-md5 stated-md5))
(set-memoized-system-data
system
(list
:system system
:description description
:sha256 sha256
:url url
:md5 stated-md5
:name name
:filename (escape-filename name)
:deps deps
:dependencies dependencies
:version version
:siblings siblings
:parasites parasites)))))
(defun parasitic-p (data)
(getf data :host))
(defvar *loaded-from* (or *compile-file-truename* *load-truename*)
"Where this source file is located.")
(defun this-file ()
"Where this source file is located or an error."
(or *loaded-from* (error "Not sure where this file is located!")))
(defun nix-expression (system)
(cl-emb:execute-emb
(merge-pathnames #p"nix-package.emb" (this-file))
(execute-emb
"nix-package"
:env (system-data system)))
(defun nix-invocation (system)
(cl-emb:execute-emb
(merge-pathnames #p"invocation.emb" (this-file))
:env (system-data system)))
(let ((data (system-data system)))
(if (parasitic-p data)
(execute-emb
"parasitic-invocation"
:env data)
(execute-emb
"invocation"
:env data))))
(defun systems-closure (systems)
(let*
@ -153,29 +228,97 @@
finally (return res))))
(defun ql-to-nix (target-directory)
(load (format nil "~a/quicklisp-to-nix-overrides.lisp" target-directory))
(let*
((systems
(cl-ppcre:split
(split
(format nil "~%")
(alexandria:read-file-into-string
(format nil "~a/quicklisp-to-nix-systems.txt" target-directory))))
(read-file-into-string
(format nil "~a/quicklisp-to-nix-systems.txt" target-directory))))
(closure (systems-closure systems))
(invocations
(loop for s in closure
collect (list :code (nix-invocation s)))))
(loop
for s in closure
do (alexandria:write-string-into-file
(nix-expression s)
(format nil "~a/quicklisp-to-nix-output/~a.nix"
target-directory (escape-filename s))
:if-exists :supersede))
(alexandria:write-string-into-file
(cl-emb:execute-emb
(merge-pathnames
#p"top-package.emb"
(this-file))
do (unless (parasitic-p (system-data s))
(write-string-into-file
(nix-expression s)
(format nil "~a/quicklisp-to-nix-output/~a.nix"
target-directory (escape-filename s))
:if-exists :supersede)))
(write-string-into-file
(execute-emb
"top-package"
:env (list :invocations invocations))
(format nil "~a/quicklisp-to-nix.nix" target-directory)
:if-exists :supersede)))
(defun print-usage-and-quit ()
"Does what it says on the tin."
(format *error-output* "Usage:
~A [--help] [--cacheSystemInfoDir <path>] <work-dir>
Arguments:
--cacheSystemInfoDir Store computed system info in the given directory
--help Print usage and exit
<work-dir> Path to directory with quicklisp-to-nix-systems.txt
" (uiop:argv0))
(uiop:quit 2))
(defun main ()
"Make it go"
(let ((argv (uiop:command-line-arguments))
work-directory
cache-system-info-directory
cache-fasl-directory)
(loop :while argv :for arg = (pop argv) :do
(cond
((equal arg "--cacheSystemInfoDir")
(unless argv
(format *error-output* "--cacheSystemInfoDir requires an argument~%")
(print-usage-and-quit))
(setf cache-system-info-directory (pop argv)))
((equal arg "--cacheFaslDir")
(unless argv
(format *error-output* "--cacheFaslDir requires an argument~%")
(print-usage-and-quit))
(setf cache-fasl-directory (pop argv)))
((equal arg "--help")
(print-usage-and-quit))
(t
(when argv
(format *error-output* "Only one positional argument allowed~%")
(print-usage-and-quit))
(setf work-directory arg))))
(when cache-system-info-directory
(setf cache-system-info-directory (pathname-as-directory (pathname cache-system-info-directory)))
(ensure-directories-exist cache-system-info-directory))
(labels
((make-go (*cache-dir*)
(format t "Caching fasl files in ~A~%" *cache-dir*)
(let ((*system-data-memoization-path* cache-system-info-directory))
(ql-to-nix work-directory))))
(if cache-fasl-directory
(make-go (truename (pathname-as-directory (parse-namestring (ensure-directories-exist cache-fasl-directory)))))
(with-temporary-directory (*cache-dir*)
(make-go *cache-dir*))))))
(defun dump-image ()
"Make an executable"
(with-quicklisp (dir) ()
(declare (ignore dir))
(dolist (system *required-systems*)
(funcall (sym :ql :quickload) system)))
(register-emb "nix-package" (merge-pathnames #p"nix-package.emb" (this-file)))
(register-emb "invocation" (merge-pathnames #p"invocation.emb" (this-file)))
(register-emb "parasitic-invocation" (merge-pathnames #p"parasitic-invocation.emb" (this-file)))
(register-emb "top-package" (merge-pathnames #p"top-package.emb" (this-file)))
(setf uiop:*image-entry-point* #'main)
(setf uiop:*lisp-interaction* nil)
(setf *loaded-from* nil) ;; Break the link to our source
(uiop:dump-image "quicklisp-to-nix" :executable t))

76
pkgs/development/lisp-modules/quicklisp-to-nix/quicklisp-bootstrap.lisp Normal file
View file

@ -0,0 +1,76 @@
(unless (find-package :ql-to-nix-util)
(load "ql-to-nix-util.lisp"))
(defpackage :ql-to-nix-quicklisp-bootstrap
(:use :common-lisp :ql-to-nix-util)
(:export #:with-quicklisp)
(:documentation
"This package provides a way to create a temporary quicklisp installation."))
(in-package :ql-to-nix-quicklisp-bootstrap)
(declaim (optimize (debug 3) (speed 0) (space 0) (compilation-speed 0) (safety 3)))
;; This file cannot have any dependencies beyond quicklisp and asdf.
;; Otherwise, we'll miss some dependencies!
(defvar *quicklisp*
(namestring (pathname-as-directory (uiop:getenv "quicklisp")))
"The path to the nix quicklisp package.")
(defun prepare-quicklisp-dir (target-dir quicklisp-prototype-dir)
"Install quicklisp into the specified `target-dir'.
`quicklisp-prototype-dir' should be the path to the quicklisp nix
package."
(ensure-directories-exist target-dir)
(dolist (subdir '(#P"dists/quicklisp/" #P"tmp/" #P"local-projects/" #P"quicklisp/"))
(ensure-directories-exist (merge-pathnames subdir target-dir)))
(with-open-file (s (merge-pathnames #P"dists/quicklisp/enabled.txt" target-dir) :direction :output :if-exists :supersede)
(format s "1~%"))
(uiop:copy-file
(merge-pathnames #P"lib/common-lisp/quicklisp/quicklisp-distinfo.txt" quicklisp-prototype-dir)
(merge-pathnames #P"dists/quicklisp/distinfo.txt" target-dir))
(uiop:copy-file
(merge-pathnames #P"lib/common-lisp/quicklisp/asdf.lisp" quicklisp-prototype-dir)
(merge-pathnames #P"asdf.lisp" target-dir))
(uiop:copy-file
(merge-pathnames #P"lib/common-lisp/quicklisp/setup.lisp" quicklisp-prototype-dir)
(merge-pathnames #P"setup.lisp" target-dir))
(copy-directory-tree
(merge-pathnames #P"lib/common-lisp/quicklisp/quicklisp/" quicklisp-prototype-dir)
(merge-pathnames #P"quicklisp/" target-dir)))
(defun call-with-quicklisp (function &key (target-dir :temp) (cache-dir :temp))
"Invoke the given function with the path to a quicklisp installation.
Quicklisp will be loaded before the function is called. `target-dir'
can either be a pathname for the place where quicklisp should be
installed or `:temp' to request installation in a temporary directory.
`cache-dir' can either be a pathname for a place to store fasls or
`:temp' to request caching in a temporary directory."
(when (find-package :ql)
(error "Already loaded quicklisp in this process"))
(labels
((make-ql (ql-dir)
(prepare-quicklisp-dir ql-dir *quicklisp*)
(with-temporary-asdf-cache (ql-dir)
(load (merge-pathnames #P"setup.lisp" ql-dir))
(if (eq :temp cache-dir)
(funcall function ql-dir)
(with-asdf-cache (ql-dir cache-dir)
(funcall function ql-dir))))))
(if (eq :temp target-dir)
(with-temporary-directory (dir)
(make-ql dir))
(make-ql target-dir))))
(defmacro with-quicklisp ((quicklisp-dir) (&key (cache-dir :temp)) &body body)
"Install quicklisp in a temporary directory, load it, bind
`quicklisp-dir' to the path where quicklisp was installed, and then
evaluate `body'.
`cache-dir' can either be a pathname for a place to store fasls or
`:temp' to request caching in a temporary directory."
`(call-with-quicklisp
(lambda (,quicklisp-dir)
,@body)
:cache-dir ,cache-dir))

473
pkgs/development/lisp-modules/quicklisp-to-nix/system-info.lisp Normal file
View file

@ -0,0 +1,473 @@
(unless (find-package :ql-to-nix-util)
(load "util.lisp"))
(unless (find-package :ql-to-nix-quicklisp-bootstrap)
(load "quicklisp-bootstrap.lisp"))
(defpackage :ql-to-nix-system-info
(:use :common-lisp :ql-to-nix-quicklisp-bootstrap :ql-to-nix-util)
(:export #:dump-image))
(in-package :ql-to-nix-system-info)
(declaim (optimize (debug 3) (speed 0) (space 0) (compilation-speed 0) (safety 3)))
;; This file cannot have any dependencies beyond quicklisp and asdf.
;; Otherwise, we'll miss some dependencies!
;; We can't load quicklisp until runtime (at which point we'll create
;; an isolated quicklisp installation). These wrapper functions are
;; nicer than funcalling intern'd symbols every time we want to talk
;; to quicklisp.
(wrap :ql apply-load-strategy)
(wrap :ql compute-load-strategy)
(wrap :ql show-load-strategy)
(wrap :ql quicklisp-systems)
(wrap :ql ensure-installed)
(wrap :ql quicklisp-releases)
(wrap :ql-dist archive-md5)
(wrap :ql-dist archive-url)
(wrap :ql-dist ensure-local-archive-file)
(wrap :ql-dist find-system)
(wrap :ql-dist local-archive-file)
(wrap :ql-dist name)
(wrap :ql-dist provided-systems)
(wrap :ql-dist release)
(wrap :ql-dist short-description)
(wrap :ql-dist system-file-name)
(wrap :ql-impl-util call-with-quiet-compilation)
(defvar *version* (uiop:getenv "version")
"The version number of this program")
(defvar *main-system* nil
"The name of the system we're trying to extract info from.")
(defvar *found-parasites* (make-hash-table :test #'equalp)
"Names of systems which have been identified as parasites.
A system is parasitic if its name doesn't match the name of the file
it is defined in. So, for example, if foo and foo-bar are both
defined in a file named foo.asd, foo would be the host system and
foo-bar would be a parasitic system.
Parasitic systems are not generally loaded without loading the host
system first.
Keys are system names. Values are unspecified.")
(defvar *found-dependencies* (make-hash-table :test #'equalp)
"Hash table containing the set of dependencies discovered while installing a system.
Keys are system names. Values are unspecified.")
(defun decode-asdf-dependency (name)
"Translates an asdf system dependency description into a system name.
For example, translates (:version :foo \"1.0\") into \"foo\"."
(etypecase name
(symbol
(setf name (symbol-name name)))
(string)
(cons
(ecase (first name)
(:version
(warn "Discarding version information ~A" name)
;; There's nothing we can do about this. If the version we
;; have around is good enough, then we're golden. If it isn't
;; good enough, then we'll error out and let a human figure it
;; out.
(setf name (second name))
(return-from decode-asdf-dependency
(decode-asdf-dependency name)))
(:feature
(if (find (second name) *features*)
(return-from decode-asdf-dependency
(decode-asdf-dependency (third name)))
(progn
(warn "Dropping dependency due to missing feature: ~A" name)
(return-from decode-asdf-dependency nil))))
(:require
;; This probably isn't a dependency we can satisfy using
;; quicklisp, but we might as well try anyway.
(return-from decode-asdf-dependency
(decode-asdf-dependency (second name)))))))
(string-downcase name))
(defun found-new-parasite (system-name)
"Record that the given system has been identified as a parasite."
(setf system-name (decode-asdf-dependency system-name))
(setf (gethash system-name *found-parasites*) t)
(when (nth-value 1 (gethash system-name *found-dependencies*))
(error "Found dependency on parasite")))
(defun known-parasite-p (system-name)
"Have we previously identified this system as a parasite?"
(nth-value 1 (gethash system-name *found-parasites*)))
(defun found-parasites ()
"Return a vector containing all identified parasites."
(let ((systems (make-array (hash-table-size *found-parasites*) :fill-pointer 0)))
(loop :for system :being :the :hash-keys :of *found-parasites* :do
(vector-push system systems))
systems))
(defvar *track-dependencies* nil
"When this variable is nil, found-new-dependency will not record
depdendencies.")
(defun parasitic-relationship-p (potential-host potential-parasite)
"Returns t if potential-host and potential-parasite have a parasitic relationship.
See `*found-parasites*'."
(let ((host-ql-system (find-system potential-host))
(parasite-ql-system (find-system potential-parasite)))
(and host-ql-system parasite-ql-system
(not (equal (name host-ql-system)
(name parasite-ql-system)))
(equal (system-file-name host-ql-system)
(system-file-name parasite-ql-system)))))
(defun found-new-dependency (name)
"Record that the given system has been identified as a dependency.
The named system may not be recorded as a dependency. It may be left
out for any number of reasons. For example, if `*track-dependencies*'
is nil then this function does nothing. If the named system isn't a
quicklisp system, this function does nothing."
(setf name (decode-asdf-dependency name))
(unless name
(return-from found-new-dependency))
(unless *track-dependencies*
(return-from found-new-dependency))
(when (known-parasite-p name)
(return-from found-new-dependency))
(when (parasitic-relationship-p *main-system* name)
(found-new-parasite name)
(return-from found-new-dependency))
(unless (find-system name)
(return-from found-new-dependency))
(setf (gethash name *found-dependencies*) t))
(defun forget-dependency (name)
"Whoops. Did I say that was a dependency? My bad.
Be very careful using this function! You can remove a system from the
dependency list, but you can't remove other effects associated with
this system. For example, transitive dependencies might still be in
the dependency list."
(setf name (decode-asdf-dependency name))
(remhash name *found-dependencies*))
(defun found-dependencies ()
"Return a vector containing all identified dependencies."
(let ((systems (make-array (hash-table-size *found-dependencies*) :fill-pointer 0)))
(loop :for system :being :the :hash-keys :of *found-dependencies* :do
(vector-push system systems))
systems))
(defun host-system (system-name)
"If the given system is a parasite, return the name of the system that is its host.
See `*found-parasites*'."
(let* ((system (find-system system-name))
(host-file (system-file-name system)))
(unless (equalp host-file system-name)
host-file)))
(defun get-loaded (system)
"Try to load the named system using quicklisp and record any
dependencies quicklisp is aware of.
Unlike `our-quickload', this function doesn't attempt to install
missing dependencies."
;; Let's get this party started!
(let* ((strategy (compute-load-strategy system))
(ql-systems (quicklisp-systems strategy)))
(dolist (dep ql-systems)
(found-new-dependency (name dep)))
(show-load-strategy strategy)
(labels
((make-go ()
(apply-load-strategy strategy)))
(call-with-quiet-compilation #'make-go)
(let ((asdf-system (asdf:find-system system)))
;; If ASDF says that it needed a system, then we should
;; probably track that.
(dolist (asdf-dep (asdf:component-sideway-dependencies asdf-system))
(found-new-dependency asdf-dep))
(dolist (asdf-dep (asdf:system-defsystem-depends-on asdf-system))
(found-new-dependency asdf-dep))))))
(defun our-quickload (system)
"Attempt to install a package like quicklisp would, but record any
dependencies that are detected during the install."
(setf system (string-downcase system))
;; Load it quickly, but do it OUR way. Turns out our way is very
;; similar to the quicklisp way...
(let ((already-tried (make-hash-table :test #'equalp))) ;; Case insensitive
(tagbody
retry
(handler-case
(get-loaded system)
(asdf/find-component:missing-dependency (e)
(let ((required-by (asdf/find-component:missing-required-by e))
(missing (asdf/find-component:missing-requires e)))
(unless (typep required-by 'asdf:system)
(error e))
(when (gethash missing already-tried)
(error "Dependency loop? ~A" missing))
(setf (gethash missing already-tried) t)
(let ((parasitic-p (parasitic-relationship-p *main-system* missing)))
(if parasitic-p
(found-new-parasite missing)
(found-new-dependency missing))
;; We always want to track the dependencies of systems
;; that share an asd file with the main system. The
;; whole asd file should be loadable. Otherwise, we
;; don't want to include transitive dependencies.
(let ((*track-dependencies* parasitic-p))
(our-quickload missing)))
(format t "Attempting to load ~A again~%" system)
(go retry)))))))
(defvar *blacklisted-parasites*
#("hu.dwim.stefil/documentation" ;; This system depends on :hu.dwim.stefil.test, but it should depend on hu.dwim.stefil/test
"named-readtables/doc" ;; Dependency cycle between named-readtabes and mgl-pax
"symbol-munger-test" ;; Dependency cycle between lisp-unit2 and symbol-munger
"cl-postgres-simple-date-tests" ;; Dependency cycle between cl-postgres and simple-date
"cl-containers/with-variates") ;; Symbol conflict between cl-variates:next-element, metabang.utilities:next-element
"A vector of systems that shouldn't be loaded by `quickload-parasitic-systems'.
These systems are known to be troublemakers. In some sense, all
parasites are troublemakers (you shouldn't define parasitic systems!).
However, these systems prevent us from generating nix packages and are
thus doubly evil.")
(defvar *blacklisted-parasites-table*
(let ((ht (make-hash-table :test #'equalp)))
(loop :for system :across *blacklisted-parasites* :do
(setf (gethash system ht) t))
ht)
"A hash table where each entry in `*blacklisted-parasites*' is an
entry in the table.")
(defun blacklisted-parasite-p (system-name)
"Returns non-nil if the named system is blacklisted"
(nth-value 1 (gethash system-name *blacklisted-parasites-table*)))
(defun quickload-parasitic-systems (system)
"Attempt to load all the systems defined in the same asd as the named system.
Blacklisted systems are skipped. Dependencies of the identified
parasitic systems will be tracked."
(let* ((asdf-system (asdf:find-system system))
(source-file (asdf:system-source-file asdf-system)))
(cond
(source-file
(loop :for system-name :being :the :hash-keys :of asdf/find-system:*defined-systems* :do
(when (and (parasitic-relationship-p system system-name)
(not (blacklisted-parasite-p system-name)))
(found-new-parasite system-name)
(let ((*track-dependencies* t))
(our-quickload system-name)))))
(t
(unless (or (equal "uiop" system)
(equal "asdf" system))
(warn "No source file for system ~A. Can't identify parasites." system))))))
(defun determine-dependencies (system)
"Load the named system and return a sorted vector containing all the
quicklisp systems that were loaded to satisfy dependencies.
This function should probably only be called once per process!
Subsequent calls will miss dependencies identified by earlier calls."
(tagbody
retry
(restart-case
(let ((*standard-output* (make-broadcast-stream))
(*trace-output* (make-broadcast-stream))
(*main-system* system)
(*track-dependencies* t))
(our-quickload system)
(quickload-parasitic-systems system))
(try-again ()
:report "Start the quickload over again"
(go retry))
(die ()
:report "Just give up and die"
(uiop:quit 1))))
;; Systems can't depend on themselves!
(forget-dependency system)
(values))
(defun parasitic-system-data (parasite-system)
"Return a plist of information about the given known-parastic system.
Sometimes we are asked to provide information about a system that is
actually a parasite. The only correct response is to point them
toward the host system. The nix package for the host system should
have all the dependencies for this parasite already recorded.
The plist is only meant to be consumed by other parts of
quicklisp-to-nix."
(let ((host-system (host-system parasite-system)))
(list
:system parasite-system
:host host-system
:name (string-downcase (format nil "~a" parasite-system))
:host-name (string-downcase (format nil "~a" host-system)))))
(defun system-data (system)
"Produce a plist describing a system.
The plist is only meant to be consumed by other parts of
quicklisp-to-nix."
(when (host-system system)
(return-from system-data
(parasitic-system-data system)))
(determine-dependencies system)
(let*
((dependencies (sort (found-dependencies) #'string<))
(parasites (coerce (sort (found-parasites) #'string<) 'list))
(ql-system (find-system system))
(ql-release (release ql-system))
(ql-sibling-systems (provided-systems ql-release))
(url (archive-url ql-release))
(local-archive (local-archive-file ql-release))
(local-url (format nil "file://~a" (pathname local-archive)))
(archive-data
(progn
(ensure-local-archive-file ql-release)
;; Stuff this archive into the nix store. It was almost
;; certainly going to end up there anyway (since it will
;; probably be fetchurl'd for a nix package). Also, putting
;; it into the store also gives us the SHA we need.
(nix-prefetch-url local-url)))
(ideal-md5 (archive-md5 ql-release))
(raw-dependencies (coerce dependencies 'list))
(name (string-downcase (format nil "~a" system)))
(ql-sibling-names
(remove name (mapcar 'name ql-sibling-systems)
:test 'equal))
(dependencies raw-dependencies)
(description (asdf:system-description (asdf:find-system system)))
(release-name (short-description ql-release)))
(list
:system system
:description description
:sha256 (getf archive-data :sha256)
:url url
:md5 ideal-md5
:name name
:dependencies dependencies
:siblings ql-sibling-names
:release-name release-name
:parasites parasites)))
(defvar *error-escape-valve* *error-output*
"When `*error-output*' is rebound to inhibit spew, this stream will
still produce output.")
(defun print-usage-and-quit ()
"Describe how to use this program... and then exit."
(format *error-output* "Usage:
~A [--cacheDir <dir>] [--silent] [--debug] [--help|-h] <system-name>
Arguments:
--cacheDir Store (and look for) compiled lisp files in the given directory
--verbose Show compilation output
--debug Enter the debugger when a fatal error is encountered
--help Print usage and exit
<system-name> The quicklisp system to examine
" (or (uiop:argv0) "quicklisp-to-nix-system-info"))
(uiop:quit 2))
(defun main ()
"Make it go."
(let ((argv (uiop:command-line-arguments))
cache-dir
target-system
verbose-p
debug-p)
(handler-bind
((warning
(lambda (w)
(format *error-escape-valve* "~A~%" w)))
(error
(lambda (e)
(if debug-p
(invoke-debugger e)
(progn
(format *error-escape-valve* "~
Failed to extract system info. Details are below. ~
Run with --debug and/or --verbose for more info.
~A~%" e)
(uiop:quit 1))))))
(loop :while argv :do
(cond
((equal "--cacheDir" (first argv))
(pop argv)
(unless argv
(error "--cacheDir expects an argument"))
(setf cache-dir (first argv))
(pop argv))
((equal "--verbose" (first argv))
(setf verbose-p t)
(pop argv))
((equal "--debug" (first argv))
(setf debug-p t)
(pop argv))
((or (equal "--help" (first argv))
(equal "-h" (first argv)))
(print-usage-and-quit))
(t
(setf target-system (pop argv))
(when argv
(error "Can only operate on one system")))))
(unless target-system
(print-usage-and-quit))
(when cache-dir
(setf cache-dir (pathname-as-directory (parse-namestring cache-dir))))
(with-quicklisp (dir) (:cache-dir (or cache-dir :temp))
(declare (ignore dir))
(let (system-data)
(let ((*error-output* (if verbose-p
*error-output*
(make-broadcast-stream)))
(*standard-output* (if verbose-p
*standard-output*
(make-broadcast-stream)))
(*trace-output* (if verbose-p
*trace-output*
(make-broadcast-stream))))
(format *error-output*
"quicklisp-to-nix-system-info ~A~%ASDF ~A~%Quicklisp ~A~%Compiler ~A ~A~%"
*version*
(asdf:asdf-version)
(funcall (intern "CLIENT-VERSION" :ql))
(lisp-implementation-type)
(lisp-implementation-version))
(setf system-data (system-data target-system)))
(cond
(system-data
(format t "~W~%" system-data)
(uiop:quit 0))
(t
(format *error-output* "Failed to determine system data~%")
(uiop:quit 1))))))))
(defun dump-image ()
"Make an executable"
(setf uiop:*image-entry-point* #'main)
(setf uiop:*lisp-interaction* nil)
(uiop:dump-image "quicklisp-to-nix-system-info" :executable t))

3
pkgs/development/lisp-modules/quicklisp-to-nix/top-package.emb
View file

@ -8,7 +8,6 @@ let quicklisp-to-nix-packages = rec {
<% @loop invocations %>
<% @var code %>
<% @endloop %>
} // qlAliases {inherit quicklisp-to-nix-packages;};
qlAliases = import ./quicklisp-to-nix-aliases.nix;
};
in
quicklisp-to-nix-packages

178
pkgs/development/lisp-modules/quicklisp-to-nix/util.lisp Normal file
View file

@ -0,0 +1,178 @@
(defpackage :ql-to-nix-util
(:use :common-lisp)
(:export #:nix-prefetch-url #:wrap #:pathname-as-directory #:copy-directory-tree #:with-temporary-directory #:sym #:with-temporary-asdf-cache #:with-asdf-cache)
(:documentation
"A collection of useful functions and macros that ql-to-nix will use."))
(in-package :ql-to-nix-util)
(declaim (optimize (debug 3) (speed 0) (space 0) (compilation-speed 0) (safety 3)))
;; This file cannot have any dependencies beyond quicklisp and asdf.
;; Otherwise, we'll miss some dependencies!
(defun pathname-as-directory (pathname)
"Given a pathname, make it into a path to a directory.
This is sort of like putting a / at the end of the path."
(unless (pathname-name pathname)
(return-from pathname-as-directory pathname))
(let* ((old-dir (pathname-directory pathname))
(old-name (pathname-name pathname))
(old-type (pathname-type pathname))
(last-dir
(cond
(old-type
(format nil "~A.~A" old-name old-type))
(t
old-name)))
(new-dir (if old-dir
(concatenate 'list old-dir (list last-dir))
(list :relative last-dir))))
(make-pathname :name nil :directory new-dir :type nil :defaults pathname)))
(defvar *nix-prefetch-url-bin*
(namestring (merge-pathnames #P"bin/nix-prefetch-url" (pathname-as-directory (uiop:getenv "nix-prefetch-url"))))
"The path to the nix-prefetch-url binary")
(defun nix-prefetch-url (url &key expected-sha256)
"Invoke the nix-prefetch-url program.
Returns a plist with two keys.
:sha256 => The sha of the fetched file
:path => The path to the file in the nix store"
(when expected-sha256
(setf expected-sha256 (list expected-sha256)))
(let* ((stdout
(with-output-to-string (so)
(uiop:run-program
`(,*nix-prefetch-url-bin* "--print-path" ,url ,@expected-sha256)
:output so)))
(stream (make-string-input-stream stdout)))
(list
:sha256 (read-line stream)
:path (read-line stream))))
(defmacro wrap (package symbol-name)
"Create a function which looks up the named symbol at runtime and
invokes it with the same arguments.
If you can't load a system until runtime, this macro gives you an
easier way to write
(funcall (intern \"SYMBOL-NAME\" :package-name) arg)
Instead, you can write
(wrap :package-name symbol-name)
(symbol-name arg)"
(let ((args (gensym "ARGS")))
`(defun ,symbol-name (&rest ,args)
(apply (sym ',package ',symbol-name) ,args))))
(defun copy-directory-tree (src-dir target-dir)
"Recursively copy every file in `src-dir' into `target-dir'.
This function traverses symlinks."
(when (or (not (pathname-directory target-dir))
(pathname-name target-dir))
(error "target-dir must be a dir"))
(when (or (not (pathname-directory src-dir))
(pathname-name src-dir))
(error "src-dir must be a dir"))
(let ((src-wild (make-pathname :name :wild :type :wild :defaults src-dir)))
(dolist (entity (uiop:directory* src-wild))
(if (pathname-name entity)
(uiop:copy-file entity (make-pathname :type (pathname-type entity) :name (pathname-name entity) :defaults target-dir))
(let ((new-target-dir
(make-pathname
:directory (concatenate 'list (pathname-directory target-dir) (last (pathname-directory entity))))))
(ensure-directories-exist new-target-dir)
(copy-directory-tree entity new-target-dir))))))
(defun call-with-temporary-directory (function)
"Create a temporary directory, invoke the given function by passing
in the pathname for the directory, and then delete the directory."
(let* ((dir (uiop:run-program '("mktemp" "-d") :output :line))
(parsed (parse-namestring dir))
(parsed-as-dir (pathname-as-directory parsed)))
(assert (uiop:absolute-pathname-p dir))
(unwind-protect
(funcall function parsed-as-dir)
(uiop:delete-directory-tree
parsed-as-dir
:validate
(lambda (path)
(and (uiop:absolute-pathname-p path)
(equal (subseq (pathname-directory path) 0 (length (pathname-directory parsed-as-dir)))
(pathname-directory parsed-as-dir))))))))
(defmacro with-temporary-directory ((dir-name) &body body)
"See `call-with-temporary-directory'."
`(call-with-temporary-directory (lambda (,dir-name) ,@body)))
(defun sym (package sym)
"A slightly less picky version of `intern'.
Unlike `intern', the `sym' argument can be a string or a symbol. If
it is a symbol, then the `symbol-name' is `intern'ed into the
specified package.
The arguments are also reversed so that the package comes first."
(etypecase sym
(symbol (setf sym (symbol-name sym)))
(string))
(intern sym package))
(defvar *touch-bin*
(namestring (merge-pathnames #P"bin/touch" (pathname-as-directory (uiop:getenv "touch"))))
"Path to the touch binary.")
(defvar *cache-dir* nil
"When asdf cache remapping is in effect (see `with-asdf-cache'),
this stores the path to the fasl cache directory.")
(defvar *src-dir* nil
"When asdf cache remapping is in effect (see `with-asdf-cache'),
this stores the path to the source directory.
Only lisp files within the source directory will have their fasls
cached in the cache directory.")
(defun remap (path prefix)
"Implements the cache policy described in `with-asdf-cache'."
(declare (ignore prefix))
(let* ((ql-dirs (pathname-directory *src-dir*))
(ql-dirs-length (length ql-dirs))
(path-prefix (subseq (pathname-directory path) 0 ql-dirs-length))
(path-postfix (subseq (pathname-directory path) ql-dirs-length)))
(unless (equal path-prefix ql-dirs)
(return-from remap path))
(let ((result (make-pathname :directory (concatenate 'list (pathname-directory *cache-dir*) path-postfix) :defaults path)))
(with-open-file (s result :direction :probe :if-does-not-exist nil)
(when s
(uiop:run-program `(,*touch-bin* ,(namestring result)))))
result)))
(defmacro with-temporary-asdf-cache ((src-dir) &body body)
"Create a temporary directory, and then use it as the ASDF cache
directory for source files in `src-dir'.
See `with-asdf-cache'."
(let ((tmp-dir (gensym "ORIGINAL-VALUE")))
`(with-temporary-directory (,tmp-dir)
(with-asdf-cache (,src-dir ,tmp-dir)
,@body))))
(defmacro with-asdf-cache ((src-dir cache-dir) &body body)
"When ASDF compiles a lisp file in `src-dir', store the fasl in `cache-dir'."
(let ((original-value (gensym "ORIGINAL-VALUE")))
`(let ((,original-value asdf:*output-translations-parameter*)
(*src-dir* ,src-dir)
(*cache-dir* ,cache-dir))
(unwind-protect
(progn
(asdf:initialize-output-translations
'(:output-translations
:INHERIT-CONFIGURATION
;; FIXME: Shouldn't we only be remaping things
;; actually in the src dir? Oh well.
(t (:function remap))))
,@body)
(asdf:initialize-output-translations ,original-value)))))

14
pkgs/development/lisp-modules/shell.nix Normal file
View file

@ -0,0 +1,14 @@
with import ../../../default.nix {};
let
self = rec {
name = "ql-to-nix";
env = buildEnv { name = name; paths = buildInputs; };
buildInputs = [
gcc stdenv
openssl fuse libuv mariadb libfixposix libev sqlite
freetds
];
CPATH = "${libfixposix}/include";
LD_LIBRARY_PATH = "${openssl.out}/lib:${fuse}/lib:${libuv}/lib:${libev}/lib:${mariadb}/lib:${sqlite.out}/lib:${libfixposix}/lib:${freetds}/lib";
};
in stdenv.mkDerivation self