tconfiguration.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tconfiguration.lisp (21324B)
---
1 ;;;; ---------------------------------------------------------------------------
2 ;;;; Generic support for configuration files
3
4 (uiop/package:define-package :uiop/configuration
5 (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27.
6 (:use :uiop/common-lisp :uiop/utility
7 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
8 (:export
9 #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
10 #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
11 #:get-folder-path
12 #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
13 #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
14 #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames
15 #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname
16 #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
17 #:configuration-inheritance-directive-p
18 #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
19 #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
20 #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
21 #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
22 (in-package :uiop/configuration)
23
24 (with-upgradability ()
25 (define-condition invalid-configuration ()
26 ((form :reader condition-form :initarg :form)
27 (location :reader condition-location :initarg :location)
28 (format :reader condition-format :initarg :format)
29 (arguments :reader condition-arguments :initarg :arguments :initform nil))
30 (:report (lambda (c s)
31 (format s (compatfmt "~@<~? (will be skipped)~@:>")
32 (condition-format c)
33 (list* (condition-form c) (condition-location c)
34 (condition-arguments c))))))
35
36 (defun configuration-inheritance-directive-p (x)
37 "Is X a configuration inheritance directive?"
38 (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
39 (or (member x kw)
40 (and (length=n-p x 1) (member (car x) kw)))))
41
42 (defun report-invalid-form (reporter &rest args)
43 "Report an invalid form according to REPORTER and various ARGS"
44 (etypecase reporter
45 (null
46 (apply 'error 'invalid-configuration args))
47 (function
48 (apply reporter args))
49 ((or symbol string)
50 (apply 'error reporter args))
51 (cons
52 (apply 'apply (append reporter args)))))
53
54 (defvar *ignored-configuration-form* nil
55 "Have configuration forms been ignored while parsing the configuration?")
56
57 (defun validate-configuration-form (form tag directive-validator
58 &key location invalid-form-reporter)
59 "Validate a configuration FORM. By default it will raise an error if the
60 FORM is not valid. Otherwise it will return the validated form.
61 Arguments control the behavior:
62 The configuration FORM should be of the form (TAG . <rest>)
63 Each element of <rest> will be checked by first seeing if it's a configuration inheritance
64 directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
65 on it.
66 In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
67 reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
68 the configuration form appeared."
69 (unless (and (consp form) (eq (car form) tag))
70 (setf *ignored-configuration-form* t)
71 (report-invalid-form invalid-form-reporter :form form :location location)
72 (return-from validate-configuration-form nil))
73 (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
74 :for directive :in (cdr form)
75 :when (cond
76 ((configuration-inheritance-directive-p directive)
77 (incf inherit) t)
78 ((eq directive :ignore-invalid-entries)
79 (setf ignore-invalid-p t) t)
80 ((funcall directive-validator directive)
81 t)
82 (ignore-invalid-p
83 nil)
84 (t
85 (setf *ignored-configuration-form* t)
86 (report-invalid-form invalid-form-reporter :form directive :location location)
87 nil))
88 :do (push directive x)
89 :finally
90 (unless (= inherit 1)
91 (report-invalid-form invalid-form-reporter
92 :form form :location location
93 ;; we throw away the form and location arguments, hence the ~2*
94 ;; this is necessary because of the report in INVALID-CONFIGURATION
95 :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
96 One and only one of ~S or ~S is required.~@:>")
97 :arguments '(:inherit-configuration :ignore-inherited-configuration)))
98 (return (nreverse x))))
99
100 (defun validate-configuration-file (file validator &key description)
101 "Validate a configuration FILE. The configuration file should have only one s-expression
102 in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error
103 reporting."
104 (let ((forms (read-file-forms file)))
105 (unless (length=n-p forms 1)
106 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
107 description forms))
108 (funcall validator (car forms) :location file)))
109
110 (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter)
111 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
112 be applied to the results to yield a configuration form. Current
113 values of TAG include :source-registry and :output-translations."
114 (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
115 (remove-if
116 'hidden-pathname-p
117 (directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
118 #'string< :key #'namestring)))
119 `(,tag
120 ,@(loop :for file :in files :append
121 (loop :with ignore-invalid-p = nil
122 :for form :in (read-file-forms file)
123 :when (eq form :ignore-invalid-entries)
124 :do (setf ignore-invalid-p t)
125 :else
126 :when (funcall validator form)
127 :collect form
128 :else
129 :when ignore-invalid-p
130 :do (setf *ignored-configuration-form* t)
131 :else
132 :do (report-invalid-form invalid-form-reporter :form form :location file)))
133 :inherit-configuration)))
134
135 (defun resolve-relative-location (x &key ensure-directory wilden)
136 "Given a designator X for an relative location, resolve it to a pathname."
137 (ensure-pathname
138 (etypecase x
139 (null nil)
140 (pathname x)
141 (string (parse-unix-namestring
142 x :ensure-directory ensure-directory))
143 (cons
144 (if (null (cdr x))
145 (resolve-relative-location
146 (car x) :ensure-directory ensure-directory :wilden wilden)
147 (let* ((car (resolve-relative-location
148 (car x) :ensure-directory t :wilden nil)))
149 (merge-pathnames*
150 (resolve-relative-location
151 (cdr x) :ensure-directory ensure-directory :wilden wilden)
152 car))))
153 ((eql :*/) *wild-directory*)
154 ((eql :**/) *wild-inferiors*)
155 ((eql :*.*.*) *wild-file*)
156 ((eql :implementation)
157 (parse-unix-namestring
158 (implementation-identifier) :ensure-directory t))
159 ((eql :implementation-type)
160 (parse-unix-namestring
161 (string-downcase (implementation-type)) :ensure-directory t))
162 ((eql :hostname)
163 (parse-unix-namestring (hostname) :ensure-directory t)))
164 :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
165 :want-relative t))
166
167 (defvar *here-directory* nil
168 "This special variable is bound to the currect directory during calls to
169 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
170 directive.")
171
172 (defvar *user-cache* nil
173 "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
174
175 (defun resolve-absolute-location (x &key ensure-directory wilden)
176 "Given a designator X for an absolute location, resolve it to a pathname"
177 (ensure-pathname
178 (etypecase x
179 (null nil)
180 (pathname x)
181 (string
182 (let ((p #-mcl (parse-namestring x)
183 #+mcl (probe-posix x)))
184 #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
185 (if ensure-directory (ensure-directory-pathname p) p)))
186 (cons
187 (return-from resolve-absolute-location
188 (if (null (cdr x))
189 (resolve-absolute-location
190 (car x) :ensure-directory ensure-directory :wilden wilden)
191 (merge-pathnames*
192 (resolve-relative-location
193 (cdr x) :ensure-directory ensure-directory :wilden wilden)
194 (resolve-absolute-location
195 (car x) :ensure-directory t :wilden nil)))))
196 ((eql :root)
197 ;; special magic! we return a relative pathname,
198 ;; but what it means to the output-translations is
199 ;; "relative to the root of the source pathname's host and device".
200 (return-from resolve-absolute-location
201 (let ((p (make-pathname :directory '(:relative))))
202 (if wilden (wilden p) p))))
203 ((eql :home) (user-homedir-pathname))
204 ((eql :here) (resolve-absolute-location
205 (or *here-directory* (pathname-directory-pathname (load-pathname)))
206 :ensure-directory t :wilden nil))
207 ((eql :user-cache) (resolve-absolute-location
208 *user-cache* :ensure-directory t :wilden nil)))
209 :wilden (and wilden (not (pathnamep x)))
210 :resolve-symlinks *resolve-symlinks*
211 :want-absolute t))
212
213 ;; Try to override declaration in previous versions of ASDF.
214 (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
215 (:ensure-directory boolean)) t) resolve-location))
216
217 (defun* (resolve-location) (x &key ensure-directory wilden directory)
218 "Resolve location designator X into a PATHNAME"
219 ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
220 (loop* :with dirp = (or directory ensure-directory)
221 :with (first . rest) = (if (atom x) (list x) x)
222 :with path = (or (resolve-absolute-location
223 first :ensure-directory (and (or dirp rest) t)
224 :wilden (and wilden (null rest)))
225 (return nil))
226 :for (element . morep) :on rest
227 :for dir = (and (or morep dirp) t)
228 :for wild = (and wilden (not morep))
229 :for sub = (merge-pathnames*
230 (resolve-relative-location
231 element :ensure-directory dir :wilden wild)
232 path)
233 :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
234 :finally (return path)))
235
236 (defun location-designator-p (x)
237 "Is X a designator for a location?"
238 ;; NIL means "skip this entry", or as an output translation, same as translation input.
239 ;; T means "any input" for a translation, or as output, same as translation input.
240 (flet ((absolute-component-p (c)
241 (typep c '(or string pathname
242 (member :root :home :here :user-cache))))
243 (relative-component-p (c)
244 (typep c '(or string pathname
245 (member :*/ :**/ :*.*.* :implementation :implementation-type)))))
246 (or (typep x 'boolean)
247 (absolute-component-p x)
248 (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
249
250 (defun location-function-p (x)
251 "Is X the specification of a location function?"
252 ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
253 (and (length=n-p x 2) (eq (car x) :function)))
254
255 (defvar *clear-configuration-hook* '())
256
257 (defun register-clear-configuration-hook (hook-function &optional call-now-p)
258 "Register a function to be called when clearing configuration"
259 (register-hook-function '*clear-configuration-hook* hook-function call-now-p))
260
261 (defun clear-configuration ()
262 "Call the functions in *CLEAR-CONFIGURATION-HOOK*"
263 (call-functions *clear-configuration-hook*))
264
265 (register-image-dump-hook 'clear-configuration)
266
267 (defun upgrade-configuration ()
268 "If a previous version of ASDF failed to read some configuration, try again now."
269 (when *ignored-configuration-form*
270 (clear-configuration)
271 (setf *ignored-configuration-form* nil)))
272
273
274 (defun get-folder-path (folder)
275 "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
276 this function tries to locate the Windows FOLDER for one of
277 :LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
278 Returns NIL when the folder is not defined (e.g., not on Windows)."
279 (or #+(and lispworks os-windows) (sys:get-folder-path folder)
280 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
281 (ecase folder
282 (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
283 (subpathname* (get-folder-path :appdata) "Local")))
284 (:appdata (getenv-absolute-directory "APPDATA"))
285 (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
286 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
287
288
289 ;; Support for the XDG Base Directory Specification
290 (defun xdg-data-home (&rest more)
291 "Returns an absolute pathname for the directory containing user-specific data files.
292 MORE may contain specifications for a subpath relative to this directory: a
293 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
294 also \"Configuration DSL\"\) in the ASDF manual."
295 (resolve-absolute-location
296 `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
297 (os-cond
298 ((os-windows-p) (get-folder-path :local-appdata))
299 (t (subpathname (user-homedir-pathname) ".local/share/"))))
300 ,more)))
301
302 (defun xdg-config-home (&rest more)
303 "Returns a pathname for the directory containing user-specific configuration files.
304 MORE may contain specifications for a subpath relative to this directory: a
305 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
306 also \"Configuration DSL\"\) in the ASDF manual."
307 (resolve-absolute-location
308 `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
309 (os-cond
310 ((os-windows-p) (xdg-data-home "config/"))
311 (t (subpathname (user-homedir-pathname) ".config/"))))
312 ,more)))
313
314 (defun xdg-data-dirs (&rest more)
315 "The preference-ordered set of additional paths to search for data files.
316 Returns a list of absolute directory pathnames.
317 MORE may contain specifications for a subpath relative to these directories: a
318 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
319 also \"Configuration DSL\"\) in the ASDF manual."
320 (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
321 (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS"))
322 (os-cond
323 ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
324 (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
325
326 (defun xdg-config-dirs (&rest more)
327 "The preference-ordered set of additional base paths to search for configuration files.
328 Returns a list of absolute directory pathnames.
329 MORE may contain specifications for a subpath relative to these directories:
330 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
331 also \"Configuration DSL\"\) in the ASDF manual."
332 (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
333 (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS"))
334 (os-cond
335 ((os-windows-p) (xdg-data-dirs "config/"))
336 (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
337
338 (defun xdg-cache-home (&rest more)
339 "The base directory relative to which user specific non-essential data files should be stored.
340 Returns an absolute directory pathname.
341 MORE may contain specifications for a subpath relative to this directory: a
342 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
343 also \"Configuration DSL\"\) in the ASDF manual."
344 (resolve-absolute-location
345 `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
346 (os-cond
347 ((os-windows-p) (xdg-data-home "cache/"))
348 (t (subpathname* (user-homedir-pathname) ".cache/"))))
349 ,more)))
350
351 (defun xdg-runtime-dir (&rest more)
352 "Pathname for user-specific non-essential runtime files and other file objects,
353 such as sockets, named pipes, etc.
354 Returns an absolute directory pathname.
355 MORE may contain specifications for a subpath relative to this directory: a
356 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
357 also \"Configuration DSL\"\) in the ASDF manual."
358 ;; The XDG spec says that if not provided by the login system, the application should
359 ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
360 (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
361
362 ;;; NOTE: modified the docstring because "system user configuration
363 ;;; directories" seems self-contradictory. I'm not sure my wording is right.
364 (defun system-config-pathnames (&rest more)
365 "Return a list of directories where are stored the system's default user configuration information.
366 MORE may contain specifications for a subpath relative to these directories: a
367 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
368 also \"Configuration DSL\"\) in the ASDF manual."
369 (declare (ignorable more))
370 (os-cond
371 ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
372
373 (defun filter-pathname-set (dirs)
374 "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
375 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))
376
377 (defun xdg-data-pathnames (&rest more)
378 "Return a list of absolute pathnames for application data directories. With APP,
379 returns directory for data for that application, without APP, returns the set of directories
380 for storing all application configurations.
381 MORE may contain specifications for a subpath relative to these directories: a
382 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
383 also \"Configuration DSL\"\) in the ASDF manual."
384 (filter-pathname-set
385 `(,(xdg-data-home more)
386 ,@(xdg-data-dirs more))))
387
388 (defun xdg-config-pathnames (&rest more)
389 "Return a list of pathnames for application configuration.
390 MORE may contain specifications for a subpath relative to these directories: a
391 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
392 also \"Configuration DSL\"\) in the ASDF manual."
393 (filter-pathname-set
394 `(,(xdg-config-home more)
395 ,@(xdg-config-dirs more))))
396
397 (defun find-preferred-file (files &key (direction :input))
398 "Find first file in the list of FILES that exists (for direction :input or :probe)
399 or just the first one (for direction :output or :io).
400 Note that when we say \"file\" here, the files in question may be directories."
401 (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
402
403 (defun xdg-data-pathname (&optional more (direction :input))
404 (find-preferred-file (xdg-data-pathnames more) :direction direction))
405
406 (defun xdg-config-pathname (&optional more (direction :input))
407 (find-preferred-file (xdg-config-pathnames more) :direction direction))
408
409 (defun compute-user-cache ()
410 "Compute (and return) the location of the default user-cache for translate-output
411 objects. Side-effects for cached file location computation."
412 (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
413 (register-image-restore-hook 'compute-user-cache))