Commit 01dd1431 authored by Eric Timmons's avatar Eric Timmons
Browse files

Simplify config files

parent 4f464e26
......@@ -12,12 +12,39 @@ directories separated by your OS's conventional directory separator. If any
entry in the list is empty. The default search locations will be spliced into
the list.
The contents of =clpm.conf= must be a single list that starts with ~clpm-config~
and the rest must be a plist. Each key in the plist names either a value or a
section. If it names a section, the value must be another plist. If it names a
value, the value is read according to the rules for that value.
Logically, CLPM is configured by a series of nested tables. The config file
describes these tables using a series of forms. It is recommended (and will
likely be required in the future) that the first form in the config file
declares the version of the config file API being used, such as the
following. The described version API is 0.1.
The following describe the configuration options for clpm.
#+begin_src common-lisp
(version "0.1")
Each subsequent form must describe a table. Each subsequent form must start
with ~table~ or ~(table &rest path)~. The body of the form then contains a
plist describing key/value pairs for that table. Tables can be nested by either
declaring toplevel tables with overlapping paths or by embedding a table
(without a path) as a value inside another table.
For example, the following config would force CLPM to use curl as its HTTP
client and use the primary quicklisp destribution as a source.
#+begin_src common-lisp
(version "0.1")
((table :http-client)
:method :curl)
((table :sources "quicklisp")
:type :quicklisp
:url "")
The following describes the available configuration tables for CLPM. Each
header describes a table (or sub table). The lists in each section describe
that tables keys.
* ~:archives~
......@@ -63,11 +90,11 @@ The following describe the configuration options for clpm.
+ ~:secure-only-p~ :: If non-NIL, send this header only on secure
+ ~:value~ :: The value to send for the header. If a string, the contents
of the string are used literally. If a pathname naming an executable
file, that file is executed and whatever it prints to its standard output
is used as the value. If a pathname naming a non-executable file, the
contents of the file are sent.
+ ~:value~ :: The value to send for the header. Must be a string.
+ ~:exec~ :: A path to a file that, when executed, prints the header value
to its standard output. Must be a string or pathname.
+ ~:contents~ :: A path to a file that contains the value to use for the
header. Must be a string or pathname.
* ~:http-client~
+ ~:method~ :: The default method to use to as an HTTP client. Defaults to
......@@ -33,10 +33,7 @@ The type of every source must be specified with a keyword.
Quicklisp distribution.
#+begin_src common-lisp
(:type :quicklisp
:url ""
:force-https t)))
((table :sources "quicklisp")
:type :quicklisp
:url "")
......@@ -80,19 +80,24 @@ directory in ~*clpm-config-directories*~."
;; * Configuration variables and merging configs
(defparameter *default-config*
(:method :auto))
(:tar-method :auto
(:path "tar"))
(:path "curl")
:method :auto))
"Default configuration of clpm")
(version "0.1")
((table :grovel :sandbox)
:method :auto)
((table :archives)
:tar-method :auto)
((table :archives :tar)
:path "tar")
((table :http-client)
:method :auto)
((table :http-client :curl)
:path "curl"))
"Default configuration of clpm.")
(defvar *config* nil
"Active configuration. Computed at program execution time.")
......@@ -140,94 +145,50 @@ overwrites the value from ~default-ht~."
;; * Parsing configs
(defun names-path-p (path-1 path-2)
"Returns T if ~path-1~ is named by ~path-2~. ~path-2~ can have
wildcards (~'*~) in it."
(or (equal path-1 path-2)
(and (eql '* (first path-2))
(names-path-p (rest path-1)
(rest path-2)))))
(defun path-table-p (path)
"Returns T if ~path~ is a path to a configuration value that contains a
(switch (path :test #'names-path-p)
('(:tar :archives)
('(:local :bundle)
('(* :local :bundle)
('(:remotes :git)
('(* :remotes :git)
('(:headers :http)
('(* :headers :http)
('(* * :headers :http)
('(:curl :http-client)
('(:sandbox :grovel)
('(* :sources)
(defun parse-table (path table)
"Given the ~path~ to the table and the ~table~ represented as a plist, return
a hash table representing the ~table~."
(let ((out (make-hash-table :test 'equalp)))
(for (key value) :on table :by #'cddr)
(for new-path := (list* key path))
(for value-table-p := (path-table-p new-path))
(if value-table-p
(setf (gethash key out) (parse-table new-path value))
(setf (gethash key out) value)))
(defgeneric parse-config-value (value))
(defun %parse-config-form (form)
"Given a top level config represented as a plist, return a hash table
representing the config."
(let ((out (make-hash-table :test 'equalp)))
(for (key value) :on form :by #'cddr)
(for path := (list key))
(for table-p := (path-table-p path))
(if table-p
(let ((existing-table (gethash key out (make-hash-table :test 'equalp))))
(setf (gethash key out) (merge-hts (parse-table path value) existing-table)))
(setf (gethash key out) value)))
(defmethod parse-config-value ((value t))
(defmethod parse-config-value ((value list))
(assert (eql 'table (first value)))
(parse-config-form value))
(defgeneric %parse-config-form (first rest table))
(defun parse-config-form (form)
(defmethod %parse-config-form ((first (eql 'table)) rest table)
:for key :in rest :by #'cddr
:for value :in (rest rest) :by #'cddr
:do (setf (gethash key table) (parse-config-value value))))
(defmethod %parse-config-form ((first list) rest table)
(destructuring-bind (first &rest path) first
(assert (eql 'table first))
(let ((sub-table (make-hash-table :test 'equalp)))
(%parse-config-form 'table rest sub-table)
(setf (gethashes* table path) sub-table))))
(defmethod %parse-config-form ((first (eql 'progn)) rest table)
(mapc (rcurry #'parse-config-form table) rest)
(defmethod %parse-config-form ((first (eql 'version)) rest table)
(assert (equal (first rest) "0.1")))
(defun parse-config-form (form &optional (table (make-hash-table :test 'equalp)))
"Given a top level config represented as a ~(clpm-config plist)~, return a
hash table representing the config."
(assert (listp form))
(assert (string-equal 'clpm-config (first form)))
(%parse-config-form (rest form)))
(%parse-config-form (first form) (rest form) table)
(defun merge-file-into-config! (pathname)
"Read a config form from ~pathname~ and merge it into the currently active
(uiop:with-safe-io-syntax ()
(merge-ht-into-config! (parse-config-form (uiop:read-file-form pathname)))))
(uiop:with-safe-io-syntax (:package :clpm/config)
(dolist (subform (uiop:read-file-forms pathname))
(merge-ht-into-config! (parse-config-form subform)))))
(defun load-global-config ()
"Seed ~*config*~ with ~*default-config*~ and merge the primary CLPM config
......@@ -242,9 +203,6 @@ file (clpm.conf) into ~*active*~."
"Clear the ~*config*~ variable."
(setf *config* nil))
(uiop:register-clear-configuration-hook 'clear-global-config)
(uiop:register-image-restore-hook 'load-global-config)
;; * Querying the config
......@@ -260,7 +218,7 @@ file (clpm.conf) into ~*active*~."
"Modify the value in ~hash-table~ addressed by the list of ~keys~."
(if (rest keys)
(setf (gethashes* (ensure-gethash (first keys) hash-table
(make-hash-table :test 'equal))
(make-hash-table :test 'equalp))
(rest keys))
(setf (gethash (first keys) hash-table) value)))
......@@ -286,6 +244,43 @@ file (clpm.conf) into ~*active*~."
(collect (flatten-hts value))
(collect value))))
(defun print-table (table path stream)
(let ((tables nil)
(values nil))
(maphash (lambda (k v)
(if (hash-table-p v)
(push (cons (append path (list k)) v) tables)
(push (cons k v) values)))
(when values
(let ((*print-pretty* t)
(*print-case* :downcase))
(pprint-logical-block (stream values :prefix "(" :suffix ")")
(format stream "(table ~{~S~^ ~})" path)
(pprint-newline :mandatory stream)
(let* ((pair (pprint-pop))
(key (car pair))
(value (cdr pair)))
(prin1 key stream)
(write-char #\Space stream)
(prin1 value stream)
(pprint-newline :mandatory stream))))
(pprint-newline :mandatory stream)
(terpri stream)
(terpri stream)))
(dolist (sub-table tables)
(print-table (cdr sub-table) (car sub-table) stream))))
(defun print-config (stream)
"Flatte ~*config*~ using ~flatten-hts~ and print it to ~stream~."
(format stream "~S~%" (flatten-hts *config*)))
"Print the configuration to ~stream~."
(format stream "(version \"0.1\")~%~%")
(maphash (lambda (k v)
(assert (hash-table-p v))
(print-table v (list k) stream))
(uiop:register-clear-configuration-hook 'clear-global-config)
(uiop:register-image-restore-hook 'load-global-config)
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment