Commit a66dda2d authored by Eric Timmons's avatar Eric Timmons
Browse files

Begin incorporating session cache to overide fs hit and duplicated work

Cache will also be used to delay reading config files until after a session
starts instead of on image start. This allows CLPM to account for changes to
the files since its image was started.
parent 56035dc7
......@@ -14,6 +14,7 @@
#:clpm/config/file-source
#:clpm/config/paths
#:clpm/config/source-defs
#:clpm/session
#:clpm/utils
#:iterate)
(:export #:*clpm-config-directories*
......@@ -28,41 +29,52 @@
(in-package #:clpm/config)
(defvar *config-sources* nil)
(defparameter *default-config-sources* (list 'config-env-source
'config-file-source
'config-default-source))
(defun load-global-config ()
"Seed *config-sources* with the default config and primary CLPM config
file (clpm.conf)."
(let ((config-file (clpm-config-pathname '("clpm.conf"))))
(setf *config-sources*
(if config-file
(list (make-instance 'config-env-source)
(make-instance 'config-file-source :pathname config-file)
(make-instance 'config-default-source))
(list (make-instance 'config-env-source)
(make-instance 'config-default-source)))))
*config-sources*)
(defun initialize-config-sources ()
(setf *config-sources* *default-config-sources*))
(uiop:register-image-restore-hook 'initialize-config-sources)
(defun get-config-source (config-source-specifier)
(with-clpm-session (:key `(get-config-source ,config-source-specifier))
(when config-source-specifier
(etypecase config-source-specifier
(config-source
config-source-specifier)
(list
(apply #'make-instance config-source-specifier))
(symbol
(make-instance config-source-specifier))))))
(defun config-add-cli-source! (ht)
(push (make-instance 'config-cli-source
:arg-ht ht)
*config-sources*))
(defun config-type-p (obj type)
(or (and (typep obj 'config-source)
(typep obj type))
(and (listp obj)
(subtypep (first obj) type))
(subtypep obj type)))
(defun config-add-file-source! (pn)
(when (uiop:probe-file* pn)
(setf *config-sources*
(append (remove-if-not (lambda (x)
(or
(typep x 'config-env-source)
(typep x 'config-cli-source)))
(config-type-p x 'config-env-source)
(config-type-p x 'config-cli-source)))
*config-sources*)
(list (make-instance 'config-file-source :pathname pn))
(remove-if (lambda (x)
(or
(typep x 'config-env-source)
(typep x 'config-cli-source)))
(config-type-p x 'config-env-source)
(config-type-p x 'config-cli-source)))
*config-sources*)))))
(defun call-with-config-file-source-added (thunk pn)
......@@ -82,33 +94,36 @@ file (clpm.conf)."
(defun config-table-keys (&rest path)
"Return a list of keys in the table rooted at PATH. This currently does not
look at environment variables."
(let ((defined-children (get-children-of-config-path path)))
(if (equal defined-children '(:*))
(remove-duplicates (mapcan (rcurry #'config-source-implicit-keys path)
*config-sources*)
:test #'equal)
defined-children)))
"Return a list of keys in the table rooted at PATH. This currently does n"
(with-clpm-session (:key `(config-table-keys ,@path))
(let ((defined-children (get-children-of-config-path path)))
(if (equal defined-children '(:*))
(remove-duplicates (mapcan (compose (rcurry #'config-source-implicit-keys path)
#'get-config-source)
*config-sources*)
:test #'equal)
defined-children))))
(defun config-value (&rest path)
"Get the configuration value located at path. First search environment
variables, then the config file, then the default config."
(let* ((config-info (get-config-entry path))
(type (getf (cdr config-info) :type)))
(assert config-info)
(if (eql type 'hash-table)
(let ((keys (apply #'config-table-keys path))
(out (make-hash-table :test 'equal)))
(dolist (key keys)
(setf (gethash key out) (apply #'config-value (append path (list key)))))
out)
(loop
:for config-source :in *config-sources*
:for (value exists-p) := (multiple-value-list (config-source-value config-source path))
:until exists-p
:finally
(return value)))))
(with-clpm-session (:key `(config-value ,@path))
(let* ((config-info (get-config-entry path))
(type (getf (cdr config-info) :type)))
(assert config-info)
(if (eql type 'hash-table)
(let ((keys (apply #'config-table-keys path))
(out (make-hash-table :test 'equal)))
(dolist (key keys)
(setf (gethash key out) (apply #'config-value (append path (list key)))))
out)
(loop
:for config-source-specifier :in *config-sources*
:for config-source := (get-config-source config-source-specifier)
:for (value exists-p) := (multiple-value-list (config-source-value config-source path))
:until exists-p
:finally
(return value))))))
(defun flatten-hts (ht)
"Given a hash table ~ht~, recursively flatten it into a plist."
......@@ -155,4 +170,3 @@ variables, then the config file, then the default config."
(print-table (config-value) nil stream))
(uiop:register-clear-configuration-hook 'clear-global-config)
(uiop:register-image-restore-hook 'load-global-config)
......@@ -11,7 +11,7 @@
(in-package #:clpm/config/cli-source)
(defclass config-cli-source ()
(defclass config-cli-source (config-source)
((bundle-clpmfile)
(context)
(local)
......
......@@ -11,7 +11,7 @@
(in-package #:clpm/config/default-source)
(defclass config-default-source ()
(defclass config-default-source (config-source)
()
(:documentation
"A config source that simply returns the default values."))
......
......@@ -14,7 +14,7 @@
(in-package #:clpm/config/env-source)
(defclass config-env-source ()
(defclass config-env-source (config-source)
()
(:documentation
"A configuration source backed by environment variables."))
......
......@@ -6,27 +6,30 @@
(uiop:define-package #:clpm/config/file-source
(:use #:cl
#:alexandria
#:clpm/config/paths
#:clpm/config/source-defs
#:clpm/utils)
(:export #:config-file-source))
(in-package #:clpm/config/file-source)
(defclass config-file-source ()
(defclass config-file-source (config-source)
((root-ht
:accessor config-file-source-root-ht)
(pathname
:reader config-file-source-pathname
:initarg :pathname))
:initarg :pathname
:initform (clpm-config-pathname '("clpm.conf"))))
(:documentation
"A configuration source backed by a file."))
(defmethod initialize-instance :after ((config-source config-file-source) &rest initargs &key pathname)
(defmethod initialize-instance :after ((config-source config-file-source) &rest initargs)
(declare (ignore initargs))
(assert pathname)
(with-open-file (s pathname)
(setf (config-file-source-root-ht config-source)
(load-config-from-stream s))))
(if (probe-file (config-file-source-pathname config-source))
(with-open-file (s (config-file-source-pathname config-source))
(setf (config-file-source-root-ht config-source)
(load-config-from-stream s)))
(setf (config-file-source-root-ht config-source) (make-hash-table :test 'equal))))
(defgeneric parse-config-value (value))
......
......@@ -5,11 +5,17 @@
(uiop:define-package #:clpm/config/source-defs
(:use #:cl)
(:export #:config-source-implicit-keys
(:export #:config-source
#:config-source-implicit-keys
#:config-source-value))
(in-package #:clpm/config/source-defs)
(defclass config-source ()
()
(:documentation
"Parent class for config sources."))
(defgeneric config-source-value (config-source path))
(defgeneric config-source-implicit-keys (config-source path)
......
;;;; CLPM Sessions
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/session
(:use #:cl)
(:export #:*config-sources*
#:with-clpm-session))
(in-package #:clpm/session)
(defvar *session-cache* nil
"Bound to a hash-table when inside a CLPM session. Used to cache function
return values.")
(defvar *config-sources* nil
"Bound to a list of config source specifiers inside a CLPM session.")
(defun call-with-clpm-session (thunk &key override key)
"Starts a new CLPM session if one does not currently exist (unless OVERRIDE is
non-NIL).
If KEY is provided and an entry exists in *SESSION-CACHE* with that key, it is
returned from the cache instead of invoking THUNK. If THUNK is invoked, its
results are stored in the cache."
(cond
((or override (not *session-cache*))
(let* ((*session-cache* (make-hash-table :test 'equal))
(*config-sources* *config-sources*))
(funcall thunk)))
((and *session-cache* key)
(multiple-value-bind (cached-values cached-values-exist-p)
(gethash key *session-cache*)
(if cached-values-exist-p
(values-list cached-values)
(let ((result (multiple-value-list (funcall thunk))))
(setf (gethash key *session-cache*) result)
(values-list result)))))
(t (funcall thunk))))
(defmacro with-clpm-session ((&key override key) &body body)
`(call-with-clpm-session (lambda () ,@body) :override ,override :key ,key))
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