configuration.lisp 17.6 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 15 16
   #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
   #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
   #:clean-search-pathnames #:xdg-data-pathnames #:xdg-config-pathnames
   #: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
    "Validate a configuration FORM"
61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
    (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
84 85 86 87 88 89
                                    :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)))
90
             (return (nreverse x))))
91

92
  (defun validate-configuration-file (file validator &key description)
93
    "Validate a configuration file for conformance of its form with the validator function"
94 95 96 97 98
    (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)))
99

100 101
  (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter)
    "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
102 103
be applied to the results to yield a configuration form.  Current
values of TAG include :source-registry and :output-translations."
104
    (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
                        (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)))
124

125
  (defun resolve-relative-location (x &key ensure-directory wilden)
126
    "Given a designator X for an relative location, resolve it to a pathname"
127 128
    (ensure-pathname
     (etypecase x
129
       (null nil)
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
       (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))
156

157 158
  (defvar *here-directory* nil
    "This special variable is bound to the currect directory during calls to
159 160 161
PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
directive.")

162 163
  (defvar *user-cache* nil
    "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
164

165
  (defun resolve-absolute-location (x &key ensure-directory wilden)
166
    "Given a designator X for an absolute location, resolve it to a pathname"
167 168
    (ensure-pathname
     (etypecase x
169
       (null nil)
170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194
       (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
195 196
                     (or *here-directory* (pathname-directory-pathname (load-pathname)))
                     :ensure-directory t :wilden nil))
197 198 199 200 201
       ((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))
202

203 204 205
  ;; Try to override declaration in previous versions of ASDF.
  (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
                               (:ensure-directory boolean)) t) resolve-location))
206

207
  (defun* (resolve-location) (x &key ensure-directory wilden directory)
208
    "Resolve location designator X into a PATHNAME"
209 210 211
    ;; :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)
212 213 214 215
           :with path = (or (resolve-absolute-location
                             first :ensure-directory (and (or dirp rest) t)
                                   :wilden (and wilden (null rest)))
                            (return nil))
216 217 218 219 220 221 222 223 224
           :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)))
225

226
  (defun location-designator-p (x)
227
    "Is X a designator for a location?"
228 229 230 231 232 233 234 235 236
    (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))))))
237

238
  (defun location-function-p (x)
239
    "Is X the specification of a location function?"
240 241
    (and
     (length=n-p x 2)
242
     (eq (car x) :function)))
243

244
  (defvar *clear-configuration-hook* '())
245

246
  (defun register-clear-configuration-hook (hook-function &optional call-now-p)
247
    "Register a function to be called when clearing configuration"
248
    (register-hook-function '*clear-configuration-hook* hook-function call-now-p))
249

250
  (defun clear-configuration ()
251
    "Call the functions in *CLEAR-CONFIGURATION-HOOK*"
252
    (call-functions *clear-configuration-hook*))
253

254
  (register-image-dump-hook 'clear-configuration)
255

256
  (defun upgrade-configuration ()
257
    "If a previous version of ASDF failed to read some configuration, try again now."
258 259
    (when *ignored-configuration-form*
      (clear-configuration)
260
      (setf *ignored-configuration-form* nil)))
261 262


263 264 265
  (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
266 267
:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
     Returns NIL when the folder is not defined (e.g., not on Windows)."
268 269 270 271
    (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")
272
                              (subpathname* (get-folder-path :appdata) "Local")))
273 274 275 276 277
          (:appdata (getenv-absolute-directory "APPDATA"))
          (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
                               (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))

  ;; Support for the XDG Base Directory Specification
278
  (defun xdg-data-home (&rest more)
279
    "path for user specific data files"
280 281 282 283 284 285 286 287
    (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)
288
    "path for user specific configuration files"
289 290 291 292 293 294
    (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)))
295

296
  (defun xdg-data-dirs (&rest more)
297
    "the preference-ordered set of additional paths to search for data files"
298 299 300 301 302
    (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/")))))))
303

304
  (defun xdg-config-dirs (&rest more)
305
    "the preference-ordered set of additional base paths to search for configuration files"
306 307 308 309 310 311 312
    (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
            (or (getenv-absolute-directories "XDG_CONFIG_DIRS")
                (os-cond
                 ((os-windows-p) (xdg-data-dirs "config/" more))
                 (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))

  (defun xdg-cache-home (&rest more)
313
    "the base directory relative to which user specific non-essential data files should be stored"
314 315 316 317 318 319
    (resolve-absolute-location
     `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
            (os-cond
             ((os-windows-p) (xdg-data-home "cache"))
             (t (subpathname* (user-homedir-pathname) ".cache/"))))
       ,more)))
320

321
  (defun xdg-runtime-dir (&rest more)
322 323 324 325
    "pathname for user-specific non-essential runtime files and other file objects"
    ;; (such as sockets, named pipes, ...)
    ;; 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.
326
    (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
327

328
  (defun system-config-pathnames (&rest more)
329
    "Determine system user configuration directories"
330
    (os-cond
331
     ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
332 333 334 335 336

  (defun clean-search-pathnames (dirs)
    "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list"
    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))

337
  (defun xdg-data-pathnames (&rest more)
338 339 340
    "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
for storing all application configurations."
341
    (clean-search-pathnames
342 343
     `(,(xdg-data-home more)
       ,@(xdg-data-dirs more))))
344

345 346
  (defun xdg-config-pathnames (&rest more)
    "Return a list of pathnames for application configuration."
347
    (clean-search-pathnames
348 349
     `(,(xdg-config-home more)
       ,@(xdg-config-dirs more))))
350

351
  ;; FIXME: AFAICT although this says "find FILE," it is often used to find a DIRECTORY.
352 353 354 355 356
  (defun find-preferred-file (files &key (direction :input))
    "Find first file in the list of FILES that exists (for direction :input or :probe)
or just the first one (for direction :output or :io)."
    (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))

357 358
  (defun xdg-data-pathname (&optional more (direction :input))
    (find-preferred-file (xdg-data-pathnames more) :direction direction))
359

360 361
  (defun xdg-config-pathname (&optional more (direction :input))
    (find-preferred-file (xdg-config-pathnames more) :direction direction))
362 363

  (defun compute-user-cache ()
364 365
    "Compute (and return) the location of the default user-cache for translate-output
objects. Side-effects for cached file location computation."
366
    (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
367
  (register-image-restore-hook 'compute-user-cache))