Commit 702f1969 authored by Eric Timmons's avatar Eric Timmons
Browse files

Client ASDF integration now only works when a context is active

parent c8a5770c
......@@ -24,7 +24,7 @@
+ =context source-registry= CLI added.
+ =context output-translations= CLI added.
+ =exec= CLI added.
+ =enter-context= function added to client to allow changing source registry
+ =activate-context= function added to client to allow changing source registry
and output translations of the current image.
+ Add =bundle init= CLI and =bundle-init= in client to easily create a new
clpmfile.
......
......@@ -9,18 +9,22 @@
;; * Variables
(defvar *asdf-system-not-found-behavior* :error
"The behavior if ASDF asks CLPM to find a system and CLPM is unable to find
it. One of:
"The behavior if ASDF is unable to find a system and CLPM's ASDF integration
is active. One of:
+ :ERROR :: Signal a MISSING-SYSTEM condition. If the current context is a
bundle, the INSTALL-AND-RELOAD-BUNDLE and RELOAD-BUNDLE restarts will be
available. If the current context is not a bundle, the INSTALL-SYSTEM and
INSTALL-SYSTEM-WITHOUT-DEPENDENCIES restarts will be available.
+ :ERROR :: Signal a MISSING-SYSTEM condition. The restarts
RELOAD-CONTEXT-CONFIG, INSTALL-AND-RELOAD-CONTEXT-CONFIG, and
INSTALL-WITHOUT-DEPENDENCIES-AND-RELOAD-CONTEXT-CONFIG will be available.
+ :INSTALL :: Install the system and its dependencies without prompting.
+ :INSTALL :: Install the system and its dependencies without prompting. If the
active context is a bundle, the system is currently not added to the bundle (you
will need to either add it to the clpmfile or as a dependency to some other
included system for this to have any effect).
+ :INSTALL-WITHOUT-DEPS :: Install the system without its dependencies without
prompting.
prompting. If the active context is a bundle, the system is currently not added
to the bundle (you will need to either add it to the clpmfile or as a dependency
to some other included system for this to have any effect).
+ NIL :: Do nothing.")
......@@ -37,31 +41,24 @@ prompting.
(:documentation
"A condition signaled when CLPM thinks a system is not installed."))
(defun install-and-reload-bundle (&optional condition)
"Invoke the INSTALL-AND-RELOAD-BUNDLE restart or return NIL if the restart
does not exist."
(let ((restart (find-restart 'install-and-reload-bundle condition)))
(defun reload-context-config (&optional condition)
"Invoke the RELOAD-CONTEXT-CONFIG restart or return NIL if the restart does
not exist."
(let ((restart (find-restart 'reload-context-config condition)))
(when restart
(invoke-restart restart))))
(defun install-system (&optional condition)
"Invoke the INSTALL-SYSTEM restart or return NIL if the restart does not
exist."
(let ((restart (find-restart 'install-system condition)))
(when restart
(invoke-restart restart))))
(defun install-system-without-dependencies (&optional condition)
"Invoke the INSTALL-SYSTEM-WITHOUT-DEPENDENCIES restart or return NIL if the
(defun install-and-reload-context-config (&optional condition)
"Invoke the INSTALL-AND-RELOAD-CONTEXT-CONFIG restart or return NIL if the
restart does not exist."
(let ((restart (find-restart 'install-system-without-dependencies condition)))
(let ((restart (find-restart 'install-and-reload-context-config condition)))
(when restart
(invoke-restart restart))))
(defun reload-bundle (&optional condition)
"Invoke the RELOAD-BUNDLE restart or return NIL if the restart does not
exist."
(let ((restart (find-restart 'reload-bundle condition)))
(defun install-without-dependencies-and-reload-context-config (&optional condition)
"Invoke the INSTALL-WITHOUT-DEPENDENCIES-AND-RELOAD-CONTEXT-CONFIG restart or
return NIL if the restart does not exist."
(let ((restart (find-restart 'install-without-dependencies-and-reload-context-config condition)))
(when restart
(invoke-restart restart))))
......@@ -73,107 +70,82 @@ exist."
;; * ASDF Search Functions
(defun find-system-without-clpm (system-name)
"Call ASDF:FIND-SYSTEM in a dynamic environment with
"Call ASDF:SEARCH-FOR-SYSTEM-DEFINITION in a dynamic environment with
*ASDF-SYSTEM-NOT-FOUND-BEHAVIOR* bound to NIL. Used to prevent infinite
recursion."
(let ((*asdf-system-not-found-behavior* nil))
(asdf:find-system system-name)))
(defun should-auto-reload-source-registry-p ()
(or (and *active-context*
(equal *active-context* (context)))
(and (inside-bundle-exec-p)
(eql (context) :bundle))
(and (clpm-exec-context)
(equal (context) (clpm-exec-context)))))
(asdf:search-for-system-definition system-name)))
(defun asdf-configure-source-registry (source-registry
&optional
(splice (and (not *active-context-ignore-inherited-source-registry*)
*active-context-splice-source-registry*)))
(when splice
(let* ((inherit-configuration-position (position :inherit-configuration source-registry)))
(when inherit-configuration-position
(setf source-registry (append (butlast source-registry (- (length source-registry)
inherit-configuration-position))
(rest splice)
(nthcdr (1+ inherit-configuration-position) source-registry))))))
(asdf:clear-source-registry)
(asdf:initialize-source-registry source-registry))
(defun clpm-system-definition-search (system-name)
"A search function for ASDF's *SYSTEM-DEFINITION-SEARCH-FUNCTIONS* list.
Given a system name, it tries to find it. If the system cannot be found, it
either does nothing, signals a condition, and/or installs the system (see:
*ASDF-SYSTEM-NOT-FOUND-BEHAVIOR*)."
(let ((primary-name (asdf:primary-system-name system-name)))
;; Don't handle ASDF or UIOP for the moment...
(unless (or (equal "asdf" primary-name)
(equal "uiop" primary-name))
(flet ((lookup-system ()
(context-find-system-asd-pathname system-name))
(reload-config (&optional source-registry)
(asdf:clear-source-registry)
(asdf:initialize-source-registry (or source-registry (context-source-registry)))))
(or
(unless (inside-bundle-exec-p)
;; The ASDF config is exhaustive when inside a bundle. No need for us
;; to look it up.
(lookup-system))
(ecase *asdf-system-not-found-behavior*
(:install
(let ((new-source-registry (install :systems (unless (inside-bundle-exec-p) (list system-name)))))
(when new-source-registry
(if (should-auto-reload-source-registry-p)
(progn
(reload-config new-source-registry)
(find-system-without-clpm system-name))
(lookup-system)))))
(:install-without-deps
(let ((new-source-registry (install :systems (unless (inside-bundle-exec-p) (list system-name))
:no-deps (not (inside-bundle-exec-p)))))
(when new-source-registry
(if (should-auto-reload-source-registry-p)
(progn
(reload-config new-source-registry)
(find-system-without-clpm system-name))
(lookup-system)))))
(:error
(restart-case
;; Prevent RESTART-CASE from using WITH-CONDITION-RESTARTS.
(signal-missing-system system-name)
(install-system ()
:report "Attempt to install the system using CLPM"
:test (lambda (c) (declare (ignore c)) (not (inside-bundle-exec-p)))
(let ((new-source-registry (install :systems (list system-name))))
(when new-source-registry
(if (should-auto-reload-source-registry-p)
(progn
(reload-config new-source-registry)
(find-system-without-clpm system-name))
(lookup-system)))))
(install-system-without-dependencies ()
:report "Attempt to install the system using CLPM without also installing its dependencies"
:test (lambda (c) (declare (ignore c)) (not (inside-bundle-exec-p)))
(let ((new-source-registry (install :systems (list system-name) :no-deps t)))
(when new-source-registry
(if (should-auto-reload-source-registry-p)
(progn
(reload-config new-source-registry)
(find-system-without-clpm system-name))
(lookup-system)))))
(install-and-reload-bundle ()
:report "Install the bundle (reresolving all requiremsnts) and reload configuration from clpmfile.lock"
:test (lambda (c) (declare (ignore c)) (inside-bundle-exec-p))
(let ((new-source-registry (install)))
(when new-source-registry
(reload-config new-source-registry)
(asdf:find-system system-name))))
(reload-bundle ()
:report "Clear ASDF configuration and reload from clpmfile.lock."
:test (lambda (c) (declare (ignore c)) (inside-bundle-exec-p))
(reload-config)
(asdf:find-system system-name))))
((nil)
nil)))))))
Does nothing if there is no active context.
As this only works with an active context, we can assume that if control gets
here, ASDF was unable to find the system (as activating a context involves
configuring the source registry to include every system). That means we don't
even have to search for the system as all config resides in the source registry.
See *ASDF-SYSTEM-NOT-FOUND-BEHAVIOR* for details on how this function can be
configured to behave."
(let ((primary-name (asdf:primary-system-name system-name))
(active-context (active-context)))
(when (and active-context
;; Don't handle ASDF or UIOP for the moment. Primary reason is I
;; don't want to deal with ASDF's self upgrades and refusal to
;; downgrade yet.
(not (equal "asdf" primary-name))
(not (equal "uiop" primary-name)))
(flet ((%install (no-deps)
(let ((new-source-registry
(install :systems (unless (context-bundle-p active-context) (list system-name))
:no-deps no-deps)))
(when new-source-registry
(asdf-configure-source-registry new-source-registry)
(find-system-without-clpm system-name)))))
(ecase *asdf-system-not-found-behavior*
(:install (%install nil))
(:install-without-deps (%install t))
(:error
(restart-case
;; Prevent RESTART-CASE from using WITH-CONDITION-RESTARTS,
;; otherwise things can get messed up for defsystem-depends-on
(signal-missing-system system-name)
(reload-context-config ()
:report "Reload the source registry for the context and try again."
(asdf-configure-source-registry (context-source-registry :context active-context))
(asdf:search-for-system-definition system-name))
(install-and-reload-context-config ()
:report "Attempt to install the system and try again."
(%install nil))
(install-without-dependencies-and-reload-context-config ()
:report "Attempt to install the system without dependencies and try again."
(%install t))))
((nil)
nil))))))
(defun asdf-integration-active-p ()
"Returns non-NIL iff 'CLPM-SYSTEM-DEFINITION-SEARCH is registered with ASDF's
search functions."
(member 'clpm-system-definition-search asdf:*system-definition-search-functions*))
(defun activate-asdf-integration (&key force
(order :last))
(defun activate-asdf-integration ()
"Add 'CLPM-SYSTEM-DEFINITION-SEARCH to ASDF's system definition search functions list.
Does nothing if ASDF-INTEGRATION-ACTIVE-P returns T and :FORCE is NIL.
Does nothing if ASDF-INTEGRATION-ACTIVE-P returns T.
:ORDER can be one of:
......@@ -182,14 +154,9 @@ Does nothing if ASDF-INTEGRATION-ACTIVE-P returns T and :FORCE is NIL.
+ :FIRST :: The CLPM search function is added to the front of ASDF's search
functions."
(when (or force
(not (asdf-integration-active-p)))
(ecase order
(:last
(setf asdf:*system-definition-search-functions*
(append asdf:*system-definition-search-functions* (list 'clpm-system-definition-search))))
(:first
(push 'clpm-system-definition-search asdf:*system-definition-search-functions*)))))
(unless (asdf-integration-active-p)
(setf asdf:*system-definition-search-functions*
(append asdf:*system-definition-search-functions* (list 'clpm-system-definition-search)))))
(defun deactivate-asdf-integration ()
"Removes CLPM-SYSTEM-DEFINITION-SEARCH from ASDF's search functions."
......
......@@ -20,9 +20,7 @@ CLPMFILE) to the new clpmfile."
(defun bundle-install (&key clpmfile no-resolve (validate 'context-diff-approved-p))
"Ensure a bundle is installed. Returns a source registry form if the install completed.
CLPMFILE must be a pathname pointing a clpmfile or NIL. If NIL, the current
clpmfile (typically specified in the CLPM_BUNDLE_CLPMFILE environment variable)
is used.
CLPMFILE must be a pathname pointing a clpmfile.
If NO-RESOLVE is non-NIL, then the bundle will be installed completely from its
lock file, without reresolving any requirements.
......@@ -34,10 +32,10 @@ aborted."
(with-clpm-proc (proc)
(clpm-proc-print
proc
`(with-bundle-default-pathname-defaults (,@(when (pathnamep clpmfile) (list clpmfile)))
(with-bundle-local-config (,@(when (pathnamep clpmfile) (list clpmfile)))
`(with-bundle-default-pathname-defaults (,clpmfile)
(with-bundle-local-config (,clpmfile)
(bundle-source-registry
(bundle-install ,(if (pathnamep clpmfile) clpmfile '(bundle-clpmfile-pathname))
(bundle-install ,clpmfile
:validate ,(make-diff-validator-fun)
:no-resolve ,no-resolve)))))
(setf diff-description (clpm-proc-read proc))
......@@ -54,9 +52,7 @@ aborted."
PROJECTS is a list of projects to update. SYSTEMS is a list of systems to
update. If both are NIL, all projects are available for updating.
CLPMFILE must be a pathname pointing a clpmfile or NIL. If NIL, the current
clpmfile (typically specified in the CLPM_BUNDLE_CLPMFILE environment variable)
is used.
CLPMFILE must be a pathname pointing a clpmfile.
VALIDATE is a function that takes a CONTEXT-DIFF instance and returns non-NIL if
the diff is approved and the install can continue. If NIL, the install is
......@@ -65,9 +61,9 @@ aborted."
(with-clpm-proc (proc)
(clpm-proc-print
proc
`(with-bundle-default-pathname-defaults (,@(when (pathnamep clpmfile) (list clpmfile)))
(with-bundle-local-config (,@(when (pathnamep clpmfile) (list clpmfile)))
(bundle-update ,(if (pathnamep clpmfile) clpmfile '(bundle-clpmfile-pathname))
`(with-bundle-default-pathname-defaults (,clpmfile)
(with-bundle-local-config (,clpmfile)
(bundle-update ,clpmfile
:update-systems ',systems
:update-projects ',projects
:validate ,(make-diff-validator-fun)))))
......
......@@ -10,10 +10,10 @@
:depends-on ((:version #:uiop "3.3.0"))
:serial nil
:components
((:file "asdf" :depends-on ("package" "cleanup"))
((:file "asdf" :depends-on ("package" "cleanup" "context"))
(:file "bundle" :depends-on ("package" "proc"))
(:file "cleanup" :depends-on ("package"))
(:file "context" :depends-on ("package" "proc"))
(:file "context" :depends-on ("package" "proc" "cleanup"))
(:file "diff" :depends-on ("package"))
(:file "env" :depends-on ("package"))
(:file "install" :depends-on ("package" "proc"))
......
......@@ -6,29 +6,67 @@
(in-package #:clpm-client)
(defvar *default-context* nil
"If non-NIL, the default context to use. Can either be a string (naming a
global CLPM context), the symbol :BUNDLE (which refers to the currently active
bundle, typically determined by the CLPM_BUNDLE_CLPMFILE environment variable),
or a pathname to a clpmfile.")
"If non-NIL, the default context to use for most operations. Can either be a
string (naming a global CLPM context) or a pathname to a clpmfile.")
(defvar *active-context* nil
"Non-NIL if we have entered a context in this session.")
(defun context ()
"Returns the current context. See *DEFAULT-CONTEXT* for possible values."
(defvar *active-context-ignore-inherited-source-registry* nil
"Non-NIL if we are ignoring inherited source registries.")
(defvar *active-context-splice-source-registry* nil
"If non-NIL, will be spliced into source registry if inherited config is not
ignored.")
(defun configure-from-env ()
"Determine if there is any active context by looking at environment
variables."
(let ((env-clpmfile (uiop:getenvp "CLPM_BUNDLE_CLPMFILE"))
(env-context (uiop:getenvp "CLPM_EXEC_CONTEXT")))
(cond
(env-clpmfile
;; We're operating within a bundle context.
(setf *active-context* (pathname env-clpmfile))
(setf *active-context-ignore-inherited-source-registry* t))
(env-context
;; We're operating within a global CLPM context.
(setf *active-context* env-context)
(setf *active-context-ignore-inherited-source-registry*
(uiop:getenvp "CLPM_EXEC_IGNORE_INHERITED_SOURCE_REGISTRY"))
(setf *active-context-splice-source-registry*
(uiop:getenvp "CLPM_EXEC_SPLICE_INHERITED_SOURCE_REGISTRY"))))))
(uiop:register-image-restore-hook 'configure-from-env)
(defun clear-active-context ()
(setf *active-context* nil
*active-context-ignore-inherited-source-registry* nil
*active-context-splice-source-registry* nil))
(uiop:register-image-dump-hook 'clear-active-context)
(register-clpm-cleanup-hook
(lambda ()
(setf uiop:*image-restore-hook* (remove 'configure-from-env uiop:*image-restore-hook*))
(setf uiop:*image-dump-hook* (remove 'clear-active-context uiop:*image-dump-hook*))))
(defun active-context ()
"Returns the currently active context. Is either a string naming a global CLPM
context or a pathname to a clpmfile. Returns NIL if there is no currently active
context."
*active-context*)
(defun default-context ()
"Returns the default context for operations. Defaults to *DEFAULT-CONTEXT*,
then ACTIVE-CONTEXT, then \"default\"."
(or *default-context*
*active-context*
(when (inside-bundle-exec-p)
:bundle)
(clpm-exec-context)
"default"))
(defun context-bundle-p (context)
"A context names a bundle if it is the symbol :bundle or a pathname."
(or (eql context :bundle)
(pathnamep context)))
"A context names a bundle if it is a pathname."
(pathnamep context))
(defun context-asd-pathnames (&optional (context (context)))
(defun context-asd-pathnames (&optional (context (default-context)))
"Given a context, return a list of pathnames to .asd files installed in that
context."
(assert (not (context-bundle-p context)))
......@@ -38,7 +76,7 @@ context."
`(context-asd-pathnames ,context))
(clpm-proc-read proc)))
(defun context-asd-directories (&optional (context (context)))
(defun context-asd-directories (&optional (context (default-context)))
"Return the directories containing the .asd files installed in CONTEXT."
(asd-pathnames-to-directories (context-asd-pathnames context)))
......@@ -48,7 +86,7 @@ directories containing the files."
(remove-duplicates (mapcar 'uiop:pathname-directory-pathname pathnames)
:test 'uiop:pathname-equal))
(defun context-find-system-asd-pathname (system-name &optional (context (context)))
(defun context-find-system-asd-pathname (system-name &optional (context (default-context)))
"Find the pathname to a system in the given context."
(assert (not (context-bundle-p context)))
(with-clpm-proc (proc)
......@@ -57,7 +95,7 @@ directories containing the files."
`(context-find-system-asd-pathname ,context ,system-name))
(clpm-proc-read proc)))
(defun context-output-translations (&optional (context (context)))
(defun context-output-translations (&optional (context (default-context)))
"Return an output-translations form for CONTEXT."
(with-clpm-proc (proc)
(clpm-proc-print
......@@ -69,31 +107,46 @@ directories containing the files."
`(context-output-translations ,context)))
(clpm-proc-read proc)))
(defun context-source-registry (&optional (context (context)))
(defun context-source-registry (&key (context (default-context)) ignore-inherited)
"Return a source-registry form for the CONTEXT."
(with-clpm-proc (proc)
(clpm-proc-print
proc
(if (context-bundle-p context)
`(with-bundle-default-pathname-defaults (,@(when (pathnamep context) (list context)))
(with-bundle-local-config (,@(when (pathnamep context) (list context)))
(bundle-source-registry ,(if (pathnamep context) context '(bundle-clpmfile-pathname)))))
`(context-to-asdf-source-registry-form ,context)))
`(with-bundle-default-pathname-defaults (,context)
(with-bundle-local-config (,context)
(bundle-source-registry ,context)))
`(context-to-asdf-source-registry-form ,context
:ignore-inherited ,ignore-inherited)))
(clpm-proc-read proc)))
(defun enter-context (context &key activate-asdf-integration)
"Enter a CLPM context. This clears ASDF's current configuration and replaces
it with configuration appropriate for CONTEXT. If ACTIVATE-ASDF-INTEGRATION is
non-NIL, ACTIVATE-ASDF-INTEGRATION is also called.
(defun activate-context (context &key activate-asdf-integration
ignore-inherited-source-registry)
"Activate a CLPM context. This clears ASDF's current configuration and
replaces it with configuration appropriate for CONTEXT.
CONTEXT can be either a string (naming a global CLPM context) or a pathname
pointing to a bundle's clpmfile."
(let ((source-registry (context-source-registry context))
(output-translations (context-output-translations context)))
(setf *active-context* context)
(asdf:clear-configuration)
(asdf:initialize-source-registry source-registry)
pointing to a bundle's clpmfile.
If IGNORE-INHERITED-SOURCE-REGISTRY is non-NIL, then source registry
configuration from other sources is ignored. This argument is ignored if CONTEXT
is a bundle.
If ACTIVATE-ASDF-INTEGRATION is non-NIL, ACTIVATE-ASDF-INTEGRATION is also
called."
(when (and (active-context) (not (equal (active-context) context)))
(cerror "Continue" "You are attempting to activate a context when a context is already active."))
(let ((source-registry (context-source-registry :context context
:ignore-inherited ignore-inherited-source-registry))
(output-translations (context-output-translations context))
(old-context (active-context)))
(setf *active-context* context
*active-context-ignore-inherited-source-registry* ignore-inherited-source-registry)
(unless old-context
(setf *active-context-splice-source-registry* asdf:*source-registry-parameter*))
(asdf-configure-source-registry source-registry)
(when output-translations
(asdf:initialize-output-translations output-translations))
(when activate-asdf-integration
(activate-asdf-integration))))
(activate-asdf-integration))
t))
......@@ -7,11 +7,11 @@
(defun clpm-exec-context ()
"Returns the context used for `clpm exec` or NIL"
(uiop:getenv "CLPM_EXEC_CONTEXT"))
(uiop:getenvp "CLPM_EXEC_CONTEXT"))
(defun inside-bundle-exec-p ()
"Returns non-NIL iff we were spawned by a `clpm bundle exec` command."
(uiop:getenv "CLPM_BUNDLE_CLPMFILE"))
(uiop:getenvp "CLPM_BUNDLE_CLPMFILE"))
(defun bundle-command ()
"Return a command (list of string) suitable for invoking the same CLPM
......
......@@ -10,7 +10,7 @@
version ref source
(validate 'context-diff-approved-p)
no-deps
(context (context)))
(context (default-context)))
"Install a set of projects and systems. Returns a source registry form if the
install completed.
......@@ -23,7 +23,8 @@ install should proceed."
(when (and (context-bundle-p context)
(or projects systems))
(error "INSTALL currently only accepts NIL for PROJECTS and SYSTEMS when working on bundles."))
(if (stringp context)
(if (context-bundle-p context)
(bundle-install :validate validate :clpmfile context)
(let (diff-description)
(with-clpm-proc (proc)
(clpm-proc-print
......@@ -44,5 +45,4 @@ install should proceed."
(clpm-proc-print proc validate-result)
(setf source-registry (clpm-proc-read proc))
(when validate-result
source-registry))))
(bundle-install :validate validate :clpmfile (when (pathnamep context) context))))
source-registry))))))
......@@ -15,6 +15,8 @@
#:*default-context*
#:asdf-integration-active-p
#:activate-asdf-integration
#:activate-context
#:active-context
#:approve-diff
#:bundle-init
#:cleanup-clpm-client
......@@ -24,7 +26,6 @@
#:clpm-error-wrapped-condition
#:clpm-system-definition-search
#:clpm-version
#:context
#:context-diff
#:context-diff-empty-p
#:context-diff-needs-approval
......@@ -32,9 +33,11 @@
#:context-diff-release-diffs
#:context-source-registry
#:deactivate-asdf-integration
#:enter-context
#:default-context
#:inside-bundle-exec-p
#:install
#:install-and-reload-context-config
#:install-without-dependencies-and-reload-context-config
#:maybe-cleanup-clpm-client
#:missing-system
#:missing-system-name
......@@ -45,7 +48,8 @@
#:release-diff-new-version
#:release-diff-old-source
#:release-diff-old-version
#:release-diff-project-name))
#:release-diff-project-name
#:reload-context-config))
(in-package #:clpm-client)
......
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