1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
;;; Consfigurator -- Lisp declarative configuration management system
;;; Copyright (C) 2020-2021 Sean Whitton <spwhitton@spwhitton.name>
;;; This file is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3, or (at your option)
;;; any later version.
;;; This file is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :consfigurator)
;;;; 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. A determined user could of
;; course edit the symbol plist entries and/or function cell, but we want to
;; make it a bit more difficult for someone who hasn't read that part of the
;; docs to accidentally violate immutability.
(defun setprop (sym type &key args desc preprocess hostattrs check apply unapply)
;; use non-keyword keys to avoid clashes with other packages
(when type
(setf (get sym 'type) type))
(when args
(setf (get sym 'args) args))
(when desc
(setf (get sym 'desc) desc))
(when preprocess
(setf (get sym 'preprocess) preprocess))
(when hostattrs
(setf (get sym 'hostattrs) hostattrs))
(when check
(setf (get sym 'check) check))
(when apply
(setf (get sym 'apply) apply)
(setf (fdefinition sym)
(if check
(lambda (&rest args)
(unless (apply check args)
(apply apply args)))
apply)))
(when unapply
(setf (get sym 'unapply) unapply))
(setf (get sym 'property) t)
sym)
(defun isprop (prop)
(and (symbolp prop) (get prop 'property nil)))
(defun proptype (prop)
(get prop 'type))
(defun proppp (prop)
(get prop 'preprocess (lambda (&rest args) args)))
(defun propapptype (propapp)
(get (car propapp) 'type))
(defun collapse-types (&rest lists)
(if (member :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 #'noop) args))
(defun propappattrs (propapp)
(apply #'propattrs propapp))
(defun propcheck (prop &rest args)
(apply (get prop 'check #'noop) args))
(defun propappcheck (propapp)
(apply #'propcheck propapp))
(defun propappapply (propapp)
(apply (symbol-function (car propapp)) (cdr propapp)))
(defun propunapply (prop &rest args)
(apply (get prop 'unapply #'noop) args))
(defun propappunapply (propapp)
(apply #'propunapply propapp))
;;; supported way to write properties is to use one of these two macros
(defmacro defprop (name type args &body forms)
(let ((slots (list :args (list 'quote 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 '(:preprocess :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 type args &body properties)
"Define a property which applies a property application specification.
PROPERTIES is an unevaluated property application specification."
(with-gensyms (propspec)
`(let ((,propspec (props ,properties)))
(defprop ,name ,type ,args
(:hostattrs
(%eval-propspec-hostattrs *host* ,propspec))
(:apply
(eval-propspec ,propspec))))))
;;;; hostattrs in property subroutines
(defun get-hostattrs (k)
"Retrieve the list of static informational attributes of type KEY.
Called by property :HOSTATTRS, :APPLY and :UNAPPLY subroutines."
(getf (slot-value *host* 'hostattrs) k))
(defun push-hostattrs (k &rest vs)
"Push new static informational attributes VS of type KEY.
Called by property :HOSTATTRS subroutines."
(dolist (v vs)
(push v (getf (slot-value *host* 'hostattrs) k))))
(defun require-data (iden1 iden2)
"Wrapper around PUSH-HOSTATTRS to indicate that a piece of prerequisite data
is needed to deploy a property.
Called by property :HOSTATTRS subroutines."
(push-hostattrs :data (cons iden1 iden2)))
(defun get-hostname ()
"Get the hostname of the host to which properties are being applied.
Called by property subroutines."
(car (get-hostattrs :hostname)))
|
