;;; Consfigurator -- Lisp declarative configuration management system ;;; Copyright (C) 2020-2022 Sean Whitton ;;; 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 . (in-package :consfigurator) (named-readtables:in-readtable :consfigurator) (defun multiple-value-mapcan (function &rest lists) "Variant of MAPCAN which preserves multiple return values." (loop with lists = (copy-list lists) with results = (make-array '(1) :initial-element nil :adjustable t) for new = (multiple-value-list (apply function (maplist (lambda (lists) (if (endp (car lists)) (return (values-list (map 'list #'nreverse results))) (pop (car lists)))) lists))) do (loop initially (adjust-array results (max (length results) (length new)) :initial-element nil) for result in new and i upfrom 0 do (setf (aref results i) (nreconc result (aref results i)))))) (defun lines (text &optional trimfun (trimchars '(#\Space #\Tab))) (with-input-from-string (stream text) (let (bolp buffer) (flet ((trim (line) (if trimfun (funcall trimfun trimchars line) line)) (reset () (setq bolp t buffer (make-array 0 :fill-pointer 0 :element-type 'character)))) ;; Split on either , or ; would mean split ;; with a blank line in between. Drop a single trailing blank line. (loop initially (reset) for char = (read-char stream nil nil) if char if (member char '(#\Return #\Newline) :test #'char=) collect (trim buffer) and do (reset) (when (char= char #\Return) (when-let ((next (peek-char nil stream nil nil))) (when (char= next #\Newline) (read-char stream)))) else do (setq bolp nil) (vector-push-extend char buffer) end else unless bolp collect (trim buffer) end and do (loop-finish)))))) (defun unlines (lines) (format nil "~{~A~%~}" lines)) (defun words (text) (delete "" (split-string text) :test #'string=)) (defun unwords (words) (format nil "~{~A~^ ~}" words)) (defun strip-prefix (prefix string) "If STRING is prefixed by PREFIX, return the rest of STRING, otherwise return NIL." (nth-value 1 (starts-with-subseq prefix string :return-suffix t))) (defun memstr= (string list) (member string list :test #'string=)) (defun assert-ordinary-ll-member (arg) "Assert that ARG is not an implementation-specific lambda list keyword or a lambda list keyword which is not permitted in ordinary lambda lists. Consfigurator's property-writing macros do not support lambda list keywords which fail this assertion." (or (not (member arg '#.(set-difference lambda-list-keywords '(&optional &rest &key &allow-other-keys &aux)))) (simple-program-error "Implementation-specific or non-ordinary lambda list keyword ~A not supported." arg))) (defun ordinary-ll-without-&aux (ll) (loop for arg in ll do (assert-ordinary-ll-member arg) if (eq '&aux arg) return accum else collect arg into accum finally (return accum))) (defun ordinary-ll-variable-names (ll &key include-supplied-p) (loop for arg in ll for arg* = (ensure-car arg) do (assert-ordinary-ll-member arg) unless (char= #\& (char (symbol-name arg*) 0)) collect arg* and when (and include-supplied-p (listp arg) (caddr arg)) collect (caddr arg))) (defmacro defun-with-args (name argsym lambda-list &body forms &aux remaining) (multiple-value-bind (required optional rest kwargs aokeys) (parse-ordinary-lambda-list lambda-list) (when (and aokeys (not rest)) (simple-program-error "&ALLOW-OTHER-KEYS without &REST in property lambda list not supported.")) (let ((normalisedll (reverse required))) (when optional (push '&optional normalisedll) (loop for (name init suppliedp) in optional for suppliedp* = (or suppliedp (gensym)) do (push `(,name ,init ,suppliedp*) normalisedll) do (push `(when ,suppliedp* (push ,name ,argsym)) remaining))) (when rest (push '&rest normalisedll) (push rest normalisedll) (push `(dolist (r ,rest) (push r ,argsym)) remaining)) (when kwargs (push '&key normalisedll) (loop for ((keyword-name name) init suppliedp) in kwargs for suppliedp* = (if (or rest suppliedp) suppliedp (gensym)) do (push `((,keyword-name ,name) ,init ,suppliedp*) normalisedll) unless rest do (push `(when ,suppliedp* (push ,keyword-name ,argsym) (push ,name ,argsym)) remaining))) (when aokeys (push '&allow-other-keys normalisedll)) `(defun ,name ,(nreverse normalisedll) (let ((,argsym (list ,@(reverse required)))) ,@(nreverse remaining) (nreversef ,argsym) ,@forms))))) (defmacro define-simple-error (name &optional parent-types docstring) `(progn (define-condition ,name (,@parent-types simple-error) () ,@(and docstring `((:documentation ,docstring)))) (defun ,name (message &rest args) ,@(and docstring `(,docstring)) (error ',name :format-control message :format-arguments args)))) (defmacro form-beginning-with (sym form) `(and (listp ,form) (symbolp (car ,form)) (string= (symbol-name (car ,form)) ,(symbol-name sym)))) (defun strip-declarations (forms) (loop while (form-beginning-with declare (car forms)) do (pop forms) finally (return forms))) (defun plist-to-long-options (plist &aux args) (doplist (k v plist args) (push (strcat "--" (string-downcase (symbol-name k)) "=" v) args))) (defun systemd-user-instance-args (args) "Where ARGS are args to RUN or MRUN for an invocation of a systemd command which can take \"--user\", insert the \"--user\" parameter, and modify or insert an :ENV parameter so that the call is more likely to succeed." (loop with xrd = (format nil "/run/user/~D" (get-connattr :remote-uid)) with dsba = (format nil "unix:path=~A/bus" xrd) with arg-done and env-done while args as next = (pop args) collect next into accum if (and (not arg-done) (stringp next)) collect "--user" into accum and do (setq arg-done t) if (eql :env next) collect (aprog1 (copy-list (pop args)) (setf (getf it :XDG_RUNTIME_DIR) xrd (getf it :DBUS_SESSION_BUS_ADDRESS) dsba env-done t)) into accum if (eql :input next) collect (pop args) finally (return (if env-done accum (list* :env `(:XDG_RUNTIME_DIR ,xrd :DBUS_SESSION_BUS_ADDRESS ,dsba) accum))))) (defmacro with-local-temporary-directory ((dir) &body forms) "Execute FORMS with a local temporary directory's pathname in DIR. Currently assumes GNU mktemp(1). There is no WITH-REMOTE-TEMPORARY-DIRECTORY because POSIX doesn't include a shell utility to create temporary directories. If you need a remote temporary directory, one solution is to convert your property to a :LISP property." `(let ((,dir (ensure-directory-pathname (stripln (run-program "umask 077; mktemp -d" :output :string))))) (unwind-protect (progn ,@forms) (delete-directory-tree ,dir :validate t)))) (defun pathname-file (pathname) "Like PATHNAME-NAME but include any file extension." (and (pathname-name pathname) (namestring (if (pathname-directory pathname) (enough-pathname pathname (pathname-directory-pathname pathname)) pathname)))) (defun local-directory-contents (pathname) "Return the immediate contents of PATHNAME, a directory, without resolving symlinks. Not suitable for use by :POSIX properties." ;; On SBCL on Debian UIOP:*WILD-FILE-FOR-DIRECTORY* is #P"*.*". (uiop:directory* (merge-pathnames uiop:*wild-file-for-directory* (ensure-directory-pathname pathname)))) (defun ensure-trailing-slash (namestring) (if (string-suffix-p namestring "/") namestring (strcat namestring "/"))) (defun drop-trailing-slash (namestring) (if (string-suffix-p namestring "/") (subseq namestring 0 (1- (length namestring))) namestring)) (defun reinit-from-simple-print (class &rest slots) (aprog1 (allocate-instance (find-class class)) (loop for (slot-name slot-value) on slots by #'cddr do (setf (slot-value it slot-name) slot-value)))) (defmacro quote-nonselfeval (x) (once-only (x) `(if (member (type-of ,x) '(cons symbol)) `',,x ,x))) (defmacro define-simple-print-object (class) "Define an implementation of PRINT-OBJECT suitable for classes representing simple collections of readably-printable values." `(defmethod print-object ((object ,class) stream) (if (and *print-readably* *read-eval*) (format stream "#.~S" `(reinit-from-simple-print ',(type-of object) ;; Call CLASS-OF so that subclasses of CLASS are handled too. ,@(loop for slot in (closer-mop:class-slots (class-of object)) for slot-name = (closer-mop:slot-definition-name slot) when (slot-boundp object slot-name) collect `',slot-name and collect (quote-nonselfeval (slot-value object slot-name))))) (call-next-method)) object)) (defun chroot-pathname (pathname chroot) (merge-pathnames (enough-pathname pathname #P"/") (ensure-directory-pathname chroot))) (defun in-chroot-pathname (pathname chroot) (ensure-pathname (enough-pathname pathname chroot) :ensure-absolute t :defaults #P"/")) (defun sh-escape (token-or-cmd &optional s) (cond ((listp token-or-cmd) (uiop:escape-command token-or-cmd s 'sh-escape)) ((pathnamep token-or-cmd) (sh-escape (unix-namestring token-or-cmd) s)) ((string= token-or-cmd "") (format s "\"\"")) (t (uiop:escape-sh-token token-or-cmd s)))) (defun parse-username-from-id (output) "Where OUTPUT is the output of the id(1) command, extract the username." (multiple-value-bind (match groups) (re:scan-to-strings "^uid=[0-9]+\\(([^)]+)" output) (and match (elt groups 0)))) ;; not DEFCONSFIG because a consfig is a system not a package (defmacro defpackage-consfig (name &body forms) "Convenience wrapper around DEFPACKAGE for consfigs. Adds recommended local nicknames for all the property and data source packages that come with Consfigurator. Either use this directly or use its macro expansion as a starting point for your own DEFPACKAGE form for your consfig." (let ((forms (copy-tree forms)) (local-nicknames (cons :local-nicknames (loop for package in (list-all-packages) for name = (package-name package) if (string-prefix-p "CONSFIGURATOR.PROPERTY." name) collect (list (make-symbol (subseq name 23)) (make-symbol name)) else if (string-prefix-p "CONSFIGURATOR.DATA." name) collect (list (make-symbol (subseq name 14)) (make-symbol name)))))) (if-let ((form (loop for form on forms when (and (listp (car form)) (eql :local-nicknames (caar form))) return form))) (rplaca form (nconc local-nicknames (cdar form))) (push local-nicknames forms)) ;; Not much benefit to importing CONSFIGURATOR for the user as it only ;; needs to be done once, and some users will prefer to import qualified, ;; but we could also have: ;; (if-let ((form (loop for form on forms ;; when (and (listp (car form)) (eql :use (caar form))) ;; return form))) ;; (rplaca form (list* :use '#:consfigurator (cdar form))) ;; (push '(:use '#:cl '#:consfigurator) forms)) `(defpackage ,name ,@forms))) (defmacro lambda-ignoring-args (&body body) (multiple-value-bind (forms declarations) (parse-body body) (with-gensyms (ignore) `(lambda (&rest ,ignore) (declare (ignore ,ignore) ,@declarations) ,@forms)))) (defun parse-cidr (address-with-suffix) (destructuring-bind (address cidr) (split-string address-with-suffix :separator "/") (unless cidr (simple-program-error "~A is not in CIDR notation." address-with-suffix)) (values address (loop with cidr = (parse-integer cidr) with type = (if (or (> cidr 32) (find #\: address)) 6 4) with block-digits = (if (= type 4) 8 16) repeat (if (= type 4) 4 8) for digits = (min cidr block-digits) do (decf cidr digits) collect (parse-integer (with-output-to-string (s) (loop repeat digits do (princ #\1 s)) (loop repeat (- block-digits digits) do (princ #\0 s))) :radix 2) into accum finally (return (if (= type 4) (format nil "~{~D~^.~}" accum) (with-output-to-string (s) (loop for blocks on accum if (> (car blocks) 0) do (format s "~X" (car blocks)) and if (cdr blocks) do (princ #\: s) end else do (princ #\: s) (loop-finish))))))))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-constant +alphanum+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" :test #'string=)) (defun random-alphanumeric (length) "Return a random alphanumeric string of length LENGTH." (aprog1 (make-string length) (loop with *random-state* = (make-random-state t) for i below length do (setf (char it i) (char +alphanum+ (random #.(length +alphanum+))))))) (defun mkfifo () "Use mkfifo(3) to create a named pipe with a mkstemp(3)-like name." (let* ((dir (drop-trailing-slash (or (getenv "TMPDIR") "/tmp"))) (dir-ls (run-program `("env" "LANG=C" "ls" "-lnd" ,dir) :output :string)) (prefix (strcat dir "/tmp."))) (unless (and (char= #\d (char dir-ls 0)) (char-equal #\t (char dir-ls 9)) (zerop (parse-integer (caddr (words dir-ls))))) (error "~A is not a root-owned dir with the sticky bit set." dir)) (flet ((mktemp () ;; We need to generate a temporary name. We don't have to worry ;; about race conditions as mkfifo(3) will fail if the file ;; already exists. (loop with result = (make-string (+ 6 (length prefix))) initially (setf (subseq result 0 (length prefix)) prefix) for i from (length prefix) below (length result) do (setf (char result i) (char +alphanum+ (random #.(length +alphanum+)))) finally (return result))) (mkfifo (temp) (handler-case (nix:mkfifo temp #o600) (serious-condition (c) (if (or (file-exists-p temp) (directory-exists-p temp)) nil (signal c)))))) (loop with *random-state* = (make-random-state t) repeat 3 for temp = (mktemp) when (mkfifo temp) return (pathname temp))))) (defmacro with-mkfifos ((&rest mkfifos) &body forms) `(let ,(loop for mkfifo in mkfifos collect `(,mkfifo (mkfifo))) (unwind-protect (progn ,@forms) ,@(loop for mkfifo in mkfifos collect `(delete-file ,mkfifo))))) (defun write-to-mkfifo (object fifo) (with-standard-io-syntax (write object :stream fifo) (terpri fifo) (finish-output fifo))) (defun valid-hostname-p (string) "Test whether STRING looks like a valid hostname, as defined by RFCs 952 and 1123." (and (<= (length string) 253) (let ((parts (split-string string :separator "."))) (every (lambda (part) (and (<= (length part) 63) (re:scan "^[a-zA-Z0-9][a-zA-Z0-9-]*$" part))) parts)))) (defmacro prog-changes (&body body) (with-gensyms (result) `(let ((,result :no-change)) (block prog-changes (flet ((add-change (&optional result) (case result (:no-change result) (t (setq ,result result)))) (return-changes () (return-from prog-changes ,result))) (declare (ignorable #'return-changes)) ,@body ,result))))) (defun sh-script-to-single-line (script) "Attempt to convert a multiline POSIX sh script to a single line. The current implementation is naïve, and certainly unsuitable for converting arbitrary scripts. Thus, this function is presently intended to be used only on simple scripts embedded in source code, written with newlines for the sake of maintainability. Converting those scripts to single lines before they are executed improves Consfigurator's debug output, and also makes process names visible to remote commands like ps(1) more readable." (re:regex-replace-all #?/\s+/ (re:regex-replace-all "(then|else|elif|fi|case|in|;;|do|done);" (format nil "~{~A~^; ~}" (lines script)) "\\1") " ")) ;;;; Progress & debug printing (defvar *consfigurator-debug-level* 0 "Integer. Higher values mean be more verbose during deploys.") (defvar *inform-prefix* ";; ") (defmacro with-indented-inform (&body forms) `(let ((*inform-prefix* (strcat *inform-prefix* " "))) ,@forms)) (defun inform (level output &key strip-empty (fresh-line t)) "Print something to the user during deploys." (unless (and (numberp level) (> level *consfigurator-debug-level*)) (let ((lines (loop for line in (etypecase output (cons output) (string (lines output))) ;; strip (first part of) prefix added by a remote Lisp for stripped = (if (string-prefix-p ";; " line) (subseq line 3) line) unless (and strip-empty (re:scan #?/\A\s*\z/ stripped)) collect stripped))) (when fresh-line (fresh-line) (princ *inform-prefix*)) (princ (pop lines)) (dolist (line lines) (fresh-line) (princ *inform-prefix*) (princ line))))) (defun informat (level control-string &rest format-arguments) "Print something to the user during deploys using FORMAT. Be sure to begin CONTROL-STRING with ~& unless you want to continue from previous output." (if (string-prefix-p "~&" control-string) (inform level (apply #'format nil (subseq control-string 2) format-arguments) :fresh-line t) (inform level (apply #'format nil control-string format-arguments) :fresh-line nil))) ;;;; Version numbers (defun compare-versions (x y &optional less-than-or-equal) (flet ((components (v) (etypecase v (number (list v)) (string (loop with buf = (make-array 0 :fill-pointer 0 :element-type 'character) for c across v if (digit-char-p c) do (vector-push-extend c buf) else if (and (char= c #\.) (plusp (fill-pointer buf))) collect (parse-integer buf) into accum and do (setf (fill-pointer buf) 0) else do (loop-finish) finally (return (if (plusp (fill-pointer buf)) (nconc accum (list (parse-integer buf))) accum))))))) (setq x (components x) y (components y)) (if less-than-or-equal (loop while (or x y) for a = (or (pop x) 0) and b = (or (pop y) 0) never (> a b) if (< a b) return t) (loop while (or x y) for a = (or (pop x) 0) and b = (or (pop y) 0) thereis (> b a) if (< b a) return nil)))) (defun version< (x y) (compare-versions x y)) (defun version<= (x y) (compare-versions x y t)) (defun version> (x y) (compare-versions y x)) (defun version>= (x y) (compare-versions y x t)) ;;;; Encoding of strings to filenames ;; Encoding scheme based on one by Joey Hess -- File.configFileName in ;; propellor. Try to avoid including non-alphanumerics other than '.' and '_' ;; in the filename, such that it both remains roughly human-readable and is ;; likely to be accepted by programs which don't treat filenames as opaque ;; (and interpret them with a charset sufficiently similar to Lisp's). ;; This implementation also assumes that the Lisp doing the decoding has the ;; same charset as the Lisp doing the encoding. (defun string-to-filename (s) (apply #'concatenate 'string (loop for c across (etypecase s (string s) (number (write-to-string s))) if (or (char= c #\.) (alpha-char-p c) (digit-char-p c)) collect (format nil "~C" c) else collect (format nil "_~X_" (char-code c))))) (defun filename-to-string (s) (loop with decoding with buffer with result for c across s do (cond ((and (char= c #\_) (not decoding)) (setq decoding t)) ((and (char= c #\_) decoding) (unless buffer (error "invalid encoding")) (push (code-char (read-from-string (coerce (list* #\# #\x (nreverse buffer)) 'string))) result) (setq buffer nil decoding nil)) (decoding (push c buffer)) (t (push c result))) finally (return (coerce (nreverse result) 'string)))) ;;;; Forking utilities ;;; Use implementation-specific fork(2) wrapper, and never fork(2) itself, to ;;; allow the implementation to handle things like finaliser threads. For all ;;; other syscalls/libc & POSIX macros like WIFEXITED, use CFFI, via Osicat ;;; when there's a wrapper available, for portability. (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)) (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 (list *debug-io* *terminal-io* *standard-output* *error-output*)) (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 application was instead skipped over, either due to the semantics of a property combinator, or because the user elected to skip the property in the interactive debugger.")) (defmacro with-deployment-report (&body forms) (with-gensyms (failures) `(let* (,failures (result (handler-bind ((skipped-properties (lambda (c) (declare (ignore c)) (setq ,failures t)))) ,@forms))) (inform t (cond ((eql :no-change result) "No changes were made.") (,failures "There were failures while attempting to apply some properties.") (t "Changes were made without any reported failures.")))))) (defmacro with-backtrace-and-exit-code (&body forms) (with-gensyms (failures) `(let* (,failures (result (handler-bind ((serious-condition (lambda (c) (trivial-backtrace:print-backtrace c :output *error-output*) (uiop:quit 1))) (skipped-properties (lambda (c) (declare (ignore c)) (setq ,failures t)))) ,@forms))) (uiop:quit (cond ((eql :no-change result) 0) (,failures 22) (t 23)))))) (defmacro exit-code-to-retval (exit &key on-failure) `(values nil (case ,exit (0 :no-change) (22 (signal 'skipped-properties) nil) (23 nil) (t ,on-failure)))) (defun posix-login-environment (&optional uid logname home) "Reset the environment after switching UID, or similar, in a :LISP connection. Does not currently establish a PAM session." (let ((rootp (zerop (or uid (nix:geteuid)))) (maybe-preserve '("TERM"))) (when rootp (push "SSH_AUTH_SOCK" maybe-preserve)) (let ((preserved (loop for var in maybe-preserve for val = (getenv var) when val collect var and collect val))) (clearenv) (loop for (var val) on preserved by #'cddr do (setf (getenv var) val))) (when logname (setf (getenv "USER") logname (getenv "LOGNAME") logname)) (when home (setf (getenv "HOME") (drop-trailing-slash (unix-namestring home))) (uiop:chdir home)) (setf (getenv "SHELL") "/bin/sh" (getenv "PATH") (if rootp "/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin" "/usr/local/bin:/bin:/usr/bin")))) ;;;; System and libc calls which can fail ;;; Osicat has an implementation of this but it's not exported. However, we ;;; are able to instantiate Osicat's POSIX-ERROR to simplify errno handling. (defmacro define-error-retval-cfun ((&key (errno t) (failure-val -1)) &body defcfun-args) (let ((defun (etypecase (car defcfun-args) (string (translate-name-from-foreign (car defcfun-args) '*package*)) (list (cadar defcfun-args)))) (cfun (etypecase (car defcfun-args) (string (car defcfun-args)) (list (caar defcfun-args)))) (failure-val-check (once-only (failure-val) `(cond ((numberp ,failure-val) (= ,failure-val result)) ((pointerp ,failure-val) (pointer-eq ,failure-val result)) (t (simple-program-error "Don't know how to compare function return value with ~S." ,failure-val)))))) `(defun ,defun ,(loop for arg in (cddr defcfun-args) collect (car arg)) ,@(and (eql errno :zero) '((nix:set-errno 0))) (let ((result (foreign-funcall ,cfun ,@(loop for arg in (cddr defcfun-args) collect (cadr arg) collect (car arg)) ,(cadr defcfun-args)))) (if ,(if (eql errno :zero) `(and ,failure-val-check (not (zerop (nix:get-errno)))) failure-val-check) (nix:posix-error ,(and errno '(nix:get-errno)) nil ',defun) result))))) ;;;; Miscellaneous system functions (define-error-retval-cfun () "clearenv" :int) (define-error-retval-cfun () "chroot" :int (path :string)) (define-error-retval-cfun () "unshare" :int (flags :int)) ;;;; Lisp data files (defmacro with-lisp-data-file ((data file) &body forms) (with-gensyms (before) `(let* ((,before (and (file-exists-p ,file) (read-file-string ,file))) (,data (and ,before (plusp (length ,before)) (safe-read-from-string ,before)))) (unwind-protect (progn ,@forms) (with-open-file (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 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 streams) (dolist (stream streams streams) (when-let ((output-stream (stream->output-stream stream))) (when (open-stream-p output-stream) (funcall function output-stream)))))