1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
;;; Consfigurator -- Lisp declarative configuration management system
;;; Copyright (C) 2021 Sean Whitton <spwhitton@spwhitton.name>
;;; This file is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3, or (at your option)
;;; any later version.
;;; This file is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :consfigurator)
(named-readtables:in-readtable :consfigurator)
;;;; Remote Lisp images
(defclass asdf-requirements ()
((asdf-requirements :type list :initform nil))
(:documentation
"A list of requirements as returned by certain calls to
ASDF:REQUIRED-COMPONENTS.
Elements are instances of ASDF:SYSTEM and/or ASDF:REQUIRE-SYSTEM."))
(defun asdf-requirements-for-host-and-features (remote-lisp-features)
"Make an instance of ASDF-REQUIREMENTS for starting up a remote Lisp image in
which *FEATURES* has the value of REMOTE-LISP-FEATURES, based on the Lisp
systems required by the host currently being deployed.
Called by connection types which start up remote Lisp images."
(let ((*features* remote-lisp-features)
(requirements (make-instance 'asdf-requirements)))
(with-slots (asdf-requirements) requirements
(dolist (system (propspec-systems (host-propspec *host*)))
(dolist (requirement
;; This call to ASDF:REQUIRED-COMPONENTS is based on one in
;; the definition of the ASDF:COMPONENT-DEPENDS-ON generic
;; for ((o gather-operation) (s system)). We use
;; ASDF:COMPILE-OP as the :KEEP-OPERATION because
;; ASDF::BASIC-COMPILE-OP is not exported, so this won't work
;; for certain exotic systems. See the comment in ASDF source.
;;
;; TODO Can we detect when this won't work and fail, possibly
;; falling back to ASDF:MONOLITHIC-CONCATENATE-SOURCE-OP?
(asdf:required-components
(asdf:find-system system)
:other-systems t :component-type 'asdf:system
:keep-component 'asdf:system :goal-operation 'asdf:load-op
:keep-operation 'asdf:compile-op))
;; Handle UIOP specially because it comes with ASDF.
(unless (string= "uiop" (asdf:component-name requirement))
;; What we really want instead of PUSHNEW here is a proper
;; topological sort.
(pushnew requirement asdf-requirements))))
(nreversef asdf-requirements))
requirements))
(defgeneric request-asdf-requirements (asdf-requirements)
(:documentation
"Request that all Lisp systems required to fulfill ASDF-REQUIREMENTS be
uploaded to the remote cache of the currently established connection.
Called by connection types which start up remote Lisp images.")
(:method ((asdf-requirements asdf-requirements))
(loop for requirement in (slot-value asdf-requirements 'asdf-requirements)
for type = (type-of requirement)
when (and (subtypep type 'asdf:system)
(not (subtypep type 'asdf:require-system)))
do (require-data "--lisp-system"
(asdf:component-name requirement)))))
(defgeneric asdf-requirements-load-form (asdf-requirements)
(:documentation
"Return form to (compile and) load each of the Lisp systems specified in
ASDF-REQUIREMENTS, after having uploaded those Lisp systems using
UPLOAD-ALL-PREREQUISITE-DATA.")
(:method ((asdf-requirements asdf-requirements))
;; As soon as we recompile something, we have to recompile everything else
;; following it in the list, because macro definitions may have changed.
`(let* (recompile
(file (merge-pathnames "consfigurator/fasls"
(ensure-directory-pathname
(or (getenv "XDG_CACHE_HOME")
(strcat (getenv "HOME") "/.cache")))))
(record (with-open-file (stream file :if-does-not-exist nil)
(and stream (safe-read-from-string
(slurp-stream-string stream))))))
(unwind-protect
(progn
,@(loop
with table = (get-connattr 'cached-data)
for requirement
in (slot-value asdf-requirements 'asdf-requirements)
for name = (asdf:component-name requirement)
collect
(etypecase requirement
(asdf:require-system `(require ,name))
(asdf:system
(let ((source
(gethash (cons "--lisp-system" name) table)))
(unless source
(error "Somehow Lisp system ~A was not uploaded."
name))
;; Using COMPILE-FILE-PATHNAME* like this has the
;; advantage that, for example, SBCL will save the FASL
;; somewhere from which only the same version of SBCL
;; will try to load FASLs.
`(let ((fasl (compile-file-pathname* ,source)))
(if (and (file-exists-p fasl) (not recompile))
(load fasl)
;; The concatenated source of at least
;; Alexandria won't compile unless it's loaded
;; first. This means we compile every library
;; that's changed since the last deploy twice,
;; which is not ideal. One possible improvement
;; would be to maintain a list of systems known
;; not to have this problem, such as
;; Consfigurator, and switch the order of the
;; LOAD and COMPILE-FILE* here for those.
(let ((pair (assoc ,source record)))
(load ,source)
(or (compile-file* ,source)
(error "Failed to compile ~S" ,source))
(if pair
(rplacd pair fasl)
(setq record (acons ,source fasl record)))
(setq recompile t)))))))))
(with-open-file (stream file :direction :output :if-exists :supersede)
(with-standard-io-syntax
(prin1 record stream)))))))
(defgeneric continue-deploy*-program (remaining-connections asdf-requirements)
(:documentation
"Return a program to complete the work of an enclosing call to DEPLOY*.
Implementations of ESTABLISH-CONNECTION which start up remote Lisp images call
this function, instead of CONTINUE-DEPLOY*, and use the result to instruct the
newly started image.
Will query the remote cache for paths to Lisp systems, so a connection to the
host which will run the Lisp image must already be established.
The program returned is a single string consisting of a number of sexps
separated by newlines. Each sexp must be evaluated by the remote Lisp image
before the following sexp is offered to its reader. Usually this can be
achieved by sending the return value of this function into a REPL's stdin.")
(:method (remaining-connections (asdf-requirements asdf-requirements))
(unless (eq (type-of *host*) 'preprocessed-host)
(error "Attempt to send unpreprocessed host to remote Lisp.
Preprocessing must occur in the root Lisp."))
(flet ((wrap (form)
;; We used to bind a handler here to invoke SKIP-DATA-SOURCES
;; upon MISSING-DATA-SOURCE, which means that remote Lisp images
;; were allowed to try querying data sources. Now we just bind
;; *NO-DATA-SOURCES* to t here. While some data sources make
;; sense in remote Lisp images, others might make arbitrary
;; network connections or read out of other users' homedirs
;; (e.g. if you are using (:SUDO :SBCL), the remote Lisp might
;; try to read your ~/.gnupg, or on another host, someone else's
;; ~/.gnupg who has the same username as you), which are usually
;; undesirable. So at least until some cool use case comes
;; along, just require all data source queries to occur in the
;; root Lisp.
`(let ((*no-data-sources* t)
(*consfigurator-debug-level* ,*consfigurator-debug-level*))
,form)))
(let* ((intern-forms
(loop for (export . name)
in '((nil . "*NO-DATA-SOURCES*")
(t . "*CONSFIGURATOR-DEBUG-LEVEL*"))
for intern-form
= `(intern ,name (find-package "CONSFIGURATOR"))
if export collect
`(export ,intern-form (find-package "CONSFIGURATOR"))
else collect intern-form))
(proclamations `((proclaim '(special *no-data-sources*))
(proclaim '(special *consfigurator-debug-level*))))
(forms
`((make-package "CONSFIGURATOR")
,@intern-forms
,@proclamations
;; (define-condition missing-data-source (error) ())
(require "asdf")
;; Hide the compile and/or load output unless there are
;; failures or the debug level is at least 3, as it's verbose
;; and not usually of interest.
,(wrap
`(let ((string
(make-array '(0) :element-type 'character
:fill-pointer 0 :adjustable t)))
(handler-case
(with-output-to-string (stream string)
(let ((*error-output* stream)
(*standard-output* stream))
,(asdf-requirements-load-form
asdf-requirements)))
(serious-condition (c)
(format
*error-output*
"~&Failed to compile and/or load:~%~A~&~%Compile and/or load output:~%~%~A"
c string)
(uiop:quit 2)))
(when (>= *consfigurator-debug-level* 3)
(format t "~&~A" string))))
;; Delete old FASLs. With SBCL they are megabytes in size.
(with-lisp-data-file
(record (merge-pathnames
"consfigurator/fasls"
(ensure-directory-pathname
(or (getenv "XDG_CACHE_HOME")
(strcat (getenv "HOME") "/.cache")))))
(loop for cell in record
if (file-exists-p (car cell))
collect cell into accum
else do (ignore-errors (delete-file (cdr cell)))
finally (setq record accum)))
;; Continue the deployment.
,(wrap
`(with-backtrace-and-exit-code
(%consfigure ',remaining-connections ,*host*))))))
(handler-case
(with-standard-io-syntax
(let ((*allow-printing-passphrases* t))
;; need line breaks in between so that packages exist before we
;; try to have remote Lisp read sexps containing symbols from
;; those packages
(values
(format nil "~{~A~^~%~}" (mapcar #'prin1-to-string forms))
forms)))
(print-not-readable (c)
(error "The Lisp printer could not serialise ~A for
transmission to the remote Lisp.
This is probably because your property application specification and/or static
informational attributes contain values which the Lisp printer does not know
how to print. If ~:*~A is something like a function object then you need to
rework your deployment so that it does not end up in the propspec or
hostattrs; see \"Pitfalls\" in the Consfigurator user manual.
If ~:*~A is a simple object then you may be able to resolve this by defining
a PRINT-OBJECT method for your class, possibly using
CONSFIGURATOR:DEFINE-PRINT-OBJECT-FOR-STRUCTLIKE."
(print-not-readable-object c))))))))
|
