configuration.lisp 20.8 KB
Newer Older
1
2
3
;;;; ---------------------------------------------------------------------------
;;;; Generic support for configuration files

4
5
6
7
(uiop/package:define-package :uiop/configuration
  (:nicknames :asdf/configuration)
  (:recycle :uiop/configuration :asdf/configuration :asdf)
  (:use :uiop/common-lisp :uiop/utility
8
   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
9
  (:export
10
11
   #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
   #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
12
   #:get-folder-path
13
14
   #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
   #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
15
   #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames
16
   #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname
17
18
   #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
   #:configuration-inheritance-directive-p
19
   #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
20
   #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
21
   #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
22
   #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
23
(in-package :uiop/configuration)
24

25
26
27
28
29
30
31
(with-upgradability ()
  (define-condition invalid-configuration ()
    ((form :reader condition-form :initarg :form)
     (location :reader condition-location :initarg :location)
     (format :reader condition-format :initarg :format)
     (arguments :reader condition-arguments :initarg :arguments :initform nil))
    (:report (lambda (c s)
32
33
34
35
36
               (format s (compatfmt "~@<~? (will be skipped)~@:>")
                       (condition-format c)
                       (list* (condition-form c) (condition-location c)
                              (condition-arguments c))))))

37
  (defun configuration-inheritance-directive-p (x)
38
    "Is X a configuration inheritance directive?"
39
40
41
    (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
      (or (member x kw)
          (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
46
47
48
49
50
51
52
53
    (etypecase reporter
      (null
       (apply 'error 'invalid-configuration args))
      (function
       (apply reporter args))
      ((or symbol string)
       (apply 'error reporter args))
      (cons
       (apply 'apply (append reporter args)))))
54

55
56
  (defvar *ignored-configuration-form* nil
    "Have configuration forms been ignored while parsing the configuration?")
57

58
59
  (defun validate-configuration-form (form tag directive-validator
                                            &key location invalid-form-reporter)
60
61
62
63
64
65
66
67
68
69
    "Validate a configuration FORM. By default it will raise an error if the
FORM is not valid.  Otherwise it will return the validated form.
     Arguments control the behavior:
     The configuration FORM should be of the form (TAG . <rest>)
     Each element of <rest> will be checked by first seeing if it's a configuration inheritance
directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
on it.
     In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
the configuration form appeared."
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
    (unless (and (consp form) (eq (car form) tag))
      (setf *ignored-configuration-form* t)
      (report-invalid-form invalid-form-reporter :form form :location location)
      (return-from validate-configuration-form nil))
    (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
          :for directive :in (cdr form)
          :when (cond
                  ((configuration-inheritance-directive-p directive)
                   (incf inherit) t)
                  ((eq directive :ignore-invalid-entries)
                   (setf ignore-invalid-p t) t)
                  ((funcall directive-validator directive)
                   t)
                  (ignore-invalid-p
                   nil)
                  (t
                   (setf *ignored-configuration-form* t)
                   (report-invalid-form invalid-form-reporter :form directive :location location)
                   nil))
            :do (push directive x)
          :finally
             (unless (= inherit 1)
               (report-invalid-form invalid-form-reporter
93
94
95
96
97
98
                                    :form form :location location
                                    ;; we throw away the form and location arguments, hence the ~2*
                                    ;; this is necessary because of the report in INVALID-CONFIGURATION
                                    :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
                                                        One and only one of ~S or ~S is required.~@:>")
                                    :arguments '(:inherit-configuration :ignore-inherited-configuration)))
99
             (return (nreverse x))))
100

101
  (defun validate-configuration-file (file validator &key description)
102
103
104
    "Validate a configuration FILE.  The configuration file should have only one s-expression
in it, which will be checked with the VALIDATOR FORM.  DESCRIPTION argument used for error
reporting."
105
106
107
108
109
    (let ((forms (read-file-forms file)))
      (unless (length=n-p forms 1)
        (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
               description forms))
      (funcall validator (car forms) :location file)))
110

111
112
  (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter)
    "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
113
114
be applied to the results to yield a configuration form.  Current
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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
                        (remove-if
                         'hidden-pathname-p
                         (directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
                       #'string< :key #'namestring)))
      `(,tag
        ,@(loop :for file :in files :append
                                    (loop :with ignore-invalid-p = nil
                                          :for form :in (read-file-forms file)
                                          :when (eq form :ignore-invalid-entries)
                                            :do (setf ignore-invalid-p t)
                                          :else
                                            :when (funcall validator form)
                                              :collect form
                                          :else
                                            :when ignore-invalid-p
                                              :do (setf *ignored-configuration-form* t)
                                          :else
                                            :do (report-invalid-form invalid-form-reporter :form form :location file)))
        :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
139
    (ensure-pathname
     (etypecase x
140
       (null nil)
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
       (pathname x)
       (string (parse-unix-namestring
                x :ensure-directory ensure-directory))
       (cons
        (if (null (cdr x))
            (resolve-relative-location
             (car x) :ensure-directory ensure-directory :wilden wilden)
            (let* ((car (resolve-relative-location
                         (car x) :ensure-directory t :wilden nil)))
              (merge-pathnames*
               (resolve-relative-location
                (cdr x) :ensure-directory ensure-directory :wilden wilden)
               car))))
       ((eql :*/) *wild-directory*)
       ((eql :**/) *wild-inferiors*)
       ((eql :*.*.*) *wild-file*)
       ((eql :implementation)
        (parse-unix-namestring
         (implementation-identifier) :ensure-directory t))
       ((eql :implementation-type)
        (parse-unix-namestring
         (string-downcase (implementation-type)) :ensure-directory t))
       ((eql :hostname)
        (parse-unix-namestring (hostname) :ensure-directory t)))
     :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
     :want-relative t))
167

168
169
  (defvar *here-directory* nil
    "This special variable is bound to the currect directory during calls to
170
171
172
PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
directive.")

173
174
  (defvar *user-cache* nil
    "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
179
    (ensure-pathname
     (etypecase x
180
       (null nil)
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
       (pathname x)
       (string
        (let ((p #-mcl (parse-namestring x)
                 #+mcl (probe-posix x)))
          #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
          (if ensure-directory (ensure-directory-pathname p) p)))
       (cons
        (return-from resolve-absolute-location
          (if (null (cdr x))
              (resolve-absolute-location
               (car x) :ensure-directory ensure-directory :wilden wilden)
              (merge-pathnames*
               (resolve-relative-location
                (cdr x) :ensure-directory ensure-directory :wilden wilden)
               (resolve-absolute-location
                (car x) :ensure-directory t :wilden nil)))))
       ((eql :root)
        ;; special magic! we return a relative pathname,
        ;; but what it means to the output-translations is
        ;; "relative to the root of the source pathname's host and device".
        (return-from resolve-absolute-location
          (let ((p (make-pathname* :directory '(:relative))))
            (if wilden (wilden p) p))))
       ((eql :home) (user-homedir-pathname))
       ((eql :here) (resolve-absolute-location
206
207
                     (or *here-directory* (pathname-directory-pathname (load-pathname)))
                     :ensure-directory t :wilden nil))
208
209
210
211
212
       ((eql :user-cache) (resolve-absolute-location
                           *user-cache* :ensure-directory t :wilden nil)))
     :wilden (and wilden (not (pathnamep x)))
     :resolve-symlinks *resolve-symlinks*
     :want-absolute t))
213

214
215
216
  ;; Try to override declaration in previous versions of ASDF.
  (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
                               (: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
221
222
    ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
    (loop* :with dirp = (or directory ensure-directory)
           :with (first . rest) = (if (atom x) (list x) x)
223
224
225
226
           :with path = (or (resolve-absolute-location
                             first :ensure-directory (and (or dirp rest) t)
                                   :wilden (and wilden (null rest)))
                            (return nil))
227
228
229
230
231
232
233
234
235
           :for (element . morep) :on rest
           :for dir = (and (or morep dirp) t)
           :for wild = (and wilden (not morep))
           :for sub = (merge-pathnames*
                       (resolve-relative-location
                        element :ensure-directory dir :wilden wild)
                       path)
           :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
           :finally (return path)))
236

237
  (defun location-designator-p (x)
238
    "Is X a designator for a location?"
239
240
    ;; NIL means "skip this entry", or as an output translation, same as translation input.
    ;; T means "any input" for a translation, or as output, same as translation input.
241
242
243
244
245
246
247
248
249
    (flet ((absolute-component-p (c)
             (typep c '(or string pathname
                        (member :root :home :here :user-cache))))
           (relative-component-p (c)
             (typep c '(or string pathname
                        (member :*/ :**/ :*.*.* :implementation :implementation-type)))))
      (or (typep x 'boolean)
          (absolute-component-p x)
          (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
254
    ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
    (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
271
    (when *ignored-configuration-form*
      (clear-configuration)
272
      (setf *ignored-configuration-form* nil)))
273
274


275
276
277
  (defun get-folder-path (folder)
    "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
this function tries to locate the Windows FOLDER for one of
278
279
:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
     Returns NIL when the folder is not defined (e.g., not on Windows)."
280
281
282
283
    (or #+(and lispworks mswindows) (sys:get-folder-path folder)
        ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
        (ecase folder
          (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
284
                              (subpathname* (get-folder-path :appdata) "Local")))
285
286
287
288
          (:appdata (getenv-absolute-directory "APPDATA"))
          (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
                               (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))

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
294
295
MORE may contain specifications for a subpath relative to this directory: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
296
297
298
299
300
301
302
303
    (resolve-absolute-location
     `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
            (os-cond
             ((os-windows-p) (get-folder-path :local-appdata))
             (t (subpathname (user-homedir-pathname) ".local/share/"))))
       ,more)))

  (defun xdg-config-home (&rest more)
304
    "Returns a pathname for the directory containing user-specific configuration files.
305
306
307
MORE may contain specifications for a subpath relative to this directory: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
308
309
310
311
312
313
    (resolve-absolute-location
     `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
            (os-cond
             ((os-windows-p) (xdg-data-home "config/"))
             (t (subpathname (user-homedir-pathname) ".config/"))))
       ,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
319
320
MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
321
322
323
324
325
    (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
            (or (getenv-absolute-directories "XDG_DATA_DIRS")
                (os-cond
                 ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
                 (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
332
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
333
334
335
    (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
            (or (getenv-absolute-directories "XDG_CONFIG_DIRS")
                (os-cond
336
                 ((os-windows-p) (xdg-data-dirs "config/"))
337
338
339
                 (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))

  (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
343
344
MORE may contain specifications for a subpath relative to this directory: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
345
346
347
    (resolve-absolute-location
     `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
            (os-cond
348
             ((os-windows-p) (xdg-data-home "cache/"))
349
350
             (t (subpathname* (user-homedir-pathname) ".cache/"))))
       ,more)))
351

352
  (defun xdg-runtime-dir (&rest more)
353
354
    "Pathname for user-specific non-essential runtime files and other file objects,
such as sockets, named pipes, etc.
355
Returns an absolute directory pathname.
356
357
358
MORE may contain specifications for a subpath relative to this directory: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
359
360
    ;; The XDG spec says that if not provided by the login system, the application should
    ;; 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
364
  ;;; NOTE: modified the docstring because "system user configuration
  ;;; 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
368
369
MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
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
375
  (defun filter-pathname-set (dirs)
    "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
376
377
    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))

378
  (defun xdg-data-pathnames (&rest more)
379
380
    "Return a list of absolute pathnames for application data directories.  With APP,
returns directory for data for that application, without APP, returns the set of directories
381
for storing all application configurations.
382
383
384
MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
385
    (filter-pathname-set
386
387
     `(,(xdg-data-home more)
       ,@(xdg-data-dirs more))))
388

389
  (defun xdg-config-pathnames (&rest more)
390
    "Return a list of pathnames for application configuration.
391
392
393
MORE may contain specifications for a subpath relative to these directories: a
subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
also \"Configuration DSL\"\) in the ASDF manual."
394
    (filter-pathname-set
395
396
     `(,(xdg-config-home more)
       ,@(xdg-config-dirs more))))
397
398
399

  (defun find-preferred-file (files &key (direction :input))
    "Find first file in the list of FILES that exists (for direction :input or :probe)
Robert Goldman's avatar
Robert Goldman committed
400
401
or just the first one (for direction :output or :io).
    Note that when we say \"file\" here, the files in question may be directories."
402
403
    (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))

404
405
  (defun xdg-data-pathname (&optional more (direction :input))
    (find-preferred-file (xdg-data-pathnames more) :direction direction))
406

407
408
  (defun xdg-config-pathname (&optional more (direction :input))
    (find-preferred-file (xdg-config-pathnames more) :direction direction))
409
410

  (defun compute-user-cache ()
411
412
    "Compute (and return) the location of the default user-cache for translate-output
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))