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