From b981a5e783d491de1aad59abb5db8469b73c1080 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Tue, 16 Feb 2021 18:39:13 -0700 Subject: move code into an src/ subdir Signed-off-by: Sean Whitton --- connection/local.lisp | 42 --- connection/ssh.lisp | 46 --- consfigurator.asd | 8 +- core.lisp | 757 ---------------------------------------------- data/asdf.lisp | 25 -- data/pgp.lisp | 8 - package.lisp | 91 ------ property/command.lisp | 15 - property/file.lisp | 14 - src/connection/local.lisp | 42 +++ src/connection/ssh.lisp | 46 +++ src/core.lisp | 757 ++++++++++++++++++++++++++++++++++++++++++++++ src/data/asdf.lisp | 25 ++ src/data/pgp.lisp | 8 + src/package.lisp | 91 ++++++ src/property/command.lisp | 15 + src/property/file.lisp | 14 + src/util.lisp | 77 +++++ util.lisp | 77 ----- 19 files changed, 1079 insertions(+), 1079 deletions(-) delete mode 100644 connection/local.lisp delete mode 100644 connection/ssh.lisp delete mode 100644 core.lisp delete mode 100644 data/asdf.lisp delete mode 100644 data/pgp.lisp delete mode 100644 package.lisp delete mode 100644 property/command.lisp delete mode 100644 property/file.lisp create mode 100644 src/connection/local.lisp create mode 100644 src/connection/ssh.lisp create mode 100644 src/core.lisp create mode 100644 src/data/asdf.lisp create mode 100644 src/data/pgp.lisp create mode 100644 src/package.lisp create mode 100644 src/property/command.lisp create mode 100644 src/property/file.lisp create mode 100644 src/util.lisp delete mode 100644 util.lisp diff --git a/connection/local.lisp b/connection/local.lisp deleted file mode 100644 index e219fea..0000000 --- a/connection/local.lisp +++ /dev/null @@ -1,42 +0,0 @@ -(in-package :consfigurator.connection.local) - -(defmethod connect-and-apply ((type (eql :local)) host &key) - (apply-properties (make-instance 'local-connection) host)) - -(defclass local-connection (lisp-connection) - () - (:documentation "The root deployment: applying properties to the machine the -root Lisp is running on, as the root Lisp's uid.")) - -(defmethod connection-run ((connection local-connection) - shell-cmd - &optional - input) - ;; assumes a POSIX shell (otherwise we could wrap in 'sh -c') - (multiple-value-bind (output _ exit-code) - (uiop:run-program shell-cmd - :force-shell t - :input (and input - (make-string-input-stream input)) - :output :string - :error-output :output) - (declare (ignore _)) - (values output exit-code))) - -(defmethod connection-readfile ((connection local-connection) path) - (uiop:read-file-string path)) - -(defmethod connection-writefile ((connection local-connection) path contents) - (with-open-file (stream path :direction :output :if-exists :supersede) - (write-string contents stream))) - -(defmethod connection-upload ((connection local-connection) from to) - (uiop:copy-file from to)) - -;; set the root Lisp's connection context now we've defined its value -- other -;; implementations of ESTABLISH-CONNECTION will rely on this when they call -;; RUN, READFILE etc. -(eval-when (:load-toplevel :execute) - (unless consfigurator.core::*connection* - (setq consfigurator.core::*connection* - (make-instance 'local-connection)))) diff --git a/connection/ssh.lisp b/connection/ssh.lisp deleted file mode 100644 index 9e51ffb..0000000 --- a/connection/ssh.lisp +++ /dev/null @@ -1,46 +0,0 @@ -(in-package :consfigurator.connection.ssh) - -(defmethod establish-connection ((type (eql :ssh)) remaining - &key - (hop (hostattr *host* :hostname))) - (declare (ignore remaining)) - (run "ssh" "-fN" hop) - (make-instance 'ssh-connection :hostname hop)) - -(defclass ssh-connection (posix-connection) - ((hostname - :documentation "Hostname to SSH to.")) - (:documentation "Deploy properties using non-interactive SSH.")) - -(defmacro sshcmd (&rest args) - ;; wrap in 'sh -c' in case the login shell is not POSIX - `(list "ssh" - (slot-value connection :hostname) - (uiop:escape-sh-command "sh" "-c" ,@args))) - -(defmethod connection-run ((connection ssh-connection) - cmd - &optional - input - environment) - (when environment - (loop do (push (uiop:escape-sh-token - (strcat - (symbol-name (pop environment)) "=" (pop environment))) - cmd) - while environment - finally (push "env" cmd))) - (run-with-input input nil (sshcmd cmd))) - -(defmethod connection-readfile ((connection ssh-connection) path) - (multiple-value-bind (output error-code) - (run (sshcmd "test" "-r" "path" "&&" "cat" path)) - (if (= 0 error-code) - output - (error "File ~S not readable" path)))) - -;; write to a temporary file, and then atomically move into place -(defmethod connection-writefile ((connection ssh-connection) path contents)) - -;; rsync it to a temporary location, and then atomically move into place -(defmethod connection-upload ((connection ssh-connection) from to)) diff --git a/consfigurator.asd b/consfigurator.asd index 08db699..a28e339 100644 --- a/consfigurator.asd +++ b/consfigurator.asd @@ -3,7 +3,7 @@ :depends-on (#:cl-ppcre #:alexandria #:cl-interpol) - :components ((:file "package") - (:file "util") - (:file "core") - (:file "connection/ssh"))) + :components ((:file "src/package") + (:file "src/util") + (:file "src/core") + (:file "src/connection/ssh"))) diff --git a/core.lisp b/core.lisp deleted file mode 100644 index afa80c4..0000000 --- a/core.lisp +++ /dev/null @@ -1,757 +0,0 @@ -(in-package :consfigurator.core) - -;;;; Connections - -;; generic function operating on keywords which identify connection types -(defgeneric establish-connection (type remaining &key) - (:documentation - "Within the context of the current connection, connect to HOST by establishing -a new connection of type TYPE. -Either starts a Lisp process somewhere else, tells it to continue establishing -REMAINING (by telling it to call DEPLOY* with arguments obtained by (locally) -evaluating, on our side of the connection, -(list (or REMAINING '(:local)) *host*)), and returns nil, or returns a object -suitable for *connection*. - -Any implementation which hands over to a remote Lisp process will need to -upload any prerequisite data required by the deployment.")) - -(defclass connection () - ((parent - :initform *connection* - :documentation - "The value of *CONNECTION* at the time this connection was established."))) - -(defclass lisp-connection (connection) ()) - -(defclass posix-connection (connection) ()) - -;;; generic functions to operate on subclasses of CONNECTION - -(defgeneric connection-run (connection cmd &optional input environment) - (:documentation "Subroutine to run shell commands on the host.")) - -(defmethod connection-run :around ((connection connection) cmd &optional input) - (let ((*connection* (slot-value connection 'parent))) - (call-next-method))) - -(defgeneric connection-readfile (connection path) - (:documentation "Subroutine to read the contents of files on the host.")) - -(defmethod connection-readfile :around ((connection connection) path) - (let ((*connection* (slot-value connection 'parent))) - (call-next-method))) - -;; only functional difference between writefile and upload is what args they -;; take: a string vs. a path. they may have same or different implementations - -(defgeneric connection-writefile (connection path contents) - (:documentation - "Subroutine to replace/create the contents of files on the host.")) - -(defmethod connection-writefile :around ((connection connection) path contents) - (let ((*connection* (slot-value connection 'parent))) - (call-next-method))) - -(defgeneric connection-upload (connection from to) - (:documentation "Subroutine to upload files to the host.")) - -(defmethod connection-upload :around ((connection connection) from to) - (let ((*connection* (slot-value connection 'parent))) - (call-next-method))) - -(defgeneric connection-teardown (connection) - (:documentation "Subroutine to disconnect from the host.")) - -(defmethod connection-teardown :around ((connection connection)) - (let ((*connection* (slot-value connection 'parent))) - (call-next-method))) - -;; many connection types don't need anything to be done to disconnect -(defmethod connection-teardown (&rest args) - (declare (ignore args)) - (values)) - -;; global value gets set in connection/local.lisp, but the symbol is not -;; exported as it should only get bound by APPLY-PROPERTIES -(defvar *connection* nil - "Object representing the currently active connection. -Connections dynamically bind this variable and then apply properties. Its -global value be regarded as a constant.") - -(defvar *host* nil - "Object representing the host to which we're currently connected. -Deployments bind this variable. Its global value should remain nil. - -The main point of this is to allow properties to read the static informational -attributes of the host to which they're being applied.") - - -;;;; Functions to access the slots of the current connection - -;; used by properties and by implementations of ESTABLISH-CONNECTION - -(defun run (&rest args) - (funcall #'connection-run - *connection* - (if (cdr args) (uiop:escape-sh-command args) args))) - -(defun run-with-input (input environment &rest args) - (funcall #'connection-run - *connection* - (if (cdr args) (uiop:escape-sh-command args) args) - input - environment)) - -(defun runlines (&rest args) - (unlines (apply #'run args))) - -(defun runlines-with-input (&rest args) - (unlines (apply #'run-with-input args))) - -(defun readfile (&rest args) - (apply #'connection-readfile *connection* args)) - -(defun writefile (&rest args) - (apply #'connection-writefile *connection* args)) - - -;;;; Properties - -;; Properties are not stored as CLOS objects (or structs) in value cells -;; because they are immutable -- see "Attempting to work with anonymous -;; properties or connection types" in the docs. An alternative would be to -;; use the function cell to store a function which takes -;; 'apply/'hostattrs/etc. as its first argument and dispatches, but those -;; could be flet, which is forbidden. A determined user could of course edit -;; the symbol plist entries, but we want to make it difficult for someone who -;; hasn't read the docs to accidentally violate immutability - -(defun setprop (sym type &key args desc hostattrs check apply unapply) - ;; use non-keyword keys to avoid clashes with other packages - (when type - (setf (get sym 'type) type)) - (when desc - (setf (get sym 'desc) desc)) - (when hostattrs - (setf (get sym 'hostattrs) hostattrs)) - (when check - (setf (get sym 'check) check)) - (when apply - (setf (get sym 'apply) apply)) - (when unapply - (setf (get sym 'unapply) unapply)) - sym) - -(defun proptype (prop) - (get prop 'type)) - -(defun propapptype (propapp) - (get (car propapp) 'type)) - -(defun collapse-types (&rest lists) - (if (some (lambda (type) (eq type :posix)) - (flatten lists)) - :posix - :lisp)) - -(defun propdesc (prop) - (get prop 'desc)) - -(defun propargs (prop) - (get prop 'args)) - -(defun propattrs (prop &rest args) - (apply (get prop 'hostattrs (lambda (&rest args) - (declare (ignore args)) - (values))) - args)) - -(defun propappattrs (propapp) - (apply #'propattrs (car propapp) (cdr propapp))) - -(defun propcheck (prop &rest args) - (apply (get prop 'check (lambda (&rest args) - (declare (ignore args)) - (values))) - args)) - -(defun propappcheck (propapp) - (apply #'propcheck (car propapp) (cdr propapp))) - -(defun propapply (prop &rest args) - (apply (get prop 'apply (lambda (&rest args) - (declare (ignore args)) - (values))) - args)) - -(defun propappapply (propapp) - (apply #'propapply (car propapp) (cdr propapp))) - -(defun propunapply (prop &rest args) - (apply (get prop 'unapply (lambda (&rest args) - (declare (ignore args)) - (values))) - args)) - -(defun propappunapply (propapp) - (apply #'propunapply (car propapp) (cdr propapp))) - -;;; standard way to write properties is to use one of these two macros - -;; TODO when forms is not (:apply etc.) but just code, we could just consider -;; that all to be :apply, and leave :hostattrs, :check and :unapply blank? -;; TODO :push-hostattrs to specify a function which does not look at -;; *hostattrs* and just returns a list which gets added to the front (we will -;; wrap (push ... *hostattrs*) around the return value, basically) -(defmacro defprop (name type args &body forms) - (let ((slots (list :args args))) - (when (stringp (car forms)) - (setf (getf slots :desc) (pop forms))) - (loop for form in forms - if (keywordp (car form)) - do (setf (getf slots (car form)) (cdr form))) - (loop for kw in '(:hostattrs :check :apply :unapply) - do (if-let ((slot (getf slots kw))) - (setf (getf slots kw) - ;; inside this lambda we could do some checking of, e.g., - ;; whether we are :lisp but this connection is - ;; posix-connection. possibly a condition with a restart - ;; which allows skipping over this property - `(lambda ,args ,@slot)))) - `(setprop ',name ,type ,@slots))) - -(defmacro defproplist (name args &body propspec) - "Define a property which applies a property application specification.") - - -;;;; Property application specifications - -(defvar *consfig* nil - "A list of names of the ASDF systems in which you define your hosts, -site-specific properties and deployments. These systems should depend on the -\"consfigurator\" system. - -More specifically, in normal usage of Consfigurator, calling -(mapc #'asdf:require-system *consfig*) should be sufficient to define all the -properties you intend to apply to hosts. - -Use the SETCONSFIG macro at the top of your consfig to set this value. - -Note that you can use Consfigurator without setting this variable, by -explicitly specifying the names of systems when creating property application -specifications. This is useful if you have more than one consfig that you -want to keep completely independent of each other.") - -(defmacro setconsfig (systems) - "Set the value of *consfig*. SYSTEMS can be a name or a list of names." - (when (atom systems) - (setq systems (list systems))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setq *consfig* ',systems))) - -(defclass propspec () - ((systems - :initarg :systems - :documentation "List of names of systems, the loading of all of which is -sufficient to deploy this propspec.") - (applications - :initarg :props - :documentation "Ordered list of property applications. -The base case valid entry is of the form (PROPERTY . ARGS) where PROPERTY is -a symbol naming a property (typically as defined by DEFPROP) and ARGS is a -list of arguments to be passed when calling the property's subroutines. These -ARGS will not be evaluated before calling the function. - -Additionally, entries can be of the following forms: - - (unapply (PROPERTY . ARGS)) -- unapply the property, if it supports that. - - ((PROPERTY . ARGS) onchange (PROPERTY . ARGS) onchange (PROPERTY . ARGS)) - -- apply the second and third properties in the case that the first - property actually had work to do. - -... and combinations thereof. - -Deployments apply properties in the order specified here, so later entries in -the list implicitly depend on earlier ones. - -Members of ARGS must all be objects which can be serialised. In particular, -function objects are not permitted.")) - (:documentation - "The point of this data structure is to be a way to inform a Lisp process -running on a remote host how it can apply some properties: load each of the -systems, resolve unapply, onchange etc., and then look in the value cell of -each PROPERTY to find a property, and pass each of ARGS to the function in the -property's apply slot.")) - -;; The following four functions, plus simple concatenation, should be -;; everything we need to do with propspecs, so all knowledge of the possible -;; combinator symbols should be confined to these four functions -- i.e., if -;; we are to add any combinators, this is the code that needs to change - -(defun compile-propapp (propapp) - "Recursively apply the effects of property combinators in PROPAPP to produce -an atomic property application." - (let ((sym (gensym))) - (cond - ;; UNAPPLY - ((symbol-named unapply (car propapp)) - (destructuring-bind (psym . args) (compile-propapp (cadr propapp)) - (setprop sym (proptype psym) - :desc (concat "Unapply: " (propdesc psym)) - :check (complement (get psym 'check)) - :apply (get psym 'unapply) - :unapply (get psym 'apply)) - (cons sym args))) - ;; ON-CHANGE - ;; Following pretty much assumes that on-change is our only infix - ;; property combinator. - ((symbol-named on-change (cadr propapp)) - (let ((propapps (loop with remaining = (cdr propapp) - with apps - for s = (pop remaining) - for a = (pop remaining) - unless (symbol-named on-change s) - do (error "Invalid on-change expression") - else - do (push (compile-propapp a) apps) - unless remaining return apps))) - (destructuring-bind (psym . args) (compile-propapp (car propapp)) - (setprop sym (collapse-types (proptype psym) - (mapcar #'propapptype propapps)) - :desc (propdesc psym) - :hostattrs (lambda (&rest args) - (nconc (apply #'propattrs psym args) - (mapcan #'propappattrs propapps))) - :check (get psym 'check) - :apply (lambda (&rest args) - (unless (eq :nochange - (apply #'propapply psym args)) - (loop for propapp in propapps - do (unless (propappcheck propapp) - (propappapply propapp))))) - :unapply (lambda (&rest args) - (unless (eq :nochange - (apply #'propunapply psym args)) - (loop for propapp in propapps - do (unless (propappcheck propapp) - (propappapply propapp)))))) - (cons sym args)))) - ;; atomic property application - (t - propapp)))) - -(defun eval-propspec (propspec) - "Apply properties as specified by PROPSPEC." - (mapc #'asdf:require-system (slot-value propspec 'systems)) - (loop for form in (slot-value propspec 'applications) - for propapp = (compile-propapp form) - unless (propappcheck propapp) - do (propappapply propapp))) - -(defun propspec->hostattrs (propspec) - "Return all the hostattrs which should be applied to the host which has -PROPSPEC applied." - (loop with *hostattrs* - for form in (slot-value propspec 'applications) - for propapp = (compile-propapp form) - do (propappattrs propapp) - finally (return *hostattrs*))) - -(defun propspec->type (propspec) - "Return :lisp if any types of the properties to be applied by PROPSPEC is -:lisp, else return :posix." - (loop for form in (slot-value propspec 'applications) - for propapp = (compile-propapp form) - if (eq (propapptype propapp) :lisp) - return :lisp - finally (return :posix))) - -(defun props (forms &optional systems) - "Where FORMS is the elements of an unevaluated property application -specification, return code which will evaluate the expressions and produce the -corresponding property application specification. - -SYSTEMS is the 'systems attribute of the property application specification -that the returned code should produce. - -Intended for use by macros which allow the user to provide expressions instead -of values as the arguments to properties when building a property application -specification." - (if systems - (when (atom systems) - (setq systems (list systems))) - ;; TODO maybe setconsfig could set *consfig* just within the current - ;; package and then macros bind it or pass it to this function. then no - ;; global value, i.e. drop that piece of state. - (if *consfig* - (setq systems (list *consfig*)) - (error "*consfig* not set"))) - (labels ((make-eval-propspec (form) - (if (atom form) - `(quote ,form) - (destructuring-bind (first . rest) form - (if (and (symbolp first) - (not (member (symbol-name first) - '("UNAPPLY") - :test #'string=))) - `(list ',first ,@rest) - `(list ,@(mapcar #'make-eval-propspec form))))))) - `(make-instance - 'propspec - :systems ',systems - :props (list ,@(mapcar #'make-eval-propspec forms))))) - -;;; property :hostattrs subroutines - -(defvar *hostattrs* nil - "Used by property :hostattrs subroutines, only, to access and modify the -current static informational attributes, and to add new ones.") - -(defun add-hostattr (k v) - (push *hostattrs* v) - (push *hostattrs* k)) - -(defun require-data (iden1 iden2) - (push (getf *hostattrs* :data) (cons iden1 iden2))) - - -;;;; Hosts - -(defclass host () - ((hostattrs - :initarg :attrs - :documentation "Plist of the host's static informational attributes.") - (propspec - :initarg :props - :documentation "Property application specification of the properties to -be applied to the host."))) - -(defun hostattr (host key) - "Retrieve a single static informational attribute." - (getf (slot-value host 'hostattrs) key)) - -(defmacro defhost (hostname &body properties) - "Define a host with hostname HOSTNAME and properties PROPERTIES. -HOSTNAME can be a string or a symbol. In either case, the host will get a -static informational property with its hostname as a string, and the symbol -whose name is the hostname will be bound to the host object. - -If the first entry in PROPERTIES is a string, it will be considered a -human-readable description of the host. Otherwise, PROPERTIES is an -unevaluated property application specification. Recall that for atomic -entries (PROPERTY . ARGS), PROPERTY refers to the property that symbol names -in the global environment, not whatever it may name in the current dynamic -and/or lexical environments. Property application specifications cannot -close over globally anonymous properties. - -The order of PROPERTIES matters: deployments will apply properties to the host -in the order specified here, so later properties implicitly depend on earlier -ones. In addition, static informational attributes set by later properties -are allowed to override any attributes with the same name set by earlier -entries." - (let (hostname-sym hostattrs) - (etypecase hostname - (string (setq hostname-sym (intern hostname))) - (symbol (setq hostname-sym hostname - hostname (string-downcase (symbol-name hostname))))) - (setf (getf hostattrs :hostname) hostname) - (when (stringp (car properties)) - (setf (getf hostattrs :desc) (pop properties))) - `(progn - (declaim (type host ,hostname-sym)) - (defparameter ,hostname-sym - (let* ((propspec ,(props properties)) - (hostattrs (nconc (propspec->hostattrs propspec) - ',hostattrs))) - (make-instance 'host :attrs hostattrs :props propspec)) - ,(getf hostattrs :desc))))) - - -;;;; Deployments - -(defmacro defdeploy (name (connection host) &body additional-properties) - "Define a function which does (DEPLOY CONNECTION HOST ADDITIONAL-PROPERTIES). -You can then eval (NAME) to execute this deployment." - `(defun ,name () - (deploy ,connection ,host ,@additional-properties))) - -(defmacro defdeploy-these (name (connection host) &body properties) - "Define a function which does (DEPLOY-THESE CONNECTION HOST PROPERTIES). -You can then eval (NAME) to execute this deployment." - `(defun ,name () - (deploy-these ,connection ,host ,@properties))) - -(defmacro defhostdeploy (connection host-name) - "Where HOST-NAME names a host as defined with DEFHOST, define a function -which does (deploy CONNECTION (symbol-value HOST)). -You can then eval (HOST-NAME) to execute this deployment. - -For example, if you usually deploy properties to athena by SSH, - - (defhost athena.silentflame.com - (foo) - (bar) - ...) - - (defhostdeploy :ssh athena.silentflame.com) - -and then you can eval (athena.silentflame.com) to apply athena's properties." - `(defdeploy ,host-name (,connection ,host-name))) - -(defmacro deploy (connection host &body additional-properties) - "Establish a connection of type CONNECTION to HOST, and apply each of the -host's usual properties, followed by specified by ADDITIONAL-PROPERTIES, an -unevaluated property application specification. - -CONNECTION is either a keyword identifying a connection type, or a list -beginning with such a keyword and followed by keyword arguments required to -establish the connection. - -Then HOST has all its usual static informational attributes, plus any set by -ADDITIONAL-PROPERTIES. Static informational attributes set by -ADDITIONAL-PROPERTIES can override the host's usual static informational -attributes, in the same way that later entries in the list of properties -specified in DEFHOST forms can override earlier entries (see DEFHOST's -docstring)." - (once-only (host) - (with-gensyms (propspec) - `(let ((,propspec ,(props additional-properties))) - (deploy* ,connection - (make-instance 'host - :attrs (nconc (propspec->hostattrs ,propspec) - (slot-value ,host 'hostattrs)) - :props (append (slot-value ,host 'propspec) - ,propspec))))))) - -(defmacro deploy-these (connection host &body properties) - "Establish a connection of type CONNECTION to HOST, and apply each of -the properties specified by PROPERTIES, an unevaluated property application -specification (and not the host's usual properties, unless they also appear -in PROPERTIES). - -CONNECTION is either a keyword identifying a connection type, or a list -beginning with such a keyword and followed by keyword arguments required to -establish the connection. - -This function is useful to apply one or two properties to a host right now, -e.g. at the REPL when when testing new property definitions. If HOST is -usually deployed using a :lisp connection, and the property you are testing -is :posix, you might use a connection type like :ssh so that you can quickly -alternate between redefining your work-in-progress property and attempting to -apply it to HOST. - -HOST has all its usual static informational attributes, as set by its usual -properties, plus any set by PROPERTIES. Static informational attributes set -by PROPERTIES can override the host's usual static informational attributes, -in the same way that later entries in the list of properties specified in -DEFHOST forms can override earlier entries (see DEFHOST's docstring)." - (with-gensyms (propspec) - `(let ((,propspec ,(props properties))) - (deploy* ,connection - (make-instance 'host - :attrs (nconc (propspec->hostattrs ,propspec) - (slot-value ,host 'hostattrs)) - :props ,propspec))))) - -(defun deploy* (connections host) - (let ((*host* host)) - (labels - ((connect (connections) - (destructuring-bind ((type . args) . remaining) connections - (when-let ((*connection* - (apply #'establish-connection type remaining args))) - (if remaining - (connect remaining) - (apply-propspec (slot-value *host* 'propspec))) - (connection-teardown *connection*)))) - (apply-propspec (propspec) - (when (and (subtypep (class-of *connection*) 'posix-connection) - (eq :lisp (propspec->type propspec))) - (error "Cannot apply :lisp properties using :posix connection")) - (eval-propspec propspec))) - (connect (loop for connection in (ensure-cons connections) - collect (ensure-cons connection)))))) - -(defprop deploy :posix (connection host &rest additional-properties) - "Execute a Consfigurator deployment. - -Useful to have one host act a controller, applying properties to other hosts. -Also useful to set up VMs, chroots, disk images etc. on localhost.") - -(defprop deploy-these :posix (connection host &rest properties) - "Execute a deployment, but replace the properties of host with PROPERTIES. -This property is to the DEPLOY property what the DEPLOY-THESE function is to -the DEPLOY function.") - - -;;;; Prerequisite data - -(defvar *data-sources* nil "Known sources of prerequisite data.") - -(defun add-data-source (check provide) - (push (cons check provide) *data-sources*)) - -;; if this proves to be inadequate then an alternative would be to maintain a -;; mapping of ASDF systems to data sources, and then APPLY-PROPERTIES could -;; look up the data sources registered for the systems in (slot-value -;; (slot-value host 'propspec) 'systems) and bind *data-sources* to point to -;; those just how it binds *host* and *connection*. registering a source -;; means registering it in the mapping of systems to sources -(defgeneric register-data-source (type &key) - (:documentation - "Initialise and register a source of prerequisite data in this Lisp process. -Registered data sources are available to all deployments executed from the -root Lisp, regardless of the consfig which defines the host to which -properties are to be applied. (This could only cause problems if you have -different consfigs with prerequisite data which is identified by the same two -strings, in which case you will need to wrap your deployments with registering -and unregistering data sources. Usually items of prerequisite data are -identified using things like hostnames, so this is unlikely to be necessary.) - -Implementation of this function call ADD-DATA-SOURCE, providing two functions. - -Signals a condition MISSING-DATA-SOURCE when unable to access the data source -(e.g. because can't decrypt it). This condition is captured and ignored in -all Lisp processes started up by Consfigurator, since prerequisite data -sources are not expected to be available outside of the root Lisp.")) - -(defprop data-uploaded (iden1 iden2 &optional destination) - ;; calls get-data - ) - -(defprop host-data-uploaded :posix (destination) - (:apply (propapply 'data-uploaded - (hostattr *host* :hostname) - destination - destination))) - -(defun get-data (iden1 iden2) - (if-let ((source-thunk (cdr (query-data-sources iden1 iden2)))) - (funcall source-thunk) - ;; now look in local cache -- note that this won't exist in the root Lisp, - ;; but only if we're a Lisp started up by a connection - - )) - -(defun query-data-sources (iden1 iden2) - (car (sort (loop for (ver . get) in *data-sources* - when (funcall ver iden1 iden2) - collect (cons it (lambda () - (funcall get iden1 iden2)))) - (compose #'version> #'car)))) - -;; called by implementations of ESTABLISH-CONNECTION which start up remote -;; Lisp processes -(defun upload-all-prerequisite-data (host) - (loop with *data-sources* - initially (register-data-source :asdf) - - with sorted-local-cache = (sort (get-local-cached-prerequisite-data) - (compose #'version> #'third)) - with sorted-remote-cache = (sort (get-remote-cached-prerequisite-data) - (compose #'version> #'third)) - - for (iden1 . iden2) in (getf (slot-value host :hostattrs) :data) - for highest-local-cached-version - = (third (car (remove-if-not (lambda (c) - (and (string= (first c) iden1) - (string= (second c) iden2))) - sorted-local-cache))) - for highest-remote-cached-version - = (third (car (remove-if-not (lambda (c) - (and (string= (first c) iden1) - (string= (second c) iden2))) - sorted-remote-cache))) - for (highest-source-version . highest-source) - = (query-data-sources iden1 iden2) - - if (and highest-source-version - (or (not highest-remote-cached-version) - (version< highest-remote-cached-version - highest-source-version))) - do (connection-clear-data-cache iden1 iden2) - (connection-upload-data iden1 - iden2 - highest-source-version - (funcall highest-source)) - else if (and highest-local-cached-version - (or (not highest-remote-cached-version) - (version< highest-remote-cached-version - highest-local-cached-version))) - do (connection-clear-data-cache iden1 iden2) - (connection-upload-data - iden1 - iden2 - highest-local-cached-version - (list :file - (local-data-pathname iden1 - iden2 - highest-local-cached-version))) - else if (not highest-remote-cached-version) - do (error "Could not provide prerequisite data ~S | ~S" - iden1 iden2))) - -(defun local-data-pathname (&rest segments) - (reduce #'merge-pathnames (nreverse (mapcar #'string->filename segments)) - :from-end t :initial-value (get-local-data-cache-dir))) - -(defun remote-data-pathname (&rest segments) - (reduce #'merge-pathnames (nreverse (mapcar #'string->filename segments)) - :from-end t :initial-value (get-remote-data-cache-dir))) - -(defun connection-upload-data (iden1 iden2 version data) - (let* ((dest (remote-data-pathname iden1 iden2 version))) - (run "mkdir" "-p" (uiop:unix-namestring - (uiop:pathname-directory-pathname dest))) - (cond - ((getf data :file) - ;; TODO if (string-prefix-p "text/" (getf data :mime)) then gzip, - ;; upload and gunzip - (connection-upload *connection* - (uiop:unix-namestring (getf data :file)) - dest)) - ((getf data :data) - (connection-writefile *connection* dest (getf data :data))) - (t - (error "Prerequisite data plist lacks both :file and :data entries"))))) - -(defun connection-clear-data-cache (iden1 iden2) - (let ((dir (uiop:ensure-directory-pathname - (remote-data-pathname iden1 iden2)))) - (run "rm" "-f" (strcat (uiop:unix-namestring - (uiop:pathname-directory-pathname dir)) - "/*")))) - -(defun get-local-data-cache-dir () - (uiop:ensure-pathname-directory - (strcat (or (uiop:getenv "XDG_CACHE_HOME") - (strcat (uiop:getenv "HOME") "/.cache")) - "/consfigurator/data"))) - -(defun get-local-cached-prerequisite-data () - "Return a list of items of prerequisite data in the cache local to this Lisp -process, where each entry is of the form - - '(iden1 iden2 version)." - (loop for dir in (uiop:subdirectories (get-local-data-cache-dir)) - nconc (loop for subdir in (uiop:subdirectories dir) - nconc (loop for file in (uiop:directory-files subdir) - collect (mapcar #'filename->string - (list dir subdir file)))))) - -(defun get-remote-data-cache-dir () - (uiop:ensure-pathname-directory - (car - (runlines "echo" "${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/data/")))) - -(defun get-remote-cached-prerequisite-data () - "Return a list of items of prerequisite data in the cache on the remote side -of the current connection, where each entry is of the form - - '(iden1 iden2 version)." - (mapcar (lambda (line) - (mapcar #'filename->string (split-string line :separator "/"))) - (runlines "find" (get-remote-data-cache-dir) - "-type" "f" "-printf" "%P\\n"))) diff --git a/data/asdf.lisp b/data/asdf.lisp deleted file mode 100644 index bca2346..0000000 --- a/data/asdf.lisp +++ /dev/null @@ -1,25 +0,0 @@ -(in-package :consfigurator.data.asdf) - -(defmethod register-data-source ((type (eql :asdf)) &key) - (add-data-source #'asdf-data-source-check #'get-path-to-concatenated-system)) - -(defun asdf-data-source-check (iden1 system) - (and (string= iden1 "lisp-system") - (asdf:find-system system nil))) - -(Defun get-path-to-concatenated-system (iden1 system) - "Try to concatenate all the source code for SYSTEM, store it somewhere and -return the filename." - (let ((cache-dir (uiop:ensure-pathname-directory - (strcat (or (uiop:getenv "XDG_CACHE_HOME") - (strcat (uiop:getenv "HOME") "/.cache")) - "/consfigurator/systems"))) - (op 'asdf:monolithic-concatenate-source-op) - (co (asdf:find-component system nil))) - (ensure-directories-exist cache-dir) - (asdf:initialize-output-translations `(:output-translations - (t ,cache-dir) - :disable-cache - :ignore-inherited-configuration)) - (asdf:operate op co) - (list :file (asdf:output-file op co)))) diff --git a/data/pgp.lisp b/data/pgp.lisp deleted file mode 100644 index c5affa5..0000000 --- a/data/pgp.lisp +++ /dev/null @@ -1,8 +0,0 @@ -(in-package :consfigurator.data.pgp) - -;;;; Simple PGP-encrypted file source of prerequisite data - -;; We provide an implementation of REGISTER-DATA-SOURCE and functions for the -;; user to call at the REPL to add pieces of data, see what's there, etc. (a -;; prerequisite data source which was some sort of external file-generating or -;; secrets storage database might not provide any functions for the REPL). diff --git a/package.lisp b/package.lisp deleted file mode 100644 index 3ffae1b..0000000 --- a/package.lisp +++ /dev/null @@ -1,91 +0,0 @@ -(in-package :cl-user) - -(defpackage :consfigurator.util - (:use #:cl) - (:shadowing-import-from #:uiop - #:strcat - #:string-prefix-p) - (:export #:strcat - #:string-prefix-p - - #:lines - #:unlines - #:noop - #:symbol-named - - #:version< - #:version> - #:version<= - #:version>= - - #:string->filename - #:filename->string)) - -(defpackage :consfigurator.core - (:use #:cl - #:alexandria - #:consfigurator.util) - (:export #:connect-and-apply - #:apply-properties - #:connection - #:lisp-connection - #:posix-connection - #:connection-run - #:run - #:run-with-input - #:runlines - #:runlines-with-input - #:connection-readfile - #:readfile - #:connection-writefile - #:writefile - #:connection-upload - #:connection-teardown - #:*host* - #:*hostattrs* - #:add-hostattr - #:require-data - #:establish-connection - #:defprop - #:defhost - #:hostattr - #:setconsfig - #:defdeploy - #:defdeploy-these - #:defhostdeploy - #:deploy - #:deploy-these - #:add-data-source - #:register-data-source - #:data-uploaded - #:host-data-uploaded - #:get-data - #:upload-all-prerequisite-data)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package :consfigurator) - (make-package :consfigurator :use '(cl)))) - -(defpackage :consfigurator.connection.ssh - (:use #:cl #:consfigurator)) - -(defpackage :consfigurator.property.file - (:use #:cl #:consfigurator) - (:export #:file-has-content - #:file-contains-lines)) - -(defpackage :consfigurator.property.command - (:use #:cl #:consfigurator) - (:export #:shell-command)) - -(defpackage :consfigurator.data.asdf - (:use #:cl #:consfigurator)) - -(defpackage :consfigurator.data.pgp - (:use #:cl #:consfigurator)) - -(in-package :consfigurator) -(dolist (package '(:consfigurator.core :consfigurator.util)) - (use-package package) - (do-external-symbols (sym package) - (export sym))) diff --git a/property/command.lisp b/property/command.lisp deleted file mode 100644 index a040968..0000000 --- a/property/command.lisp +++ /dev/null @@ -1,15 +0,0 @@ -(in-package :consfigurator.property.command) - -(defprop shell-command :posix (cmd args &key environment) - "A property which can be applied by running a shell command. - -Keyword argument :environment is a plist of environment variables to be set -when running the command, using env(1)." - (:apply (when environment - (let ((env (cons "env" - (loop for (var . val) in environment - collect (concat (symbol-name var) - "=" - val))))) - (setq args (nconc env args)))) - (connection-run (apply #'shellcmd cmd args)))) diff --git a/property/file.lisp b/property/file.lisp deleted file mode 100644 index 91ab379..0000000 --- a/property/file.lisp +++ /dev/null @@ -1,14 +0,0 @@ -(in-package :consfigurator.property.file) - -(defprop file-has-content :posix (path lines) - "Ensure there is a file at PATH whose lines are the elements of LINES." - (:apply (connection-writefile path (unlines lines)))) - -(defprop file-contains-lines :posix (path lines) - "Ensure there is a file at PATH containing each of LINES." - (:apply (let ((new-lines (copy-list lines)) - (existing-lines (lines (connection-readfile path)))) - (loop for existing-line in existing-lines - do (setq new-lines (delete existing-line new-lines))) - (connection-writefile path (unlines - (nconc existing-lines new-lines)))))) diff --git a/src/connection/local.lisp b/src/connection/local.lisp new file mode 100644 index 0000000..e219fea --- /dev/null +++ b/src/connection/local.lisp @@ -0,0 +1,42 @@ +(in-package :consfigurator.connection.local) + +(defmethod connect-and-apply ((type (eql :local)) host &key) + (apply-properties (make-instance 'local-connection) host)) + +(defclass local-connection (lisp-connection) + () + (:documentation "The root deployment: applying properties to the machine the +root Lisp is running on, as the root Lisp's uid.")) + +(defmethod connection-run ((connection local-connection) + shell-cmd + &optional + input) + ;; assumes a POSIX shell (otherwise we could wrap in 'sh -c') + (multiple-value-bind (output _ exit-code) + (uiop:run-program shell-cmd + :force-shell t + :input (and input + (make-string-input-stream input)) + :output :string + :error-output :output) + (declare (ignore _)) + (values output exit-code))) + +(defmethod connection-readfile ((connection local-connection) path) + (uiop:read-file-string path)) + +(defmethod connection-writefile ((connection local-connection) path contents) + (with-open-file (stream path :direction :output :if-exists :supersede) + (write-string contents stream))) + +(defmethod connection-upload ((connection local-connection) from to) + (uiop:copy-file from to)) + +;; set the root Lisp's connection context now we've defined its value -- other +;; implementations of ESTABLISH-CONNECTION will rely on this when they call +;; RUN, READFILE etc. +(eval-when (:load-toplevel :execute) + (unless consfigurator.core::*connection* + (setq consfigurator.core::*connection* + (make-instance 'local-connection)))) diff --git a/src/connection/ssh.lisp b/src/connection/ssh.lisp new file mode 100644 index 0000000..9e51ffb --- /dev/null +++ b/src/connection/ssh.lisp @@ -0,0 +1,46 @@ +(in-package :consfigurator.connection.ssh) + +(defmethod establish-connection ((type (eql :ssh)) remaining + &key + (hop (hostattr *host* :hostname))) + (declare (ignore remaining)) + (run "ssh" "-fN" hop) + (make-instance 'ssh-connection :hostname hop)) + +(defclass ssh-connection (posix-connection) + ((hostname + :documentation "Hostname to SSH to.")) + (:documentation "Deploy properties using non-interactive SSH.")) + +(defmacro sshcmd (&rest args) + ;; wrap in 'sh -c' in case the login shell is not POSIX + `(list "ssh" + (slot-value connection :hostname) + (uiop:escape-sh-command "sh" "-c" ,@args))) + +(defmethod connection-run ((connection ssh-connection) + cmd + &optional + input + environment) + (when environment + (loop do (push (uiop:escape-sh-token + (strcat + (symbol-name (pop environment)) "=" (pop environment))) + cmd) + while environment + finally (push "env" cmd))) + (run-with-input input nil (sshcmd cmd))) + +(defmethod connection-readfile ((connection ssh-connection) path) + (multiple-value-bind (output error-code) + (run (sshcmd "test" "-r" "path" "&&" "cat" path)) + (if (= 0 error-code) + output + (error "File ~S not readable" path)))) + +;; write to a temporary file, and then atomically move into place +(defmethod connection-writefile ((connection ssh-connection) path contents)) + +;; rsync it to a temporary location, and then atomically move into place +(defmethod connection-upload ((connection ssh-connection) from to)) diff --git a/src/core.lisp b/src/core.lisp new file mode 100644 index 0000000..afa80c4 --- /dev/null +++ b/src/core.lisp @@ -0,0 +1,757 @@ +(in-package :consfigurator.core) + +;;;; Connections + +;; generic function operating on keywords which identify connection types +(defgeneric establish-connection (type remaining &key) + (:documentation + "Within the context of the current connection, connect to HOST by establishing +a new connection of type TYPE. +Either starts a Lisp process somewhere else, tells it to continue establishing +REMAINING (by telling it to call DEPLOY* with arguments obtained by (locally) +evaluating, on our side of the connection, +(list (or REMAINING '(:local)) *host*)), and returns nil, or returns a object +suitable for *connection*. + +Any implementation which hands over to a remote Lisp process will need to +upload any prerequisite data required by the deployment.")) + +(defclass connection () + ((parent + :initform *connection* + :documentation + "The value of *CONNECTION* at the time this connection was established."))) + +(defclass lisp-connection (connection) ()) + +(defclass posix-connection (connection) ()) + +;;; generic functions to operate on subclasses of CONNECTION + +(defgeneric connection-run (connection cmd &optional input environment) + (:documentation "Subroutine to run shell commands on the host.")) + +(defmethod connection-run :around ((connection connection) cmd &optional input) + (let ((*connection* (slot-value connection 'parent))) + (call-next-method))) + +(defgeneric connection-readfile (connection path) + (:documentation "Subroutine to read the contents of files on the host.")) + +(defmethod connection-readfile :around ((connection connection) path) + (let ((*connection* (slot-value connection 'parent))) + (call-next-method))) + +;; only functional difference between writefile and upload is what args they +;; take: a string vs. a path. they may have same or different implementations + +(defgeneric connection-writefile (connection path contents) + (:documentation + "Subroutine to replace/create the contents of files on the host.")) + +(defmethod connection-writefile :around ((connection connection) path contents) + (let ((*connection* (slot-value connection 'parent))) + (call-next-method))) + +(defgeneric connection-upload (connection from to) + (:documentation "Subroutine to upload files to the host.")) + +(defmethod connection-upload :around ((connection connection) from to) + (let ((*connection* (slot-value connection 'parent))) + (call-next-method))) + +(defgeneric connection-teardown (connection) + (:documentation "Subroutine to disconnect from the host.")) + +(defmethod connection-teardown :around ((connection connection)) + (let ((*connection* (slot-value connection 'parent))) + (call-next-method))) + +;; many connection types don't need anything to be done to disconnect +(defmethod connection-teardown (&rest args) + (declare (ignore args)) + (values)) + +;; global value gets set in connection/local.lisp, but the symbol is not +;; exported as it should only get bound by APPLY-PROPERTIES +(defvar *connection* nil + "Object representing the currently active connection. +Connections dynamically bind this variable and then apply properties. Its +global value be regarded as a constant.") + +(defvar *host* nil + "Object representing the host to which we're currently connected. +Deployments bind this variable. Its global value should remain nil. + +The main point of this is to allow properties to read the static informational +attributes of the host to which they're being applied.") + + +;;;; Functions to access the slots of the current connection + +;; used by properties and by implementations of ESTABLISH-CONNECTION + +(defun run (&rest args) + (funcall #'connection-run + *connection* + (if (cdr args) (uiop:escape-sh-command args) args))) + +(defun run-with-input (input environment &rest args) + (funcall #'connection-run + *connection* + (if (cdr args) (uiop:escape-sh-command args) args) + input + environment)) + +(defun runlines (&rest args) + (unlines (apply #'run args))) + +(defun runlines-with-input (&rest args) + (unlines (apply #'run-with-input args))) + +(defun readfile (&rest args) + (apply #'connection-readfile *connection* args)) + +(defun writefile (&rest args) + (apply #'connection-writefile *connection* args)) + + +;;;; Properties + +;; Properties are not stored as CLOS objects (or structs) in value cells +;; because they are immutable -- see "Attempting to work with anonymous +;; properties or connection types" in the docs. An alternative would be to +;; use the function cell to store a function which takes +;; 'apply/'hostattrs/etc. as its first argument and dispatches, but those +;; could be flet, which is forbidden. A determined user could of course edit +;; the symbol plist entries, but we want to make it difficult for someone who +;; hasn't read the docs to accidentally violate immutability + +(defun setprop (sym type &key args desc hostattrs check apply unapply) + ;; use non-keyword keys to avoid clashes with other packages + (when type + (setf (get sym 'type) type)) + (when desc + (setf (get sym 'desc) desc)) + (when hostattrs + (setf (get sym 'hostattrs) hostattrs)) + (when check + (setf (get sym 'check) check)) + (when apply + (setf (get sym 'apply) apply)) + (when unapply + (setf (get sym 'unapply) unapply)) + sym) + +(defun proptype (prop) + (get prop 'type)) + +(defun propapptype (propapp) + (get (car propapp) 'type)) + +(defun collapse-types (&rest lists) + (if (some (lambda (type) (eq type :posix)) + (flatten lists)) + :posix + :lisp)) + +(defun propdesc (prop) + (get prop 'desc)) + +(defun propargs (prop) + (get prop 'args)) + +(defun propattrs (prop &rest args) + (apply (get prop 'hostattrs (lambda (&rest args) + (declare (ignore args)) + (values))) + args)) + +(defun propappattrs (propapp) + (apply #'propattrs (car propapp) (cdr propapp))) + +(defun propcheck (prop &rest args) + (apply (get prop 'check (lambda (&rest args) + (declare (ignore args)) + (values))) + args)) + +(defun propappcheck (propapp) + (apply #'propcheck (car propapp) (cdr propapp))) + +(defun propapply (prop &rest args) + (apply (get prop 'apply (lambda (&rest args) + (declare (ignore args)) + (values))) + args)) + +(defun propappapply (propapp) + (apply #'propapply (car propapp) (cdr propapp))) + +(defun propunapply (prop &rest args) + (apply (get prop 'unapply (lambda (&rest args) + (declare (ignore args)) + (values))) + args)) + +(defun propappunapply (propapp) + (apply #'propunapply (car propapp) (cdr propapp))) + +;;; standard way to write properties is to use one of these two macros + +;; TODO when forms is not (:apply etc.) but just code, we could just consider +;; that all to be :apply, and leave :hostattrs, :check and :unapply blank? +;; TODO :push-hostattrs to specify a function which does not look at +;; *hostattrs* and just returns a list which gets added to the front (we will +;; wrap (push ... *hostattrs*) around the return value, basically) +(defmacro defprop (name type args &body forms) + (let ((slots (list :args args))) + (when (stringp (car forms)) + (setf (getf slots :desc) (pop forms))) + (loop for form in forms + if (keywordp (car form)) + do (setf (getf slots (car form)) (cdr form))) + (loop for kw in '(:hostattrs :check :apply :unapply) + do (if-let ((slot (getf slots kw))) + (setf (getf slots kw) + ;; inside this lambda we could do some checking of, e.g., + ;; whether we are :lisp but this connection is + ;; posix-connection. possibly a condition with a restart + ;; which allows skipping over this property + `(lambda ,args ,@slot)))) + `(setprop ',name ,type ,@slots))) + +(defmacro defproplist (name args &body propspec) + "Define a property which applies a property application specification.") + + +;;;; Property application specifications + +(defvar *consfig* nil + "A list of names of the ASDF systems in which you define your hosts, +site-specific properties and deployments. These systems should depend on the +\"consfigurator\" system. + +More specifically, in normal usage of Consfigurator, calling +(mapc #'asdf:require-system *consfig*) should be sufficient to define all the +properties you intend to apply to hosts. + +Use the SETCONSFIG macro at the top of your consfig to set this value. + +Note that you can use Consfigurator without setting this variable, by +explicitly specifying the names of systems when creating property application +specifications. This is useful if you have more than one consfig that you +want to keep completely independent of each other.") + +(defmacro setconsfig (systems) + "Set the value of *consfig*. SYSTEMS can be a name or a list of names." + (when (atom systems) + (setq systems (list systems))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setq *consfig* ',systems))) + +(defclass propspec () + ((systems + :initarg :systems + :documentation "List of names of systems, the loading of all of which is +sufficient to deploy this propspec.") + (applications + :initarg :props + :documentation "Ordered list of property applications. +The base case valid entry is of the form (PROPERTY . ARGS) where PROPERTY is +a symbol naming a property (typically as defined by DEFPROP) and ARGS is a +list of arguments to be passed when calling the property's subroutines. These +ARGS will not be evaluated before calling the function. + +Additionally, entries can be of the following forms: + + (unapply (PROPERTY . ARGS)) -- unapply the property, if it supports that. + + ((PROPERTY . ARGS) onchange (PROPERTY . ARGS) onchange (PROPERTY . ARGS)) + -- apply the second and third properties in the case that the first + property actually had work to do. + +... and combinations thereof. + +Deployments apply properties in the order specified here, so later entries in +the list implicitly depend on earlier ones. + +Members of ARGS must all be objects which can be serialised. In particular, +function objects are not permitted.")) + (:documentation + "The point of this data structure is to be a way to inform a Lisp process +running on a remote host how it can apply some properties: load each of the +systems, resolve unapply, onchange etc., and then look in the value cell of +each PROPERTY to find a property, and pass each of ARGS to the function in the +property's apply slot.")) + +;; The following four functions, plus simple concatenation, should be +;; everything we need to do with propspecs, so all knowledge of the possible +;; combinator symbols should be confined to these four functions -- i.e., if +;; we are to add any combinators, this is the code that needs to change + +(defun compile-propapp (propapp) + "Recursively apply the effects of property combinators in PROPAPP to produce +an atomic property application." + (let ((sym (gensym))) + (cond + ;; UNAPPLY + ((symbol-named unapply (car propapp)) + (destructuring-bind (psym . args) (compile-propapp (cadr propapp)) + (setprop sym (proptype psym) + :desc (concat "Unapply: " (propdesc psym)) + :check (complement (get psym 'check)) + :apply (get psym 'unapply) + :unapply (get psym 'apply)) + (cons sym args))) + ;; ON-CHANGE + ;; Following pretty much assumes that on-change is our only infix + ;; property combinator. + ((symbol-named on-change (cadr propapp)) + (let ((propapps (loop with remaining = (cdr propapp) + with apps + for s = (pop remaining) + for a = (pop remaining) + unless (symbol-named on-change s) + do (error "Invalid on-change expression") + else + do (push (compile-propapp a) apps) + unless remaining return apps))) + (destructuring-bind (psym . args) (compile-propapp (car propapp)) + (setprop sym (collapse-types (proptype psym) + (mapcar #'propapptype propapps)) + :desc (propdesc psym) + :hostattrs (lambda (&rest args) + (nconc (apply #'propattrs psym args) + (mapcan #'propappattrs propapps))) + :check (get psym 'check) + :apply (lambda (&rest args) + (unless (eq :nochange + (apply #'propapply psym args)) + (loop for propapp in propapps + do (unless (propappcheck propapp) + (propappapply propapp))))) + :unapply (lambda (&rest args) + (unless (eq :nochange + (apply #'propunapply psym args)) + (loop for propapp in propapps + do (unless (propappcheck propapp) + (propappapply propapp)))))) + (cons sym args)))) + ;; atomic property application + (t + propapp)))) + +(defun eval-propspec (propspec) + "Apply properties as specified by PROPSPEC." + (mapc #'asdf:require-system (slot-value propspec 'systems)) + (loop for form in (slot-value propspec 'applications) + for propapp = (compile-propapp form) + unless (propappcheck propapp) + do (propappapply propapp))) + +(defun propspec->hostattrs (propspec) + "Return all the hostattrs which should be applied to the host which has +PROPSPEC applied." + (loop with *hostattrs* + for form in (slot-value propspec 'applications) + for propapp = (compile-propapp form) + do (propappattrs propapp) + finally (return *hostattrs*))) + +(defun propspec->type (propspec) + "Return :lisp if any types of the properties to be applied by PROPSPEC is +:lisp, else return :posix." + (loop for form in (slot-value propspec 'applications) + for propapp = (compile-propapp form) + if (eq (propapptype propapp) :lisp) + return :lisp + finally (return :posix))) + +(defun props (forms &optional systems) + "Where FORMS is the elements of an unevaluated property application +specification, return code which will evaluate the expressions and produce the +corresponding property application specification. + +SYSTEMS is the 'systems attribute of the property application specification +that the returned code should produce. + +Intended for use by macros which allow the user to provide expressions instead +of values as the arguments to properties when building a property application +specification." + (if systems + (when (atom systems) + (setq systems (list systems))) + ;; TODO maybe setconsfig could set *consfig* just within the current + ;; package and then macros bind it or pass it to this function. then no + ;; global value, i.e. drop that piece of state. + (if *consfig* + (setq systems (list *consfig*)) + (error "*consfig* not set"))) + (labels ((make-eval-propspec (form) + (if (atom form) + `(quote ,form) + (destructuring-bind (first . rest) form + (if (and (symbolp first) + (not (member (symbol-name first) + '("UNAPPLY") + :test #'string=))) + `(list ',first ,@rest) + `(list ,@(mapcar #'make-eval-propspec form))))))) + `(make-instance + 'propspec + :systems ',systems + :props (list ,@(mapcar #'make-eval-propspec forms))))) + +;;; property :hostattrs subroutines + +(defvar *hostattrs* nil + "Used by property :hostattrs subroutines, only, to access and modify the +current static informational attributes, and to add new ones.") + +(defun add-hostattr (k v) + (push *hostattrs* v) + (push *hostattrs* k)) + +(defun require-data (iden1 iden2) + (push (getf *hostattrs* :data) (cons iden1 iden2))) + + +;;;; Hosts + +(defclass host () + ((hostattrs + :initarg :attrs + :documentation "Plist of the host's static informational attributes.") + (propspec + :initarg :props + :documentation "Property application specification of the properties to +be applied to the host."))) + +(defun hostattr (host key) + "Retrieve a single static informational attribute." + (getf (slot-value host 'hostattrs) key)) + +(defmacro defhost (hostname &body properties) + "Define a host with hostname HOSTNAME and properties PROPERTIES. +HOSTNAME can be a string or a symbol. In either case, the host will get a +static informational property with its hostname as a string, and the symbol +whose name is the hostname will be bound to the host object. + +If the first entry in PROPERTIES is a string, it will be considered a +human-readable description of the host. Otherwise, PROPERTIES is an +unevaluated property application specification. Recall that for atomic +entries (PROPERTY . ARGS), PROPERTY refers to the property that symbol names +in the global environment, not whatever it may name in the current dynamic +and/or lexical environments. Property application specifications cannot +close over globally anonymous properties. + +The order of PROPERTIES matters: deployments will apply properties to the host +in the order specified here, so later properties implicitly depend on earlier +ones. In addition, static informational attributes set by later properties +are allowed to override any attributes with the same name set by earlier +entries." + (let (hostname-sym hostattrs) + (etypecase hostname + (string (setq hostname-sym (intern hostname))) + (symbol (setq hostname-sym hostname + hostname (string-downcase (symbol-name hostname))))) + (setf (getf hostattrs :hostname) hostname) + (when (stringp (car properties)) + (setf (getf hostattrs :desc) (pop properties))) + `(progn + (declaim (type host ,hostname-sym)) + (defparameter ,hostname-sym + (let* ((propspec ,(props properties)) + (hostattrs (nconc (propspec->hostattrs propspec) + ',hostattrs))) + (make-instance 'host :attrs hostattrs :props propspec)) + ,(getf hostattrs :desc))))) + + +;;;; Deployments + +(defmacro defdeploy (name (connection host) &body additional-properties) + "Define a function which does (DEPLOY CONNECTION HOST ADDITIONAL-PROPERTIES). +You can then eval (NAME) to execute this deployment." + `(defun ,name () + (deploy ,connection ,host ,@additional-properties))) + +(defmacro defdeploy-these (name (connection host) &body properties) + "Define a function which does (DEPLOY-THESE CONNECTION HOST PROPERTIES). +You can then eval (NAME) to execute this deployment." + `(defun ,name () + (deploy-these ,connection ,host ,@properties))) + +(defmacro defhostdeploy (connection host-name) + "Where HOST-NAME names a host as defined with DEFHOST, define a function +which does (deploy CONNECTION (symbol-value HOST)). +You can then eval (HOST-NAME) to execute this deployment. + +For example, if you usually deploy properties to athena by SSH, + + (defhost athena.silentflame.com + (foo) + (bar) + ...) + + (defhostdeploy :ssh athena.silentflame.com) + +and then you can eval (athena.silentflame.com) to apply athena's properties." + `(defdeploy ,host-name (,connection ,host-name))) + +(defmacro deploy (connection host &body additional-properties) + "Establish a connection of type CONNECTION to HOST, and apply each of the +host's usual properties, followed by specified by ADDITIONAL-PROPERTIES, an +unevaluated property application specification. + +CONNECTION is either a keyword identifying a connection type, or a list +beginning with such a keyword and followed by keyword arguments required to +establish the connection. + +Then HOST has all its usual static informational attributes, plus any set by +ADDITIONAL-PROPERTIES. Static informational attributes set by +ADDITIONAL-PROPERTIES can override the host's usual static informational +attributes, in the same way that later entries in the list of properties +specified in DEFHOST forms can override earlier entries (see DEFHOST's +docstring)." + (once-only (host) + (with-gensyms (propspec) + `(let ((,propspec ,(props additional-properties))) + (deploy* ,connection + (make-instance 'host + :attrs (nconc (propspec->hostattrs ,propspec) + (slot-value ,host 'hostattrs)) + :props (append (slot-value ,host 'propspec) + ,propspec))))))) + +(defmacro deploy-these (connection host &body properties) + "Establish a connection of type CONNECTION to HOST, and apply each of +the properties specified by PROPERTIES, an unevaluated property application +specification (and not the host's usual properties, unless they also appear +in PROPERTIES). + +CONNECTION is either a keyword identifying a connection type, or a list +beginning with such a keyword and followed by keyword arguments required to +establish the connection. + +This function is useful to apply one or two properties to a host right now, +e.g. at the REPL when when testing new property definitions. If HOST is +usually deployed using a :lisp connection, and the property you are testing +is :posix, you might use a connection type like :ssh so that you can quickly +alternate between redefining your work-in-progress property and attempting to +apply it to HOST. + +HOST has all its usual static informational attributes, as set by its usual +properties, plus any set by PROPERTIES. Static informational attributes set +by PROPERTIES can override the host's usual static informational attributes, +in the same way that later entries in the list of properties specified in +DEFHOST forms can override earlier entries (see DEFHOST's docstring)." + (with-gensyms (propspec) + `(let ((,propspec ,(props properties))) + (deploy* ,connection + (make-instance 'host + :attrs (nconc (propspec->hostattrs ,propspec) + (slot-value ,host 'hostattrs)) + :props ,propspec))))) + +(defun deploy* (connections host) + (let ((*host* host)) + (labels + ((connect (connections) + (destructuring-bind ((type . args) . remaining) connections + (when-let ((*connection* + (apply #'establish-connection type remaining args))) + (if remaining + (connect remaining) + (apply-propspec (slot-value *host* 'propspec))) + (connection-teardown *connection*)))) + (apply-propspec (propspec) + (when (and (subtypep (class-of *connection*) 'posix-connection) + (eq :lisp (propspec->type propspec))) + (error "Cannot apply :lisp properties using :posix connection")) + (eval-propspec propspec))) + (connect (loop for connection in (ensure-cons connections) + collect (ensure-cons connection)))))) + +(defprop deploy :posix (connection host &rest additional-properties) + "Execute a Consfigurator deployment. + +Useful to have one host act a controller, applying properties to other hosts. +Also useful to set up VMs, chroots, disk images etc. on localhost.") + +(defprop deploy-these :posix (connection host &rest properties) + "Execute a deployment, but replace the properties of host with PROPERTIES. +This property is to the DEPLOY property what the DEPLOY-THESE function is to +the DEPLOY function.") + + +;;;; Prerequisite data + +(defvar *data-sources* nil "Known sources of prerequisite data.") + +(defun add-data-source (check provide) + (push (cons check provide) *data-sources*)) + +;; if this proves to be inadequate then an alternative would be to maintain a +;; mapping of ASDF systems to data sources, and then APPLY-PROPERTIES could +;; look up the data sources registered for the systems in (slot-value +;; (slot-value host 'propspec) 'systems) and bind *data-sources* to point to +;; those just how it binds *host* and *connection*. registering a source +;; means registering it in the mapping of systems to sources +(defgeneric register-data-source (type &key) + (:documentation + "Initialise and register a source of prerequisite data in this Lisp process. +Registered data sources are available to all deployments executed from the +root Lisp, regardless of the consfig which defines the host to which +properties are to be applied. (This could only cause problems if you have +different consfigs with prerequisite data which is identified by the same two +strings, in which case you will need to wrap your deployments with registering +and unregistering data sources. Usually items of prerequisite data are +identified using things like hostnames, so this is unlikely to be necessary.) + +Implementation of this function call ADD-DATA-SOURCE, providing two functions. + +Signals a condition MISSING-DATA-SOURCE when unable to access the data source +(e.g. because can't decrypt it). This condition is captured and ignored in +all Lisp processes started up by Consfigurator, since prerequisite data +sources are not expected to be available outside of the root Lisp.")) + +(defprop data-uploaded (iden1 iden2 &optional destination) + ;; calls get-data + ) + +(defprop host-data-uploaded :posix (destination) + (:apply (propapply 'data-uploaded + (hostattr *host* :hostname) + destination + destination))) + +(defun get-data (iden1 iden2) + (if-let ((source-thunk (cdr (query-data-sources iden1 iden2)))) + (funcall source-thunk) + ;; now look in local cache -- note that this won't exist in the root Lisp, + ;; but only if we're a Lisp started up by a connection + + )) + +(defun query-data-sources (iden1 iden2) + (car (sort (loop for (ver . get) in *data-sources* + when (funcall ver iden1 iden2) + collect (cons it (lambda () + (funcall get iden1 iden2)))) + (compose #'version> #'car)))) + +;; called by implementations of ESTABLISH-CONNECTION which start up remote +;; Lisp processes +(defun upload-all-prerequisite-data (host) + (loop with *data-sources* + initially (register-data-source :asdf) + + with sorted-local-cache = (sort (get-local-cached-prerequisite-data) + (compose #'version> #'third)) + with sorted-remote-cache = (sort (get-remote-cached-prerequisite-data) + (compose #'version> #'third)) + + for (iden1 . iden2) in (getf (slot-value host :hostattrs) :data) + for highest-local-cached-version + = (third (car (remove-if-not (lambda (c) + (and (string= (first c) iden1) + (string= (second c) iden2))) + sorted-local-cache))) + for highest-remote-cached-version + = (third (car (remove-if-not (lambda (c) + (and (string= (first c) iden1) + (string= (second c) iden2))) + sorted-remote-cache))) + for (highest-source-version . highest-source) + = (query-data-sources iden1 iden2) + + if (and highest-source-version + (or (not highest-remote-cached-version) + (version< highest-remote-cached-version + highest-source-version))) + do (connection-clear-data-cache iden1 iden2) + (connection-upload-data iden1 + iden2 + highest-source-version + (funcall highest-source)) + else if (and highest-local-cached-version + (or (not highest-remote-cached-version) + (version< highest-remote-cached-version + highest-local-cached-version))) + do (connection-clear-data-cache iden1 iden2) + (connection-upload-data + iden1 + iden2 + highest-local-cached-version + (list :file + (local-data-pathname iden1 + iden2 + highest-local-cached-version))) + else if (not highest-remote-cached-version) + do (error "Could not provide prerequisite data ~S | ~S" + iden1 iden2))) + +(defun local-data-pathname (&rest segments) + (reduce #'merge-pathnames (nreverse (mapcar #'string->filename segments)) + :from-end t :initial-value (get-local-data-cache-dir))) + +(defun remote-data-pathname (&rest segments) + (reduce #'merge-pathnames (nreverse (mapcar #'string->filename segments)) + :from-end t :initial-value (get-remote-data-cache-dir))) + +(defun connection-upload-data (iden1 iden2 version data) + (let* ((dest (remote-data-pathname iden1 iden2 version))) + (run "mkdir" "-p" (uiop:unix-namestring + (uiop:pathname-directory-pathname dest))) + (cond + ((getf data :file) + ;; TODO if (string-prefix-p "text/" (getf data :mime)) then gzip, + ;; upload and gunzip + (connection-upload *connection* + (uiop:unix-namestring (getf data :file)) + dest)) + ((getf data :data) + (connection-writefile *connection* dest (getf data :data))) + (t + (error "Prerequisite data plist lacks both :file and :data entries"))))) + +(defun connection-clear-data-cache (iden1 iden2) + (let ((dir (uiop:ensure-directory-pathname + (remote-data-pathname iden1 iden2)))) + (run "rm" "-f" (strcat (uiop:unix-namestring + (uiop:pathname-directory-pathname dir)) + "/*")))) + +(defun get-local-data-cache-dir () + (uiop:ensure-pathname-directory + (strcat (or (uiop:getenv "XDG_CACHE_HOME") + (strcat (uiop:getenv "HOME") "/.cache")) + "/consfigurator/data"))) + +(defun get-local-cached-prerequisite-data () + "Return a list of items of prerequisite data in the cache local to this Lisp +process, where each entry is of the form + + '(iden1 iden2 version)." + (loop for dir in (uiop:subdirectories (get-local-data-cache-dir)) + nconc (loop for subdir in (uiop:subdirectories dir) + nconc (loop for file in (uiop:directory-files subdir) + collect (mapcar #'filename->string + (list dir subdir file)))))) + +(defun get-remote-data-cache-dir () + (uiop:ensure-pathname-directory + (car + (runlines "echo" "${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/data/")))) + +(defun get-remote-cached-prerequisite-data () + "Return a list of items of prerequisite data in the cache on the remote side +of the current connection, where each entry is of the form + + '(iden1 iden2 version)." + (mapcar (lambda (line) + (mapcar #'filename->string (split-string line :separator "/"))) + (runlines "find" (get-remote-data-cache-dir) + "-type" "f" "-printf" "%P\\n"))) diff --git a/src/data/asdf.lisp b/src/data/asdf.lisp new file mode 100644 index 0000000..bca2346 --- /dev/null +++ b/src/data/asdf.lisp @@ -0,0 +1,25 @@ +(in-package :consfigurator.data.asdf) + +(defmethod register-data-source ((type (eql :asdf)) &key) + (add-data-source #'asdf-data-source-check #'get-path-to-concatenated-system)) + +(defun asdf-data-source-check (iden1 system) + (and (string= iden1 "lisp-system") + (asdf:find-system system nil))) + +(Defun get-path-to-concatenated-system (iden1 system) + "Try to concatenate all the source code for SYSTEM, store it somewhere and +return the filename." + (let ((cache-dir (uiop:ensure-pathname-directory + (strcat (or (uiop:getenv "XDG_CACHE_HOME") + (strcat (uiop:getenv "HOME") "/.cache")) + "/consfigurator/systems"))) + (op 'asdf:monolithic-concatenate-source-op) + (co (asdf:find-component system nil))) + (ensure-directories-exist cache-dir) + (asdf:initialize-output-translations `(:output-translations + (t ,cache-dir) + :disable-cache + :ignore-inherited-configuration)) + (asdf:operate op co) + (list :file (asdf:output-file op co)))) diff --git a/src/data/pgp.lisp b/src/data/pgp.lisp new file mode 100644 index 0000000..c5affa5 --- /dev/null +++ b/src/data/pgp.lisp @@ -0,0 +1,8 @@ +(in-package :consfigurator.data.pgp) + +;;;; Simple PGP-encrypted file source of prerequisite data + +;; We provide an implementation of REGISTER-DATA-SOURCE and functions for the +;; user to call at the REPL to add pieces of data, see what's there, etc. (a +;; prerequisite data source which was some sort of external file-generating or +;; secrets storage database might not provide any functions for the REPL). diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..3ffae1b --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,91 @@ +(in-package :cl-user) + +(defpackage :consfigurator.util + (:use #:cl) + (:shadowing-import-from #:uiop + #:strcat + #:string-prefix-p) + (:export #:strcat + #:string-prefix-p + + #:lines + #:unlines + #:noop + #:symbol-named + + #:version< + #:version> + #:version<= + #:version>= + + #:string->filename + #:filename->string)) + +(defpackage :consfigurator.core + (:use #:cl + #:alexandria + #:consfigurator.util) + (:export #:connect-and-apply + #:apply-properties + #:connection + #:lisp-connection + #:posix-connection + #:connection-run + #:run + #:run-with-input + #:runlines + #:runlines-with-input + #:connection-readfile + #:readfile + #:connection-writefile + #:writefile + #:connection-upload + #:connection-teardown + #:*host* + #:*hostattrs* + #:add-hostattr + #:require-data + #:establish-connection + #:defprop + #:defhost + #:hostattr + #:setconsfig + #:defdeploy + #:defdeploy-these + #:defhostdeploy + #:deploy + #:deploy-these + #:add-data-source + #:register-data-source + #:data-uploaded + #:host-data-uploaded + #:get-data + #:upload-all-prerequisite-data)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package :consfigurator) + (make-package :consfigurator :use '(cl)))) + +(defpackage :consfigurator.connection.ssh + (:use #:cl #:consfigurator)) + +(defpackage :consfigurator.property.file + (:use #:cl #:consfigurator) + (:export #:file-has-content + #:file-contains-lines)) + +(defpackage :consfigurator.property.command + (:use #:cl #:consfigurator) + (:export #:shell-command)) + +(defpackage :consfigurator.data.asdf + (:use #:cl #:consfigurator)) + +(defpackage :consfigurator.data.pgp + (:use #:cl #:consfigurator)) + +(in-package :consfigurator) +(dolist (package '(:consfigurator.core :consfigurator.util)) + (use-package package) + (do-external-symbols (sym package) + (export sym))) diff --git a/src/property/command.lisp b/src/property/command.lisp new file mode 100644 index 0000000..a040968 --- /dev/null +++ b/src/property/command.lisp @@ -0,0 +1,15 @@ +(in-package :consfigurator.property.command) + +(defprop shell-command :posix (cmd args &key environment) + "A property which can be applied by running a shell command. + +Keyword argument :environment is a plist of environment variables to be set +when running the command, using env(1)." + (:apply (when environment + (let ((env (cons "env" + (loop for (var . val) in environment + collect (concat (symbol-name var) + "=" + val))))) + (setq args (nconc env args)))) + (connection-run (apply #'shellcmd cmd args)))) diff --git a/src/property/file.lisp b/src/property/file.lisp new file mode 100644 index 0000000..91ab379 --- /dev/null +++ b/src/property/file.lisp @@ -0,0 +1,14 @@ +(in-package :consfigurator.property.file) + +(defprop file-has-content :posix (path lines) + "Ensure there is a file at PATH whose lines are the elements of LINES." + (:apply (connection-writefile path (unlines lines)))) + +(defprop file-contains-lines :posix (path lines) + "Ensure there is a file at PATH containing each of LINES." + (:apply (let ((new-lines (copy-list lines)) + (existing-lines (lines (connection-readfile path)))) + (loop for existing-line in existing-lines + do (setq new-lines (delete existing-line new-lines))) + (connection-writefile path (unlines + (nconc existing-lines new-lines)))))) diff --git a/src/util.lisp b/src/util.lisp new file mode 100644 index 0000000..6378d02 --- /dev/null +++ b/src/util.lisp @@ -0,0 +1,77 @@ +(in-package :consfigurator.util) + +(defun noop (&rest args) + "Accept any arguments and do nothing." + (declare (ignore args)) + (values)) + +(defun lines (text) + (uiop:split-string (uiop:stripln text) :separator '(#\Newline))) + +(defun unlines (lines) + (format nil "~{~A~%~}" lines)) + +(defmacro symbol-named (name symbol) + `(and (symbolp ,symbol) + (string= (symbol-name ',name) (symbol-name ,symbol)))) + +(defun version< (x y) + (dpkg-version-compare x "<<" y)) + +(defun version> (x y) + (dpkg-version-compare x ">>" y)) + +(defun version<= (x y) + (dpkg-version-compare x "<=" y)) + +(defun version>= (x y) + (dpkg-version-compare x ">=" y)) + +(defun dpkg-version-compare (x r y) + (= 0 (nth-value 2 (uiop:run-program (list "dpkg" "--compare-versions" x r y) + :ignore-error-status 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->filename (s) + (apply #'concatenate 'string + (loop for c across 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->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 (cons #\# (cons #\x (nreverse buffer))) + 'string))) + result) + (setq buffer nil + decoding nil)) + (decoding + (push c buffer)) + (t + (push c result))) + finally (return (coerce (nreverse result) 'string)))) diff --git a/util.lisp b/util.lisp deleted file mode 100644 index 6378d02..0000000 --- a/util.lisp +++ /dev/null @@ -1,77 +0,0 @@ -(in-package :consfigurator.util) - -(defun noop (&rest args) - "Accept any arguments and do nothing." - (declare (ignore args)) - (values)) - -(defun lines (text) - (uiop:split-string (uiop:stripln text) :separator '(#\Newline))) - -(defun unlines (lines) - (format nil "~{~A~%~}" lines)) - -(defmacro symbol-named (name symbol) - `(and (symbolp ,symbol) - (string= (symbol-name ',name) (symbol-name ,symbol)))) - -(defun version< (x y) - (dpkg-version-compare x "<<" y)) - -(defun version> (x y) - (dpkg-version-compare x ">>" y)) - -(defun version<= (x y) - (dpkg-version-compare x "<=" y)) - -(defun version>= (x y) - (dpkg-version-compare x ">=" y)) - -(defun dpkg-version-compare (x r y) - (= 0 (nth-value 2 (uiop:run-program (list "dpkg" "--compare-versions" x r y) - :ignore-error-status 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->filename (s) - (apply #'concatenate 'string - (loop for c across 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->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 (cons #\# (cons #\x (nreverse buffer))) - 'string))) - result) - (setq buffer nil - decoding nil)) - (decoding - (push c buffer)) - (t - (push c result))) - finally (return (coerce (nreverse result) 'string)))) -- cgit v1.2.3