cl-micropm.lisp (8187B)
1 (defpackage micropm 2 (:use :cl) 3 (:export #:setup #:setup-asdf-registry)) 4 5 (in-package :micropm) 6 7 (require 'asdf) 8 9 (defvar *lisp-systems-dir* #P"./lisp-systems/") 10 11 (defvar *quicklisp-projects-dir* 12 (uiop:merge-pathnames* #P"quicklisp-projects/projects/" (uiop:getcwd))) 13 14 (defun setup (system-name &key (ignore-error t)) 15 "Sets up micropm and the project's dependencies" 16 ;; Quicklisp sources (obtained from the quicklisp-projects repo) 17 (unless (uiop:directory-exists-p *quicklisp-projects-dir*) 18 (add-quicklisp-projects-submodule)) 19 20 ;; Quicklisp systems index (obtained from a generated file from Dockerfile) 21 (unless (boundp '*systems-alist*) 22 (defvar *systems-alist* (generate-quicklisp-index))) 23 24 ;; Clone the dependencies listed in the system 25 (add-local-project-to-asdf) 26 (loop for dependency-name in (locate-dependencies system-name) do 27 (if ignore-error 28 (progn 29 (format t "Cloning ~a...~%" dependency-name) 30 (ignore-errors (clone-dependencies dependency-name *systems-alist*))) 31 (clone-dependencies dependency-name *systems-alist*)))) 32 33 (defun setup-asdf-registry () 34 "Initializes the ASDF registry with the existing dependencies in *lisp-systems-dir*" 35 (setf asdf:*central-registry* (cons (uiop:getcwd) (list-lisp-systems-paths)))) 36 37 (defun add-quicklisp-projects-submodule () 38 (uiop:run-program "git submodule add -f https://github.com/quicklisp/quicklisp-projects.git")) 39 40 (defun add-local-project-to-asdf () 41 "Configures ASDF to find the project in the current working directory" 42 (when (not (find-if (lambda (e) (equal e (uiop:getcwd))) asdf:*central-registry*)) 43 (push (uiop:getcwd) asdf:*central-registry*))) 44 45 (defun locate-dependencies (system-name) 46 "Locates the dependencies of system-name" 47 (asdf:system-depends-on (asdf:find-system system-name))) 48 49 (defun fetch-system-quicklisp-source (system-name) 50 "Fetches the quicklisp source for the given system" 51 (let ((system-source 52 (uiop:merge-pathnames* (format nil "~a/source.txt" (string-downcase system-name)) 53 *quicklisp-projects-dir*))) 54 (map 'list (lambda (source) (uiop:split-string source :separator " ")) 55 (uiop:read-file-lines system-source)))) 56 57 (defvar *quicklisp-container-name* "quicklisp") 58 59 (defconstant *dockerfile* 60 "FROM debian:bullseye-slim 61 RUN apt-get update && apt-get install -y sbcl curl gnupg 62 RUN useradd -ms /bin/bash lisp 63 USER lisp 64 WORKDIR /home/lisp 65 66 # Setup quicklisp 67 RUN curl -O https://beta.quicklisp.org/quicklisp.lisp 68 RUN curl -O https://beta.quicklisp.org/quicklisp.lisp.asc 69 RUN curl -O https://beta.quicklisp.org/release-key.txt 70 RUN gpg --import release-key.txt 71 RUN gpg --verify quicklisp.lisp.asc quicklisp.lisp 72 RUN sbcl --non-interactive \\ 73 --load quicklisp.lisp \\ 74 --eval '(quicklisp-quickstart:install)' \\ 75 --eval '(ql::without-prompting (ql:add-to-init-file))'") 76 77 (defun micropm::build-quicklisp-image () 78 "Builds an OCI container with quicklisp installed inside" 79 ;; https://github.com/quicklisp/quicklisp-projects 80 #+nil(signal 'progress :topic :build-quicklisp :msg "Building quicklisp image...") 81 (multiple-value-bind (output err-output status-code) 82 (uiop:run-program 83 (format nil "podman build -t ~a -" *quicklisp-container-name*) 84 :input 85 (make-string-input-stream *dockerfile*) 86 :output t 87 :err-output t 88 :ignore-error-status t) 89 (declare (ignore output err-output)) 90 #+nil(signal 'progress :topic :build-quicklisp :msg (format nil "Command exited (~d)" status-code)) 91 status-code)) 92 93 (defun micropm::quicklisp-image-exists-p () 94 (multiple-value-bind (output err-output status-code) 95 (uiop:run-program (format nil "podman inspect --type=image ~a" *quicklisp-container-name*) 96 :ignore-error-status t) 97 (declare (ignore output err-output)) 98 (if (= status-code 0) t nil))) 99 100 (defun generate-quicklisp-index () 101 "Generates the quicklisp index" 102 ;; https://github.com/quicklisp/quicklisp-controller/blob/master/indexes.lisp#L162 103 (when (not (quicklisp-image-exists-p)) 104 (build-quicklisp-image)) 105 106 (let* ((systems-path "/home/lisp/quicklisp/dists/quicklisp/systems.txt") 107 (systems (uiop:run-program 108 (format nil 109 "podman run --rm --entrypoint cat ~a ~a | tail -n +2 | sed -e '1i(' -e '$a)' -e 's/^/(/g' -e 's/$/)/g'" 110 *quicklisp-container-name* 111 systems-path) 112 :output '(:string :stripped t) 113 :ignore-error-status t))) 114 (loop for x in (read-from-string systems) 115 ;; Just get the main system for a project, and it's dependencies 116 when (and (eql (first x) (second x)) (eql (first x) (third x))) 117 collect (cddr x)))) 118 119 (defun micropm::get-deps (system alist) 120 "Recursively finds all of the dependencies for the system" 121 (let* ((system-name (intern (string-upcase system))) 122 (dependencies 123 (rest (assoc-if (lambda (x) (equal system-name x)) alist)))) 124 (if dependencies 125 (let ((list (mapcan (lambda (x) (cons system-name (micropm::get-deps x alist))) 126 dependencies))) 127 (remove-duplicates list)) 128 (list system-name)))) 129 130 (defun get-dependencies (system systems-alist) 131 (let ((system-name (intern (string-upcase system)))) 132 (loop for x in (get-deps system-name systems-alist) 133 when (not (member-if 134 (lambda (e) (equal (symbol-name x) e)) 135 `(,(string-upcase system) "UIOP" "ASDF"))) 136 collect x))) 137 138 (defun get-source-type (source) 139 (first source)) 140 141 (defun ediware-p (source) 142 "Git source: https://github.com/edicl/" 143 (equal (get-source-type source) "ediware-http")) 144 145 (defun kmr-p (source) 146 "Git source: http://git.kpe.io/" 147 (equal (get-source-type source) "kmr-git")) 148 149 (defun http-get-source-p (source) 150 (member-if (lambda (x) (equal (get-source-type source) x)) 151 '("http" "https" "single-file"))) 152 153 (defun git-clone-source-p (source) 154 (member-if (lambda (x) (equal (get-source-type source) x)) 155 '("git" "latest-github-release" "latest-github-tag" "latest-gitlab-release"))) 156 157 (defun git-clone-tagged-source-p (source) 158 (member-if (lambda (x) (equal (get-source-type source) x)) 159 '("branched-git" "tagged-git"))) 160 161 (defun clone-dependency (system-name source &key (clone nil)) 162 (let ((url (second source)) 163 (dir (uiop:merge-pathnames* *lisp-systems-dir* system-name)) 164 (git-cmd (if clone "clone" "submodule add -f"))) 165 (cond 166 ((http-get-source-p source) 167 (uiop:run-program (format nil "wget ~a ~a" url dir) :output t)) 168 ((git-clone-source-p source) 169 (uiop:run-program (format nil "git ~a ~a ~a" git-cmd url dir) :output t)) 170 ((git-clone-tagged-source-p source) 171 (let ((tag (third source))) 172 (uiop:run-program (format nil "git ~a ~a#~a ~a" git-cmd url tag dir) :output t))) 173 (t (error (format nil "Unimplemented for source: ~a" source)))))) 174 175 (defun clone-dependencies (system systems-alist &key (include-system t) (clone nil)) 176 "Clones the dependencies of a Quicklisp system" 177 (let ((dependencies (get-dependencies system systems-alist))) 178 (loop for system-name in dependencies do 179 (setf system-name (string-downcase system-name)) 180 (clone-dependency system-name 181 (first (fetch-system-quicklisp-source system-name)) 182 :clone clone)) 183 (when include-system 184 (clone-dependency system 185 (first (fetch-system-quicklisp-source system)) 186 :clone clone)))) 187 188 (defun add-dependency (system-name) 189 "Configures ASDF to include the dependency" 190 (declaim (ignore system-name))) 191 192 (defun setup-asdf-central-registry (lisp-systems-paths) 193 "Setup ASDF to read the systems already setup in lisp-systems dir" 194 (setf asdf:*central-registry* lisp-systems-paths)) 195 196 (defun list-lisp-systems-paths () 197 "Lists the paths of the dependencies in lisp-systems" 198 (let ((dir (uiop:merge-pathnames* *lisp-systems-dir* (uiop:getcwd)))) 199 (uiop:subdirectories dir)))