GopherProxy

	tconfiguration.lisp - clic - Clic is an command line interactive client for gop…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	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 upg…
	6 (:use :uiop/common-lisp :uiop/utility
	7 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :ui…
	8 (:export
	9 #:user-configuration-directories #:system-configuration-directories ;…
	10 #:in-first-directory #:in-user-configuration-directory #:in-system-co…
	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 #:validat…
	17 #:configuration-inheritance-directive-p
	18 #:report-invalid-form #:invalid-configuration #:*ignored-configuratio…
	19 #:clear-configuration-hook #:clear-configuration #:register-clear-c…
	20 #:resolve-location #:location-designator-p #:location-function-p #:*h…
	21 #:resolve-relative-location #:resolve-absolute-location #:upgrade-con…
	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 :initfor…
	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 configurati…
	56
	57 (defun validate-configuration-form (form tag directive-validator
	58 &key location invalid-form-r…
	59 "Validate a configuration FORM. By default it will raise an error if…
	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 co…
	64 directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRE…
	65 on it.
	66 In the event of an invalid form, INVALID-FORM-REPORTER will be used…
	67 reporting (see REPORT-INVALID-FORM) with LOCATION providing information …
	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 lo…
	72 (return-from validate-configuration-form nil))
	73 (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list…
	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 dire…
	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 locati…
	94 ;; this is necessary because of the …
	95 :format (compatfmt "~@<Invalid sourc…
	96 One and only one…
	97 :arguments '(:inherit-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 …
	102 in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argum…
	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:…
	107 description forms))
	108 (funcall validator (car forms) :location file)))
	109
	110 (defun validate-configuration-directory (directory tag validator &key …
	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: DIREC…
	115 (remove-if
	116 'hidden-pathname-p
	117 (directory* (make-pathname :name wild :type "…
	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…
	123 :when (eq form :ignore-invalid…
	124 :do (setf ignore-invalid-p t)
	125 :else
	126 :when (funcall validator for…
	127 :collect form
	128 :else
	129 :when ignore-invalid-p
	130 :do (setf *ignored-configu…
	131 :else
	132 :do (report-invalid-form inv…
	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 path…
	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 wilde…
	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 call…
	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…
	174
	175 (defun resolve-absolute-location (x &key ensure-directory wilden)
	176 "Given a designator X for an absolute location, resolve it to a path…
	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 wilde…
	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 devic…
	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 (…
	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 boolea…
	215 (:ensure-directory boolean)) t) resolve-l…
	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 direc…
	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)…
	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-symlink…
	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…
	239 ;; T means "any input" for a translation, or as output, same as tran…
	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 :impleme…
	246 (or (typep x 'boolean)
	247 (absolute-component-p x)
	248 (and (consp x) (absolute-component-p (first x)) (every #'relat…
	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 notabl…
	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…
	258 "Register a function to be called when clearing configuration"
	259 (register-hook-function 'clear-configuration-hook hook-function ca…
	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, tr…
	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-fold…
	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\W…
	281 (ecase folder
	282 (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
	283 (subpathname* (get-folder-path :appdata) "…
	284 (:appdata (getenv-absolute-directory "APPDATA"))
	285 (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDA…
	286 (subpathname* (getenv-absolute-directory …
	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-spec…
	292 MORE may contain specifications for a subpath relative to this directory…
	293 subpathname specification and keyword arguments as per RESOLVE-LOCATION …
	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 confi…
	304 MORE may contain specifications for a subpath relative to this directory…
	305 subpathname specification and keyword arguments as per RESOLVE-LOCATION …
	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 f…
	316 Returns a list of absolute directory pathnames.
	317 MORE may contain specifications for a subpath relative to these director…
	318 subpathname specification and keyword arguments as per RESOLVE-LOCATION …
	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 :co…
	324 (t (mapcar 'parse-unix-namestring '("/usr/local/share/"…
	325
	326 (defun xdg-config-dirs (&rest more)
	327 "The preference-ordered set of additional base paths to search for c…
	328 Returns a list of absolute directory pathnames.
	329 MORE may contain specifications for a subpath relative to these director…
	330 subpathname specification and keyword arguments as per RESOLVE-LOCATION …
	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_DIR…
	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 da…
	340 Returns an absolute directory pathname.
	341 MORE may contain specifications for a subpath relative to this directory…
	342 subpathname specification and keyword arguments as per RESOLVE-LOCATION …
	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 fi…
	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…
	356 subpathname specification and keyword arguments as per RESOLVE-LOCATION …
	357 also \"Configuration DSL\"\) in the ASDF manual."
	358 ;; The XDG spec says that if not provided by the login system, the a…
	359 ;; issue a warning and provide a replacement. UIOP is not equipped t…
	360 (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIM…
	361
	362 ;;; NOTE: modified the docstring because "system user configuration
	363 ;;; directories" seems self-contradictory. I'm not sure my wording is …
	364 (defun system-config-pathnames (&rest more)
	365 "Return a list of directories where are stored the system's default …
	366 MORE may contain specifications for a subpath relative to these director…
	367 subpathname specification and keyword arguments as per RESOLVE-LOCATION …
	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-namest…
	372
	373 (defun filter-pathname-set (dirs)
	374 "Parse strings as unix namestrings and remove duplicates and non abs…
	375 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-…
	376
	377 (defun xdg-data-pathnames (&rest more)
	378 "Return a list of absolute pathnames for application data directorie…
	379 returns directory for data for that application, without APP, returns th…
	380 for storing all application configurations.
	381 MORE may contain specifications for a subpath relative to these director…
	382 subpathname specification and keyword arguments as per RESOLVE-LOCATION …
	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 director…
	391 subpathname specification and keyword arguments as per RESOLVE-LOCATION …
	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 :in…
	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 di…
	401 (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :…
	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 directio…
	408
	409 (defun compute-user-cache ()
	410 "Compute (and return) the location of the default user-cache for tra…
	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))