diff options
| -rw-r--r-- | doc/connections.rst | 29 | ||||
| -rw-r--r-- | doc/ideas.rst | 9 | ||||
| -rw-r--r-- | src/connection.lisp | 2 | ||||
| -rw-r--r-- | src/connection/as.lisp | 4 | ||||
| -rw-r--r-- | src/connection/chroot.lisp | 4 | ||||
| -rw-r--r-- | src/connection/fork.lisp | 97 | ||||
| -rw-r--r-- | src/data.lisp | 17 | ||||
| -rw-r--r-- | src/image.lisp | 218 | ||||
| -rw-r--r-- | src/package.lisp | 8 | ||||
| -rw-r--r-- | src/util.lisp | 70 |
10 files changed, 325 insertions, 133 deletions
diff --git a/doc/connections.rst b/doc/connections.rst index 58b8dfe..cbb1597 100644 --- a/doc/connections.rst +++ b/doc/connections.rst @@ -112,22 +112,17 @@ in that saved image. Typically a ``:SUDO`` connection hop is used before hops which start up remote Lisp images, so these issues will not arise for most users. -``:CHROOT.FORK`` -~~~~~~~~~~~~~~~~ - -Since forking is typically only possible when it is not the case that multiple -threads are running, it is better to avoid using this connection type as the -first hop, i.e., directly out of the root Lisp (this is not much of a -restriction, since typically the root Lisp is running under a uid which cannot -use the ``chroot(2)`` system call anyway). More generally, you should avoid -using this connection type within a Lisp image which might try to execute -other deployments in parallel. Typical usage would be something like:: +Connections which fork: ``:CHROOT.FORK``, ``:SETUID`` +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +These connection types cannot be used as the first hop, i.e., directly out of +the root Lisp. This is because they must call fork(2), and Consfigurator only +makes this system call in contexts in which there shouldn't ever be more than +one thread (excluding Lisp implementation finaliser threads and the like). +The root Lisp is not such a context, because it is often multithreaded due to +the use of SLIME. This is, however, not much of a restriction, because +typically the root Lisp is running under a UID which cannot use system calls +like chroot(2) and setuid(2) anyway. Thus, typical usage on localhost would +be something like:: (deploy (:sudo :sbcl (:chroot.fork :into "...")) ...) - -In some situations you might want to have a connection chain which effectively -uses a connection type like ``:SBCL`` twice in a row, so that the first Lisp -image can execute deployments in parallel while the second forks into the -chroot (typically by having a ``DEPLOYS`` property with connection type -``:SBCL`` as one of the properties applied by a deployment whose connection -chain itself ends with ``:SBCL``). diff --git a/doc/ideas.rst b/doc/ideas.rst index e93e42d..11f8c12 100644 --- a/doc/ideas.rst +++ b/doc/ideas.rst @@ -61,10 +61,11 @@ Core - A CONCURRENTLY combinator for property application specifications, which means to apply each of the enclosed properties in parallel. Particularly useful surrounding a set of DEPLOYS applications, to concurrently deploy a - number of hosts. We use ``WITH-CURRENT-DIRECTORY`` in various places, so we - may not be able to do this using threads. But if we want to do it with lots - of forking, then practically speaking usage of this combinator will be - restricted to connection chains which start up remote Lisp images. + number of hosts. Now that we don't call fork(2) while executing + deployments, we ought to be able to do this using threads, and so it can + work in the root Lisp too. However, we still use ``WITH-CURRENT-DIRECTORY`` + in various places. Perhaps that macro could be changed to only affect RUN, + MRUN etc. for the sake of enabling multithreading. - It might be useful to have a restart for the case where an attempt is made to apply a list of properties containing some ``:LISP`` properties with a diff --git a/src/connection.lisp b/src/connection.lisp index 7dbe5d3..6ceb837 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -69,6 +69,8 @@ For an example of usage, see the :SUDO connection type.")) :initform nil :documentation "This connection's connection attributes."))) +(define-print-object-for-structlike connection) + (defclass lisp-connection (connection) ()) (defclass posix-connection (connection) ()) diff --git a/src/connection/as.lisp b/src/connection/as.lisp index 6f6edc6..a31a338 100644 --- a/src/connection/as.lisp +++ b/src/connection/as.lisp @@ -30,8 +30,6 @@ whether it is possible to establish a :SETUID connection. Note that both these connection types require root." ;; An alternative to :SU would be :SUDO or runuser(1), but :SU is more ;; portable. - (establish-connection (if (and (lisp-connection-p) - (can-setuid) - (can-probably-fork)) + (establish-connection (if (and (lisp-connection-p) (can-setuid)) :setuid :su) remaining :to to)) diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp index d0d59ac..836124f 100644 --- a/src/connection/chroot.lisp +++ b/src/connection/chroot.lisp @@ -24,9 +24,7 @@ (zerop (foreign-funcall "geteuid" :int))) (defmethod establish-connection ((type (eql :chroot)) remaining &key into) - (establish-connection (if (and (lisp-connection-p) - (can-chroot) - (can-probably-fork)) + (establish-connection (if (and (lisp-connection-p) (can-chroot)) :chroot.fork :chroot.shell) remaining diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp index 746b9ed..5def543 100644 --- a/src/connection/fork.lisp +++ b/src/connection/fork.lisp @@ -18,33 +18,6 @@ (in-package :consfigurator.connection.fork) (named-readtables:in-readtable :consfigurator) -;; Use only implementation-specific fork and waitpid calls to avoid thread -;; woes. Things like chroot(2) and setuid(2), however, should be okay. - -(defun fork () - #+sbcl (sb-posix:fork)) - -(defun waitpid (pid options) - ;; normalise any other implementations such that we always return - ;; (values PID EXIT-STATUS), as SB-POSIX:WAITPID does - #+sbcl (sb-posix:waitpid pid options)) - -(defun wifexited (status) - #+sbcl (sb-posix:wifexited status)) - -(defun wexitstatus (status) - #+sbcl (sb-posix:wexitstatus status)) - -(defun can-probably-fork () - "Return nil if we can detect other running threads, and the Lisp -implementation is known not to support forking when there are other threads. -A return value other than nil indicates only that we couldn't detect -circumstances in which it is known that we cannot fork, not that we are sure -we can fork -- a thread might be only partly initialised at the time we check, -for example, such that we don't see it." - (and - #+sbcl (> 2 (length (sb-thread:list-all-threads))))) - (defclass fork-connection (local-connection) ()) (defgeneric post-fork (connection) @@ -52,63 +25,13 @@ for example, such that we don't see it." "Code to execute after forking but before calling CONTINUE-DEPLOY*.")) (defmethod continue-connection ((connection fork-connection) remaining) - (unless (lisp-connection-p) - (error "Forking requires a Lisp-type connection.")) - #-(or sbcl) (error "Don't know how to safely fork() in this Lisp") - (upload-all-prerequisite-data - :connection connection :upload-string-data nil) - (with-remote-temporary-file (output) - (with-remote-temporary-file (error) - (mapc #'force-output - (list *standard-output* *error-output* *debug-io* *terminal-io*)) - (let ((child (fork))) - (case child - ;; note that SB-POSIX:FORK can only return >=0 - (-1 - (error "fork(2) failed")) - (0 - (with-backtrace-and-exit-code - ;; Capture child stdout in case *STANDARD-OUTPUT* has been - ;; rebound to somewhere else in the parent, e.g. by - ;; APPLY-AND-PRINT. The parent can then send the contents of the - ;; file named by OUTPUT to the correct stream. Capture child - ;; stderr so that we can include it in FAILED-CHANGE condition; - ;; otherwise if we are within SEQPROPS, for example, stderr won't - ;; be made visible to the user. We don't use pipe(2) because - ;; then we'd need implementation-specific code to bind streams to - ;; the FDs. - (with-open-file (*standard-output* - output :direction :output :if-exists :append) - (with-open-file (*error-output* - error :direction :output :if-exists :append) - (mapc #'clear-input - (list *standard-input* *debug-io* *terminal-io*)) - (cancel-unwind-protect-in-parent-cleanup) - ;; While some kinds of data source will still work given - ;; certain subtypes of FORK-CONNECTION (e.g. if they've - ;; already cached the data in memory, or if it's also - ;; accessible to whomever we will SETUID to), others won't, - ;; so drop all registrations and rely on the call to - ;; UPLOAD-ALL-PREREQUISITE-DATA above. - (reset-data-sources) - (post-fork connection) - ;; It would be nice to reenter Consfigurator's primary loop - ;; by just calling (return-from establish-connection - ;; (establish-connection :local)) here, but we need to kill - ;; off the child afterwards, rather than returning to the - ;; child's REPL or whatever else. - (continue-deploy* connection remaining))))) - (t - (multiple-value-bind (pid status) (waitpid child 0) - (declare (ignore pid)) - (fresh-line) - (princ (readfile output)) - (if (wifexited status) - (return-exit - (wexitstatus status) - :on-failure (failed-change - "~&Fork connection child failed; stderr was~%~%~A" - (readfile error))) - (failed-change - "~&Fork connection child did not exit normally, status #x~(~4,'0X~)" - status))))))))) + (upload-all-prerequisite-data connection) + (eval-in-grandchild `(progn (post-fork ,connection) + (continue-deploy* ,connection ',remaining)) + (out err exit) + (fresh-line) + (princ out) + (return-exit + exit + :on-failure (failed-change + "~&Fork connection child failed; stderr was ~%~%~A" err)))) diff --git a/src/data.lisp b/src/data.lisp index d09e4e2..c78784c 100644 --- a/src/data.lisp +++ b/src/data.lisp @@ -330,19 +330,12 @@ new versions of data, to avoid them piling up.")) ((connection connection) (k (eql 'cached-data))) (make-hash-table :test #'equal)) -(defun upload-all-prerequisite-data - (&key (upload-string-data t) (connection *connection*)) +(defun upload-all-prerequisite-data (&optional (connection *connection*)) "Upload all prerequisite data required by the current deployment to the remote cache of the current connection hop, or to the remote cache of CONNECTION. -If UPLOAD-STRING-DATA is false, don't upload items of string data, but -retrieve them from data sources and keep in memory. This is for connection -types which will do something like fork after calling this function. - This is called by implementations of ESTABLISH-CONNECTION which call CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM." - ;; Retrieving & keeping in memory refers to how %GET-DATA stores items of - ;; string data in *STRING-DATA*. (flet ((record-cached-data (iden1 iden2 version) (let ((*connection* connection)) (setf (gethash (cons iden1 iden2) (get-connattr 'cached-data)) @@ -366,11 +359,9 @@ CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM." (or (not highest-remote-version) (version> highest-local-version highest-remote-version))) do (let ((data (funcall thunk))) - (when (or upload-string-data - (not (subtypep (type-of data) 'string-data))) - (connection-clear-data-cache connection iden1 iden2) - (connection-upload connection data) - (record-cached-data iden1 iden2 (data-version data)))) + (connection-clear-data-cache connection iden1 iden2) + (connection-upload connection data) + (record-cached-data iden1 iden2 (data-version data))) else if highest-remote-version do (informat 3 "~&Not uploading ~S | ~S ver ~S as remote has ~S" iden1 iden2 diff --git a/src/image.lisp b/src/image.lisp index b7e6225..70781a0 100644 --- a/src/image.lisp +++ b/src/image.lisp @@ -20,6 +20,211 @@ ;;;; Remote Lisp images +;;; Remote Lisp images fork right after loading all required ASDF systems. +;;; The parent then enters %CONSFIGURE. Further connection hops of type +;;; FORK-CONNECTION are established in grandchildren (actually +;;; great-grandchildren) such that (i) if establishing those hops requires +;;; calling things like chroot(2), setuid(2) and setns(2), then the parent +;;; doesn't get stuck in those contexts; and (ii) subdeployments executed in +;;; those contexts will not have access to any secrets the parent might have +;;; read into its memory. +;;; +;;; Similar considerations apply to dumping executables. +;;; +;;; Previously we forked the original process right before chrooting, +;;; setuiding, etc., but this failed to ensure (ii), meant that the parent +;;; could not be multithreaded as it might later need to fork, and required us +;;; to take extra steps when using UNWIND-PROTECT to ensure cleanup forms +;;; weren't executed on both sides of any forks, using a specialised macro. +;;; +;;; Right before establishing the FORK-CONNECTION, the grandchild also +;;; recursively sets up infrastructure to request grandchildren for +;;; establishing further connection hops or dumping executables, such that it +;;; too can be multithreaded even if there are sub-subdeployments, etc.. +;;; +;;; We use named pipes for the IPC to minimise implementation-specific code. + +(defparameter *fork-control* nil) + +(defmacro with-fork-request (request (out err exit) &body forms) + (with-gensyms (input output) + `(progn + (unless (lisp-connection-p) + (failed-change "Forking requires a Lisp-type connection.")) + (unless *fork-control* + (failed-change + "Fork requested but no fork control child; is this the root Lisp?")) + (informat 3 "~&Making grandchild request ~S" ,request) + (with-mkfifos (,input ,output) + ;; We send the path to a named pipe, INPUT, rather than our actual + ;; request. That way we can be confident that what we send into the + ;; (shared) requests pipe will be less than PIPE_BUF (see pipe(7)). + (write-to-mkfifo (cons ,input ,output) *fork-control*) + (with-open-file (,input ,input :direction :output :if-exists :append + :element-type 'character) + (write-to-mkfifo ,request ,input)) + (destructuring-bind (,out ,err ,exit) + (safe-read-file-form ,output :element-type 'character) + ,@forms))))) + +;;; These are the two requests we expect to make of grandchildren: complete +;;; the work of an enclosing call to DEPLOY* or DEPLOY-THESE*, or dump an +;;; image which will evaluate a form. In the former case we always want to +;;; carry over *HOST*, *CONNECTION* and *CONSFIGURATOR-DEBUG-LEVEL*, and in +;;; the latter case we do not carry over any of these by default. + +(defmacro eval-in-grandchild (request (out err exit) &body forms) + "Evaluate REQUEST, a readably printable Lisp form, in a grandchild process. +REQUEST must be evaluable using only definitions established statically by +your consfig, or in one of the ASDF systems upon which your consfig depends. +Then bind OUT, ERR and EXIT to the stdout, stderr and exit code of that +process, respectively, and evaluate FORMS." + `(with-fork-request + `(let ((*host* ,*host*) + (*connection* ,*connection*) + (*no-data-sources* t) + (*consfigurator-debug-level* ,*consfigurator-debug-level*)) + ,,request) + (,out ,err ,exit) + ,@forms)) + +(defun dump-consfigurator (filename form) + (umask #o077) + (uiop:register-image-restore-hook (lambda () (eval form)) nil) + (uiop:dump-image filename :executable t)) + +(defun dump-consfigurator-in-grandchild + (filename &optional (form `(let ((*no-data-sources* t) + (*connection* ,*connection*) + (*consfigurator-debug-level* + ,*consfigurator-debug-level*)) + (with-deployment-report + (with-fork-control + (%consfigure nil ,*host*))) + (fresh-line)))) + "Dump an executable image to FILENAME which will evaluate the readably +printable Lisp form FORM, which defaults to one which will execute the current +deployment. FORM must be evaluable using only definitions established +statically by your consfig, or in one of the ASDF systems upon which your +consfig depends. + +Only :LISP property :APPLY subroutines should call this. + +The process which performs the dump will have its umask set to #o077, but +implementation-specific image dumping code might undo this (SBCL, for example, +changes the mode of the file to #o755). You might want to ensure that the +directory containing FILENAME is locked down." + (with-fork-request `(dump-consfigurator ,filename ',form) (out err exit) + (declare (ignore out)) + (unless (zerop exit) + (failed-change "~&Failed to dump image; stderr was ~%~%~A" err)))) + +(defmacro with-fork-control (&body forms &aux (fork-control (gensym))) + `(let ((,fork-control (mkfifo))) + (forked-progn child + ;; We use MAPC-OPEN-INPUT-STREAMS because (i) the input streams may + ;; already have been closed if this is a recursive call; (ii) we + ;; don't want to close the output streams in the case of *DEBUG-IO* + ;; and *TERMINAL-IO*; and (iii) there is some ambiguity in the + ;; standard about closing synonym streams; see + ;; <https://bugs.launchpad.net/sbcl/+bug/1904257>. + (loop initially (mapc-open-input-streams + #'close *standard-input* *debug-io* *terminal-io*) + with ,fork-control = (open ,fork-control + :element-type 'character) + for (input . output) = (handler-case (with-safe-io-syntax () + (read ,fork-control)) + (end-of-file () + (close ,fork-control) + (uiop:quit))) + do (mapc-open-output-streams + #'force-output + *standard-output* *error-output* *debug-io* *terminal-io*) + when (zerop (fork)) + do (setsid) + (close ,fork-control) + (handle-fork-request input output) + (uiop:quit)) + (let ((*fork-control* (open ,fork-control + :direction :output :if-exists :append + :element-type 'character))) + ;; Opening named pipes for writing blocks on the other end being + ;; opened for reading, so at this point we know the child has it + ;; open. Then delete the filesystem reference right away in case we + ;; are about to chroot or similar, such that we couldn't do it later. + (delete-file ,fork-control) + (unwind-protect (progn ,@forms) + (close *fork-control*) + (let ((status (nth-value 1 (waitpid child 0)))) + (unless (and (wifexited status) (zerop (wexitstatus status))) + (error "Fork control child did not exit zero.")))))))) + +;; IPC security considerations +;; +;; The grandchild initially shouldn't have anything in memory other than the +;; ASDF systems we've loaded, and a few bits of IPC information like OUT and +;; ERR. The INPUT pipe has mode 0600. So by directly evaluating the first +;; thing we receive all that we're permitting is for a process with the same +;; UID and a sufficiently similar view of the filesystem as us to execute and +;; potentially introspect the consfig. That should not in itself be a +;; security concern, because the consfig should not contain any secrets. +;; +;; The data we get from INPUT is potentially security-sensitive; for example, +;; specifications of onward connection chains might contain sudo passwords +;; (though this would be an unusual way to use Consfigurator). Another writer +;; to the pipe might insert a reference to the #. reader macro which causes us +;; to reveal what we get from INPUT, or another reader from the pipe might be +;; able to get some of INPUT. Again, however, only an attacker who has +;; already managed to change to our UID or otherwise circumvent normal POSIX +;; permissions could do any of this. We might consider encrypting the data we +;; send down the named pipes using a pre-shared key. +;; +;; An alternative to forking would be to dump an image which we reexecute each +;; time we would have created another grandchild; then we can send the request +;; on stdin. That would mean writing ~75MB out to disk every time we start up +;; a remote Lisp image and every time we establish a further FORK-CONNECTION, +;; however. If we took this approach, then we'd have implementation-specific +;; dumping code but the code to reinvoke the dumped images would be fully +;; portable. In place of :SETUID connections we might runuser(1) the image, +;; which would have the advantage of getting us a fresh PAM session, although +;; it would mean making the executable readable by the target user. +(defun handle-fork-request (input output &aux (out (mkfifo)) (err (mkfifo))) + (forked-progn child + (with-backtrace-and-exit-code + ;; Capture stdout and leave it to the request submitter to decide what + ;; to do with it, because perhaps the requester has rebound + ;; *STANDARD-OUTPUT*, e.g. in an enclosing call to APPLY-AND-PRINT. + ;; + ;; Similarly for stderr. In particular, we discard the stderr from + ;; remote Lisp images unless they fail due to an unhandled error, so + ;; if we just leave stderr uncaptured then it might be the case that + ;; the user will never see it. Also see commit 9e7ae48590. + (with-open-file (*standard-output* out :direction :output + :if-exists :append + :element-type 'character) + (with-open-file (*error-output* err :direction :output + :if-exists :append + :element-type 'character) + (with-fork-control + (eval (with-standard-io-syntax + (read-file-form input :element-type 'character))))))) + (unwind-protect + (with-open-file (out out :element-type 'character) + (with-open-file (err err :element-type 'character) + (let ((status (nth-value 1 (waitpid child 0)))) + (unless (wifexited status) + (failed-change + "~&Grandchild process did not exit normally, status #x~(~4,'0X~)." + status)) + (with-open-file (output output :direction :output + :if-exists :append + :element-type 'character) + (write-to-mkfifo (list (slurp-stream-string out) + (slurp-stream-string err) + (wexitstatus status)) + output))))) + (delete-file out) (delete-file err)))) + (defclass asdf-requirements () ((asdf-requirements :type list :initform nil)) (:documentation @@ -147,8 +352,7 @@ 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.") +before the following sexp is offered to its reader, on standard input.") (:method (remaining-connections (asdf-requirements asdf-requirements)) (unless (eq (type-of *host*) 'preprocessed-host) (error "Attempt to send unpreprocessed host to remote Lisp. @@ -220,10 +424,12 @@ Preprocessing must occur in the root Lisp.")) 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*)))))) + ;; Continue the deployment. The READ indirection is to try + ;; to ensure that the fork control child does not end up with + ;; information about the deployment in its memory. + ,(wrap `(with-backtrace-and-exit-code + (with-fork-control (eval (read))))) + (%consfigure ',remaining-connections ,*host*)))) (handler-case (with-standard-io-syntax (let ((*allow-printing-passphrases* t)) diff --git a/src/package.lisp b/src/package.lisp index bd40579..5d2166b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -33,6 +33,9 @@ #:with-current-directory #:delete-empty-directory #:delete-directory-tree + #:with-safe-io-syntax + #:read-file-form + #:safe-read-file-form #:safe-read-from-string #:compile-file* #:compile-file-pathname*) @@ -66,6 +69,9 @@ #:with-current-directory #:delete-empty-directory #:delete-directory-tree + #:with-safe-io-syntax + #:read-file-form + #:safe-read-file-form #:safe-read-from-string #:compile-file* #:compile-file-pathname* @@ -286,6 +292,8 @@ #:get-data-protected-string ;; image.lisp + #:eval-in-grandchild + #:dump-consfigurator-in-grandchild #:asdf-requirements-for-host-and-features #:request-asdf-requirements #:continue-deploy*-program)) diff --git a/src/util.lisp b/src/util.lisp index 6de9e71..5524188 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -532,6 +532,47 @@ of this macro." Should be called soon after fork(2) in child processes." (signal 'in-child-process)) +;;; Use only implementation-specific fork, waitpid etc. calls to avoid thread +;;; woes. Things like chroot(2) and setuid(2), however, should be okay. + +(defun fork () + ;; Normalise any other implementations such that we signal an error if + ;; fork(2) returns -1, so caller doesn't have to check for that. + #+sbcl (sb-posix:fork)) + +(defun waitpid (pid options) + ;; Normalise any other implementations such that we always return (values + ;; PID EXIT-STATUS), as SB-POSIX:WAITPID does. + #+sbcl (sb-posix:waitpid pid options)) + +(defun wifexited (status) + #+sbcl (sb-posix:wifexited status)) + +(defun wexitstatus (status) + #+sbcl (sb-posix:wexitstatus status)) + +(defun setsid () + #+sbcl (sb-posix:setsid)) + +(defun umask (mode) + #+sbcl (sb-posix:umask mode)) + +(defmacro forked-progn (child-pid child-form &body parent-forms) + (with-gensyms (retval) + `(progn + #-(or sbcl) (error "Don't know how to safely fork(2) in this Lisp.") + (mapc-open-output-streams + #'force-output + *standard-output* *error-output* *debug-io* *terminal-io*) + (let ((,retval (fork))) + (if (zerop ,retval) + ;; We leave it to the caller to appropriately call CLOSE or + ;; CLEAR-INPUT on input streams shared with the parent, because + ;; at least SBCL's CLEAR-INPUT clears the OS buffer as well as + ;; Lisp's, potentially denying data to both sides of the fork. + ,child-form + (let ((,child-pid ,retval)) ,@parent-forms)))))) + (define-condition skipped-properties () () (:documentation "There were failed changes, but instead of aborting, that particular property @@ -617,3 +658,32 @@ Does not currently establish a PAM session." (stream ,file :direction :output :if-exists :supersede) (with-standard-io-syntax (prin1 ,data stream))))))) + + +;;;; Streams + +(defun stream->input-stream (stream) + (etypecase stream + (synonym-stream (stream->input-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream (two-way-stream-input-stream stream)) + (stream (and (input-stream-p stream) stream)))) + +(defun mapc-open-input-streams (function &rest streams) + (dolist (stream streams streams) + (when-let ((input-stream (stream->input-stream stream))) + (when (open-stream-p input-stream) + (funcall function input-stream))))) + +(defun stream->output-stream (stream) + (etypecase stream + (synonym-stream (stream->output-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream (two-way-stream-output-stream stream)) + (stream (and (output-stream-p stream) stream)))) + +(defun mapc-open-output-streams (function &rest streams) + (dolist (stream streams streams) + (when-let ((output-stream (stream->output-stream stream))) + (when (open-stream-p output-stream) + (funcall function output-stream))))) |