Commit 015c8ab9 authored by Eric Timmons's avatar Eric Timmons
Browse files

Update client for full bundle and new feature support

parent 7a6a15e2
......@@ -8,15 +8,20 @@
#:clpm-client/bundle
#:clpm-client/cleanup
#:clpm-client/clpm
#:clpm-client/context
#:clpm-client/install)
(:import-from #:asdf
#:*system-definition-search-functions*)
(:export #:*clpm-system-not-found-behavior*
#:activate-clpm
#:clpm-active-p
#:activate-clpm-asdf-integration
#:clpm-asdf-integration-active-p
#:clpm-missing-system
#:clpm-system-search
#:deactivate-clpm))
#:deactivate-clpm-asdf-integration
#:install-and-reload-bundle
#:install-system
#:install-system-and-dependencies
#:reload-bundle))
(in-package #:clpm-client/asdf)
......@@ -33,12 +38,6 @@ prompting.
+ NIL :: Do nothing.")
(defvar *clpm-installed-systems* nil
"A cache to hold a mapping from primary system names to .asd pathnames for
systems installed by CLPM during this session. Used because there doesn't seem
to be an exposed, stable way to update ASDF's source registry once we install a
new system.")
(define-condition clpm-missing-system (error)
((system-name
:initarg :system-name))
......@@ -47,29 +46,96 @@ new system.")
(slot-value c 'system-name))))
(:documentation "A condition signaled when a system is not installed."))
(defmacro maybe-restart-case (condition form &rest cases)
`(if ,condition
(restart-case ,form
,@cases)
,form))
(defun install-system-and-record-pathnames (system-name &key no-deps-p)
(let ((pathnames (ignore-errors
(clpm-install-system system-name
:no-deps-p no-deps-p))))
(dolist (p pathnames)
(setf (gethash (pathname-name p) *clpm-installed-systems*)
(pathname p)))))
(defun populate-installed-systems ()
(setf *clpm-installed-systems* (make-hash-table :test 'equal))
(let ((pathnames (ignore-errors
(run-clpm `("context" "pathnames" "--output=sexp" ,*clpm-context*)
:output '(:string :stripped t)))))
(when pathnames
(dolist (p (uiop:with-safe-io-syntax () (read-from-string pathnames)))
(setf (gethash (pathname-name p) *clpm-installed-systems*)
(pathname p))))))
(define-condition clpm-bundle-install-diff ()
((diff
:initarg :diff))
(:report (lambda (c s)
(format s "Bundle install would perform the following changes:~%~S"
(slot-value c 'diff))))
(:documentation "A condition signaled when bundle install produces a diff."))
(defun signal-missing-system (system-name)
(error 'clpm-missing-system :system-name system-name))
(defun find-system-without-clpm (system-name)
(let ((*clpm-system-not-found-behavior* nil))
(asdf:find-system system-name)))
(defun clpm-bundle-install-validate-diff (diff)
(restart-case
(progn (error 'clpm-bundle-install-diff :diff diff))
(continue ()
:report "Accept and continue"
t)
(abort ()
:report "Do not accept the diff"
nil)))
(defun clpm-system-search-bundle (system-name)
"ASDF search function for use inside a bundle. When inside a bundle exec, ASDF
is configured entirely through environment variables and that configuration is
exhaustive. If a system is missing, the best we can do is either reload the
config from the lock file (in case the lockfile has been modified outside this
process), or run a bundle install to propagate new dependencies and requirements
into the lock file and then reload the config."
(flet ((reload-config ()
(asdf:clear-source-registry)
(asdf:initialize-source-registry (clpm-bundle-source-registry))))
(ecase *clpm-system-not-found-behavior*
((:install :install-with-deps)
(clpm-bundle-install)
(reload-config)
(find-system-without-clpm system-name))
(:error
(restart-case
;; Prevent RESTART-CASE from using WITH-CONDITION-RESTARTS
(signal-missing-system system-name)
(install-and-reload-bundle ()
:report "Run bundle install and reload configuration form clpmfile.lock"
(when (clpm-bundle-install :validate 'clpm-bundle-install-validate-diff)
(reload-config)
(asdf:find-system system-name)))
(reload-bundle ()
:report "Clear ASDF configuration and reload from clpmfile.lock."
(reload-config)
(asdf:find-system system-name))))
((nil)
nil))))
(defun clpm-system-search-no-bundle (system-name)
"ASDF search function for use outside of a bundle, when global contexts are in
use."
(let ((primary-name (asdf:primary-system-name system-name)))
(flet ((lookup-system ()
(clpm-context-find-system primary-name)))
(or
(lookup-system)
(ecase *clpm-system-not-found-behavior*
(:install
(clpm-install-system system-name :no-deps-p t)
(lookup-system))
(:install-with-deps
(clpm-install-system 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."
(let ((*clpm-system-not-found-behavior* nil))
(clpm-install-system system-name :no-deps-p t)
(lookup-system)))
(install-system-and-dependencies ()
:report "Attempt to install the system and its dependencies using CLPM."
(let ((*clpm-system-not-found-behavior* nil))
(clpm-install-system system-name)
(lookup-system)))
(continue ()
:report "Return control to ASDF."
nil)))
((nil)
nil))))))
(defun clpm-system-search (system-name)
"A search function for ASDF's *SYSTEM-DEFINITION-SEARCH-FUNCTIONS* list.
......@@ -78,69 +144,22 @@ Given a system name, it tries to find it using the CLPM executable (see:
*CLPM-EXECUTABLE*). If the system cannot be found, it either does nothing,
signals a condition, and/or installs the system with CLPM-INSTALL-SYSTEM (see:
*CLPM-SYSTEM-NOT-FOUND-BEHAVIOR*)."
;; If this is the first time we've called this, try to seed the installed
;; systems hash table first.
(unless *clpm-installed-systems*
(populate-installed-systems))
(let ((primary-name (asdf:primary-system-name system-name)))
(unless (or (equal "asdf" primary-name)
(equal "uiop" primary-name))
(flet ((lookup-system ()
(gethash primary-name *clpm-installed-systems*)))
(or
(lookup-system)
(ecase *clpm-system-not-found-behavior*
(:install
(install-system-and-record-pathnames system-name :no-deps-p t)
(lookup-system))
(:install-with-deps
(install-system-and-record-pathnames system-name)
(lookup-system))
(:error
(maybe-restart-case
(inside-bundle-exec-p)
(restart-case
;; The progn is necessary here to prevent RESTART-CASE from
;; using WITH-CONDITION-RESTARTS to associate the restarts with
;; only this condition. This becomes an issue for
;; :DEFSYSTEM-DEPENDS-ON, becuase this error will be signaled
;; in the middle of an ASDF DEFINE-OP and ASDF will catch it,
;; wrap it, and signal a new condition. If
;; WITH-CONDITION-RESTARTS is used in the expansion of this
;; macro, then these restarts won't be available in the
;; interactive debugger in this case.
(progn
(error 'clpm-missing-system :system-name system-name))
(install-system ()
:report "Attempt to install the system using CLPM."
(let ((*clpm-system-not-found-behavior* nil))
(install-system-and-record-pathnames system-name :no-deps-p t)
(lookup-system)))
(install-system-and-dependencies ()
:report "Attempt to install the system and its dependencies using CLPM."
(let ((*clpm-system-not-found-behavior* nil))
(install-system-and-record-pathnames system-name)
(lookup-system)))
(continue ()
:report "Return control to ASDF."
nil))
(reload-bundle ()
:report "Clear ASDF configuration and reload from clpmfile.lock."
(asdf:clear-configuration)
(asdf:initialize-source-registry 'bundle-pathnames-for-asd-config)
(clpm-system-search system-name))))
((nil)
nil)))))))
(defun clpm-active-p ()
(if (clpm-inside-bundle-exec-p)
(clpm-system-search-bundle system-name)
(clpm-system-search-no-bundle system-name)))))
(defun clpm-asdf-integration-active-p ()
"Returns T iff 'CLPM-SYSTEM-SEARCH is registered with ASDF's search functions."
(member 'clpm-system-search *system-definition-search-functions*))
(defun activate-clpm (&key force
(order :last))
(defun activate-clpm-asdf-integration (&key force
(order :last))
"Add 'CLPM-SYSTEM-SEARCH to ASDF's system definition search functions list.
Does nothing if CLPM-ACTIVE-P returns T and :FORCE is NIL.
Does nothing if CLPM-ASDF-INTEGRATION-ACTIVE-P returns T and :FORCE is NIL.
:ORDER can be one of:
......@@ -149,7 +168,7 @@ Does nothing if CLPM-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 (clpm-active-p)))
(not (clpm-asdf-integration-active-p)))
(ecase order
(:last
(setf *system-definition-search-functions*
......@@ -157,19 +176,10 @@ Does nothing if CLPM-ACTIVE-P returns T and :FORCE is NIL.
(:first
(push 'clpm-system-search *system-definition-search-functions*)))))
(defun deactivate-clpm ()
(defun deactivate-clpm-asdf-integration ()
"Removes ~clpm-system-search~ from ASDF's search functions."
(setf *system-definition-search-functions*
(remove 'clpm-system-search *system-definition-search-functions*)))
(defun clear-clpm-cache ()
(setf *clpm-installed-systems* (make-hash-table :test 'equal)))
(uiop:register-clear-configuration-hook 'clear-clpm-cache)
(defun clear-clpm-cache-hook ()
(setf uiop:*clear-configuration-hook*
(remove 'clear-clpm-cache uiop:*clear-configuration-hook*)))
;; Unregister CLPM from ASDF on CLPM cleanup.
(register-clpm-cleanup-hook 'deactivate-clpm)
(register-clpm-cleanup-hook 'clear-clpm-cache-hook)
(register-clpm-cleanup-hook 'deactivate-clpm-asdf-integration)
......@@ -5,27 +5,26 @@
(uiop:define-package #:clpm-client/bundle
(:use #:cl
;; Everything must depend on header so that it comes first in the
;; concatenated file.
#:clpm-client/header
#:clpm-client/clpm)
#:clpm-client/clpm
#:clpm-client/env)
(:import-from #:uiop
#:getenv
#:pathname-directory-pathname
#:with-current-directory)
(:export #:bundle-pathnames
#:bundle-pathnames-for-asd-config
(:export #:clpm-bundle-command
#:clpm-bundle-install
#:clpm-bundle-source-registry
#:clpmfile-pathname
#:inside-bundle-exec-p))
#:clpm-inside-bundle-exec-p))
(in-package #:clpm-client/bundle)
(defun inside-bundle-exec-p ()
"Returns T iff we were spawned by a ~clpm bundle exec~ command."
(defun clpm-inside-bundle-exec-p ()
"Returns T iff we were spawned by a `clpm bundle exec` command."
(not (null (getenv "CLPM_BUNDLE_CLPMFILE"))))
(defun clpmfile-pathname ()
"If spawned by a ~clpm bundle exec~ command, return the pathname to the
"If spawned by a `clpm bundle exec` command, return the pathname to the
clpmfile."
(pathname (getenv "CLPM_BUNDLE_CLPMFILE")))
......@@ -33,13 +32,53 @@ clpmfile."
"The directory pathname containing the clpmfile."
(pathname-directory-pathname (clpmfile-pathname)))
(defun bundle-pathnames ()
"Return a list of pathnames to ASD files that are part of this bundle."
(with-current-directory ((clpmfile-directory-pathname))
(uiop:split-string
(run-clpm '("bundle" "pathnames")
:output '(:string :stripped t))
:separator '(#\Newline))))
(defun clpm-bundle-command ()
"Return a command (list of string) suitable for invoking the same CLPM
executable that spawned this bundle exec environment."
(let ((bin (uiop:getenv "CLPM_BUNDLE_BIN")))
(if bin
(list bin)
(let ((live-script (uiop:getenv "CLPM_BUNDLE_BIN_LIVE_SCRIPT"))
(lisp-implementation (uiop:getenv "CLPM_BUNDLE_BIN_LISP_IMPLEMENTATION")))
(cond
((equalp "sbcl" lisp-implementation)
(list "sbcl" "--load" live-script "--"))
(t
(error "Unknown lisp implementation")))))))
(defun bundle-pathnames-for-asd-config ()
(format nil "~{~A~^:~}" (bundle-pathnames)))
(defun clpm-bundle-source-registry ()
"Return a source-registry form for this bundle."
(uiop:with-safe-io-syntax ()
(read-from-string
(run-clpm `("bundle" "source-registry"
"-f" ,(uiop:native-namestring (clpmfile-pathname))
"--with-client")
:output '(:string :stripped t)))))
(defun clpm-bundle-install (&key (validate (constantly t)))
"Run `clpm bundle install`. VALIDATE will be called with a diff and its return
value is passed to the bindle install command. Returns T iff the command exited
successfully."
(let* ((proc (launch-clpm `("bundle" "install"
"-f" ,(uiop:native-namestring (clpmfile-pathname))
"--output" "sexp")
:output :stream
:input :stream
:error-output :stream))
(diff (uiop:with-safe-io-syntax ()
(read (uiop:process-info-output proc) nil))))
(when diff
(let ((result (funcall validate diff)))
(uiop:with-safe-io-syntax ()
(prin1 result (uiop:process-info-input proc))
(terpri (uiop:process-info-input proc))
(finish-output (uiop:process-info-input proc)))))
(when *clpm-dribble*
(uiop:copy-stream-to-stream (uiop:process-info-error-output proc)
*clpm-dribble*
:linewise t
:prefix *clpm-dribble-prefix*))
(close (uiop:process-info-error-output proc))
(close (uiop:process-info-input proc))
(close (uiop:process-info-output proc))
(zerop (uiop:wait-process proc))))
;;;; Cleaning up the client on image dump
;;;; Cleaning up the client
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm-client/cleanup
(:use #:cl
;; Everything must depend on header so that it comes first in the
;; concatenated file.
#:clpm-client/header)
(:use #:cl)
(:export #:*clpm-cleanup-on-dump-p*
#:cleanup-clpm!
#:register-clpm-cleanup-hook))
......@@ -16,44 +13,47 @@
(defvar *clpm-cleanup-on-dump-p* t
"If non-NIL, CLPM will cleanup after itself if an image is dumped in a manner
that uses UIOP's image dump hooks. See ~cleanup-clpm!~ for details.")
that uses UIOP's image dump hooks. See CLEANUP-CLPM! for details.")
(defvar *clpm-cleanup-hooks* nil
"List of functions to run in ~cleanup-clpm!~.")
"List of functions to run in CLEANUP-CLPM!.")
(defun register-clpm-cleanup-hook (hook)
"Register a new function to be called as part of CLEANUP-CLPM!."
(pushnew hook *clpm-cleanup-hooks*))
(defun clpm-package-p (p)
(defun clpm-client-package-p (p)
"Returns T iff P is a package belonging to the client."
(let ((package-name (package-name p)))
(and package-name
(string-equal "clpm-client"
(first (uiop:split-string package-name :separator '(#\/)))))))
(defun cleanup-clpm! (&key force)
"If *CLPM-CLEANUP-ON-DUMP-P* is non-NIL or :FORCE is non-NIL, this function
performs the following steps:
(defun cleanup-clpm! ()
"Performs the following steps:
1. Removes ~:clpm-client~ from ~*features*~
1. Removes :CLPM-CLIENT from *FEATURES*
2. Runs all hooks in ~*clpm-cleanup-hooks*~.
2. Runs all hooks in *CLPM-CLEANUP-HOOKS*.
3. Removes ~'cleanup-clpm!~ from ~uiop:*image-dump-hook*~
3. Removes 'MAYBE-CLEANUP-CLPM! from UIOP:*IMAGE-DUMP-HOOK*
4. Deletes all packages that start with ~clpm-client/~."
(when (or *clpm-cleanup-on-dump-p* force)
;; Remove ourselves from *FEATURES*
(setf *features* (remove :clpm-client *features*))
;; Run all cleanup hooks
(mapc 'funcall *clpm-cleanup-hooks*)
;; Remove ourselves from UIOP's image dump hook
;; (setf asdf:*system-definition-search-functions*
;; (remove 'clpm-system-search asdf:*system-definition-search-functions*))
(setf uiop:*image-dump-hook* (remove 'cleanup-clpm! uiop:*image-dump-hook*))
;; Find all clpm-client packages and delete them.
(let ((packages (remove-if-not 'clpm-package-p (list-all-packages))))
(handler-bind ((package-error #'continue))
(mapc #'delete-package packages)))))
4. Deletes all packages that start with CLPM-CLIENT/."
;; Remove ourselves from *FEATURES*
(setf *features* (remove :clpm-client *features*))
;; Run all cleanup hooks
(mapc 'funcall *clpm-cleanup-hooks*)
;; Remove ourselves from UIOP's image dump hook
(setf uiop:*image-dump-hook* (remove 'cleanup-clpm! uiop:*image-dump-hook*))
;; Find all clpm-client packages and delete them.
(let ((packages (remove-if-not 'clpm-client-package-p (list-all-packages))))
(handler-bind ((package-error #'continue))
(mapc #'delete-package packages))))
(defun maybe-cleanup-clpm! ()
"Run CLEANUP-CLPM! iff *CLPM-CLEANUP-ON-DUMP-P* is non-NIL."
(when *clpm-cleanup-on-dump-p*
(cleanup-clpm!)))
;; Register our cleanup function with UIOP's image dump facilities.
(uiop:register-image-dump-hook 'cleanup-clpm!)
(uiop:register-image-dump-hook 'maybe-cleanup-clpm!)
......@@ -7,7 +7,7 @@
(error "Requires ASDF >=3.2")
(defsystem #:clpm-client
:version (:read-file-form "header.lisp" :at (1 2))
:version (:read-file-form "version.lisp" :at (2 2))
:description "A client for CLPM"
:license "BSD-2-Clause"
:class :package-inferred-system
......
......@@ -6,23 +6,30 @@
(uiop:define-package #:clpm-client/clpm-client
(:nicknames #:clpm-client)
(:use #:cl
#:clpm-client/header
#:clpm-client/asdf
#:clpm-client/bundle
#:clpm-client/cleanup
#:clpm-client/clpm)
#:clpm-client/clpm
#:clpm-client/version)
(:export #:*clpm-cleanup-on-dump-p*
#:*clpm-context*
#:*clpm-executable*
#:*clpm-system-not-found-behavior*
#:activate-clpm
#:activate-clpm-asdf-integration
#:cleanup-clpm!
#:clpm-active-p
#:clpm-asdf-integration-active-p
#:clpm-install-system
#:clpm-missing-system
#:clpm-client-version
#:clpm-inside-bundle-exec-p
#:clpm-version
#:clpmfile-pathname
#:deactivate-clpm
#:inside-bundle-exec-p
#:deactivate-clpm-asdf-integration
#:install-and-reload-bundle
#:install-system
#:install-system-and-dependencies
#:launch-clpm
#:reload-bundle
#:run-clpm))
(in-package #:clpm-client)
......
......@@ -4,11 +4,16 @@
;;;; LICENSE for license information.
(uiop:define-package #:clpm-client/clpm
(:use #:cl)
(:use #:cl
#:clpm-client/cleanup
#:clpm-client/env)
(:import-from #:uiop
#:launch-program
#:run-program)
(:export #:*clpm-context*
(:export #:*clpm-dribble*
#:*clpm-dribble-prefix*
#:*clpm-executable*
#:launch-clpm
#:run-clpm))
(in-package #:clpm-client/clpm)
......@@ -25,8 +30,11 @@
(clpm-condition-code c)
(clpm-condition-error-output c)))))
(defvar *clpm-context* "default"
"The context to operate in when not operating in a bundle.")
(defvar *clpm-dribble* *error-output*
"The stream where clpm's stderr is copied.")
(defvar *clpm-dribble-prefix* "CLPM> "
"The prefix for lines to *CLPM-DRIBBLE*.")
(defvar *clpm-executable* nil
"The command to execute CLPM. If the clpm executable is not on your PATH,
......@@ -37,19 +45,43 @@ change this to be an absolute path to the executable.")
executable that spawned us."
(or *clpm-executable*
(setf *clpm-executable*
(or (uiop:getenv "CLPM_BUNDLE_BIN_PATH")
"clpm"))))
(if (clpm-inside-bundle-exec-p)
(clpm-bundle-command)
(list "clpm")))))
(uiop:register-image-restore-hook 'compute-clpm-executable)
(defun clear-clpm-executable ()
(setf *clpm-executable* nil))
(uiop:register-image-dump-hook 'clear-clpm-executable)
(defun clear-clpm-executable-hooks ()
(setf uiop:*image-restore-hook* (remove 'compute-clpm-executable uiop:*image-restore-hook*))
(setf uiop:*image-dump-hook* (remove 'clear-clpm-executable uiop:*image-dump-hook*)))
(register-clpm-cleanup-hook 'clear-clpm-executable-hooks)
(defun ensure-list (arg)
(if (listp arg)
arg
(list arg)))
(defun run-clpm (command &rest args &key ignore-error-status &allow-other-keys)
"Run CLPM with ~command~. ~args~ are passed directly to ~uiop:run-program~."
(multiple-value-bind (out err-out code)
(apply #'run-program
(list* *clpm-executable* command)
(append (ensure-list *clpm-executable*) command)
:ignore-error-status t
:error-output '(:string :stripped t)
args)
(when *clpm-dribble*
(with-input-from-string (s err-out)
(uiop:copy-stream-to-stream s *clpm-dribble* :linewise t :prefix *clpm-dribble-prefix*)))
(unless (or ignore-error-status (zerop code))
(error 'clpm-condition :error-output err-out :code code))
(values out err-out code)))
(defun launch-clpm (command &rest args &key &allow-other-keys)
"Launch CLPM with ~command~. ~args~ are passed directly to ~uiop:launch-program~."
(apply #'launch-program
(append (ensure-list *clpm-executable*) command)
args))
;;;; CLPM Context
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm-client/context
(:use #:cl
#:clpm-client/clpm)
(:export #:*clpm-context*
#:clpm-context-asd-directories
#:clpm-context-asd-pathnames
#:clpm-context-find-system))
(in-package #:clpm-client/context)
(defvar *clpm-context* "default"
"The context to operate in when not operating in a bundle.")
(defun clpm-context-asd-pathnames (&optional (context *clpm-context*))
"Given a context name, return a list of pathnames to .asd files installed in
that context."
(let ((pathnames-string (ignore-errors
(run-clpm `("context" "pathnames" "--output=sexp" ,context)
:output '(:string :stripped t)))))
(when pathnames-string
(uiop:with-safe-io-syntax () (read-from-string pathnames-string)))))
(defun clpm-context-asd-directories (&optional (context *clpm-context*))
"Return the directories containing the .asd files installed in CONTEXT."
(remove-duplicates (mapcar #'pathname-directory (clpm-context-asd-pathnames context))
:test #'uiop:pathname-equal))
(defun clpm-context-find-system (system-name &key (context *clpm-context*))
"Find the pathname to a system in the given context."
(multiple-value-bind (output error-output code)
(run-clpm `("context" "find"
"--context" ,context
"--output=sexp"
,system-name)
:output '(:string :stripped t)
:ignore-error-status t)
(declare (ignore error-output))