commit a749a8056328b22f6e47c41e0f1a0e67ace1ce98
parent 62c708c1e61c68fd3ef78d9e85dbd9a63e576fe7
Author: Risto Stevcev <me@risto.codes>
Date: Wed, 30 Aug 2023 20:09:36 +0200
WIP
Diffstat:
7 files changed, 195 insertions(+), 28 deletions(-)
diff --git a/.envrc b/.envrc
@@ -1 +0,0 @@
-export CL_SOURCE_REGISTRY="$PWD/lisp-systems//"
diff --git a/.gitmodules b/.gitmodules
@@ -0,0 +1,3 @@
+[submodule "quicklisp-projects"]
+ path = quicklisp-projects
+ url = https://github.com/quicklisp/quicklisp-projects.git
diff --git a/cl-micropm.asd b/cl-micropm.asd
@@ -0,0 +1,4 @@
+(defsystem "micropm"
+ :class :package-inferred-system
+ :depends-on (:alexandria)
+ :components ((:file "micropm")))
diff --git a/cl-micropm.lisp b/cl-micropm.lisp
@@ -0,0 +1,169 @@
+(defpackage micropm
+ (:use :cl))
+
+(in-package :micropm)
+
+(defvar *lisp-systems-dir* #P"./lisp-systems")
+
+(defvar *quicklisp-projects-dir*
+ (uiop:merge-pathnames* #P"quicklisp-projects/projects/" (uiop:getcwd)))
+
+(defun init (system-name)
+ (add-local-project-to-asdf)
+ (loop for i in (locate-dependencies system-name) do
+ (print i)))
+
+#+nil(init "micropm")
+
+(defun add-local-project-to-asdf ()
+ "Configures ASDF to find the project in the current working directory"
+ (when (not (find-if (lambda (e) (equal e (uiop:getcwd))) asdf:*central-registry*))
+ (push (uiop:getcwd) asdf:*central-registry*)))
+
+(defun locate-dependencies (system-name)
+ "Locates the dependencies of system-name"
+ (asdf:system-depends-on (asdf:find-system system-name)))
+
+(defun fetch-system-quicklisp-source (system-name)
+ "Fetches the quicklisp source for the given system"
+ (let ((system-source
+ (uiop:merge-pathnames* (uiop:strcat system-name "/source.txt")
+ *quicklisp-projects-dir*)))
+ (map 'list (lambda (source) (uiop:split-string source :separator " "))
+ (uiop:read-file-lines system-source))))
+
+#+nil(fetch-system-quicklisp-source "xmls")
+
+(defvar *quicklisp-container-name* "quicklisp")
+
+#+nil(define-condition progress (condition)
+ ((topic :initarg :topic)
+ (msg :initarg :msg)))
+
+#+nil(defmacro with-progress (&body body)
+ `(handler-bind
+ ((progress #'(lambda (condition)
+ (with-slots (topic msg) condition
+ (format t "~&* ~a: ~a" topic msg))
+ (continue))))
+ (progn ,@body)))
+
+#+nil(with-progress (build-quicklisp-image))
+
+(defconstant *dockerfile*
+ "FROM debian:bullseye-slim
+RUN apt-get update && apt-get install -y sbcl curl gnupg
+RUN useradd -ms /bin/bash lisp
+USER lisp
+WORKDIR /home/lisp
+
+# Setup quicklisp
+RUN curl -O https://beta.quicklisp.org/quicklisp.lisp
+RUN curl -O https://beta.quicklisp.org/quicklisp.lisp.asc
+RUN curl -O https://beta.quicklisp.org/release-key.txt
+RUN gpg --import release-key.txt
+RUN gpg --verify quicklisp.lisp.asc quicklisp.lisp
+RUN sbcl --non-interactive \\
+ --load quicklisp.lisp \\
+ --eval '(quicklisp-quickstart:install)' \\
+ --eval '(ql::without-prompting (ql:add-to-init-file))'")
+
+(defun micropm::build-quicklisp-image ()
+ "Builds an OCI container with quicklisp installed inside"
+ ;; https://github.com/quicklisp/quicklisp-projects
+ #+nil(signal 'progress :topic :build-quicklisp :msg "Building quicklisp image...")
+ (multiple-value-bind (output err-output status-code)
+ (uiop:run-program
+ (format nil "podman build -t ~a -" *quicklisp-container-name*)
+ :input
+ (make-string-input-stream *dockerfile*)
+ :output t
+ :err-output t
+ :ignore-error-status t)
+ (declare (ignore output err-output))
+ #+nil(signal 'progress :topic :build-quicklisp :msg (format nil "Command exited (~d)" status-code))
+ status-code))
+
+(defun micropm::quicklisp-image-exists-p ()
+ (multiple-value-bind (output err-output status-code)
+ (uiop:run-program (format nil "podman inspect --type=image ~a" *quicklisp-container-name*)
+ :ignore-error-status t)
+ (declare (ignore output err-output))
+ (if (= status-code 0) t nil)))
+
+(defun generate-quicklisp-index ()
+ "Generates the quicklisp index"
+ ;; https://github.com/quicklisp/quicklisp-controller/blob/master/indexes.lisp#L162
+ (when (not (quicklisp-image-exists-p))
+ (build-quicklisp-image))
+
+ (let* ((systems-path "/home/lisp/quicklisp/dists/quicklisp/systems.txt")
+ (systems (uiop:run-program
+ (format nil
+ "podman run --rm --entrypoint cat ~a ~a | tail -n +2 | sed -e '1i(' -e '$a)' -e 's/^/(/g' -e 's/$/)/g'"
+ *quicklisp-container-name*
+ systems-path)
+ :output '(:string :stripped t)
+ :ignore-error-status t)))
+ (loop for x in (read-from-string systems)
+ ;; Just get the main system for a project, and it's dependencies
+ when (and (eql (first x) (second x)) (eql (first x) (third x)))
+ collect (cddr x))))
+
+#+nil(defvar *systems-alist* (generate-quicklisp-index))
+
+(defun micropm::get-deps (system alist)
+ "Recursively finds all of the dependencies for the system"
+ (let ((dependencies (rest (assoc system alist))))
+ (if dependencies
+ (let ((list (mapcan (lambda (x) (cons system (micropm::get-deps x alist))) dependencies)))
+ (remove-duplicates list))
+ (list system))))
+
+(defun get-dependencies (system systems-alist)
+ (loop for x in (get-deps system systems-alist)
+ when (not (member x `(,system uiop asdf))) collect x))
+
+#+nil(get-dependencies 'cffi *systems-alist*)
+
+#|
+branched-git
+cvs
+darcs
+ediware-http
+git
+http
+https
+kmr-git
+latest-github-release
+LATEST-GITHUB-RELEASE
+latest-github-tag
+LATEST-GITHUB-TAG
+latest-gitlab-release
+mercurial
+single-file
+svn
+tagged-git
+|#
+
+(defun clone-dependencies (system systems-alist)
+ (let ((dependencies (get-dependencies system systems-alist)))
+ ()
+ ))
+
+(defun add-dependency (system-name)
+ "Configures ASDF to include the dependency"
+ (declaime (ignore system-name)))
+
+(defun setup-asdf-central-registry (lisp-systems-paths)
+ "Setup ASDF to read the systems already setup in lisp-systems dir"
+ (setf asdf:*central-registry* lisp-systems-paths))
+
+(defun list-lisp-systems-paths ()
+ "Lists the paths of the dependencies in lisp-systems"
+ (let ((dir (uiop:merge-pathnames* (uiop:getcwd) *lisp-systems-dir*)))
+ (uiop:subdirectories dir)))
+
+#+nil(push
+ (uiop:strcat (uiop:native-namestring (uiop:getcwd)) "lisp-systems/babel/")
+ asdf:*central-registry*)
diff --git a/micropm-docker/Dockerfile b/micropm-docker/Dockerfile
@@ -1,27 +0,0 @@
-FROM debian:bullseye-slim
-
-ARG SYSTEM_NAME
-ENV SYSTEM_NAME=${SYSTEM_NAME}
-
-RUN apt-get update && apt-get install -y sbcl curl gnupg
-RUN useradd -ms /bin/bash lisp
-USER lisp
-WORKDIR /home/lisp
-
-RUN curl -O https://beta.quicklisp.org/quicklisp.lisp
-RUN curl -O https://beta.quicklisp.org/quicklisp.lisp.asc
-RUN curl -O https://beta.quicklisp.org/release-key.txt
-RUN gpg --import release-key.txt
-RUN gpg --verify quicklisp.lisp.asc quicklisp.lisp
-
-
-RUN sbcl --non-interactive \
- --load quicklisp.lisp \
- --eval '(quicklisp-quickstart:install)' \
- --eval '(ql::without-prompting (ql:add-to-init-file))'
-
-COPY . /home/lisp/common-lisp/${SYSTEM_NAME}/
-RUN ls /home/lisp/common-lisp/${SYSTEM_NAME}
-
-RUN sbcl --non-interactive --eval '(ql:quickload (sb-ext:posix-getenv "SYSTEM_NAME"))'
-CMD bash
diff --git a/quicklisp-docker/Dockerfile b/quicklisp-docker/Dockerfile
@@ -0,0 +1,17 @@
+FROM debian:bullseye-slim
+
+RUN apt-get update && apt-get install -y sbcl curl gnupg
+RUN useradd -ms /bin/bash lisp
+USER lisp
+WORKDIR /home/lisp
+
+# Setup quicklisp
+RUN curl -O https://beta.quicklisp.org/quicklisp.lisp
+RUN curl -O https://beta.quicklisp.org/quicklisp.lisp.asc
+RUN curl -O https://beta.quicklisp.org/release-key.txt
+RUN gpg --import release-key.txt
+RUN gpg --verify quicklisp.lisp.asc quicklisp.lisp
+RUN sbcl --non-interactive \
+ --load quicklisp.lisp \
+ --eval '(quicklisp-quickstart:install)' \
+ --eval '(ql::without-prompting (ql:add-to-init-file))'
+\ No newline at end of file
diff --git a/quicklisp-projects b/quicklisp-projects
@@ -0,0 +1 @@
+Subproject commit 74c0fc58072821e9ca32f95184f50167e2566a6f
