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

Rewrite resolver.

Groveler management is now more explicit.
parent aaa2460c
......@@ -4,9 +4,14 @@
;;;; LICENSE for license information.
(uiop:define-package #:clpm-deps/main
(:use #:cl)
(:nicknames #:clpm-deps)
(:use #:cl)
(:import-from #:uiop
#:pathname-equal))
#:pathname-equal)
(:export #:determine-systems-from-file
#:safe-load-asd
#:start-rel
#:system-direct-deps))
(in-package #:clpm-deps/main)
......@@ -85,3 +90,12 @@ if an unknown error occurred, the third is a missing system."
(system-source-file (asdf:system-source-file system)))
(pathname-equal asd-pathname system-source-file)))
(asdf:registered-systems)))
(defun start-rel ()
"Some lisp's like to always print a prompt at their REPL. To avoid needing to
handle skipping this prompt when READ'ing the groveler's output, we run our own
REL (READ EVAL LOOP) instead. All prints must be explcit."
(loop
(let ((input (read)))
(eval input)
(finish-output))))
"0.0.1"
\ No newline at end of file
"0.0.2"
\ No newline at end of file
......@@ -31,43 +31,10 @@
*bundle-arguments*
*common-arguments*))
(defun ensure-vcs-req-installed-and-rewrite-req (req)
"Given a VCS requirement, install it and return a new requirement on the
correct commit."
(let* ((project-name (requirement/name req))
(branch (requirement/branch req))
(commit (requirement/commit req))
(tag (requirement/tag req))
(source (requirement/source req))
(vcs-project (source/project source project-name))
(vcs-release (project/release vcs-project
(cond
(commit
`(:commit ,commit))
(branch
`(:branch ,branch))
(tag
`(:tag ,tag))))))
(install-release vcs-release)
(make-instance 'vcs-project-requirement
:commit (vcs-release/commit vcs-release)
:repo (requirement/repo req)
:source (requirement/source req)
:name (requirement/name req)
:systems (requirement/systems req)
:system-files (requirement/system-files req))))
(defun build-lockfile (clpmfile)
"Given a clpmfile instance, make a lockfile instance for it."
(let* ((sources (clpmfile/sources clpmfile))
(raw-reqs (clpmfile/all-requirements clpmfile))
reqs)
;; Make sure all vcs releases are installed and replace their requirements
;; with a requirement on the commit.
(dolist (r raw-reqs)
(if (typep r 'vcs-requirement)
(push (ensure-vcs-req-installed-and-rewrite-req r) reqs)
(push r reqs)))
(reqs (clpmfile/all-requirements clpmfile)))
;; Resolve the requirements!
(multiple-value-bind (releases-to-install system-releases)
......
......@@ -31,45 +31,12 @@
*bundle-arguments*
*common-arguments*))
(defun ensure-vcs-req-installed-and-rewrite-req (req)
"Given a VCS requirement, install it and return a new requirement on the
correct commit."
(let* ((project-name (requirement/name req))
(branch (requirement/branch req))
(commit (requirement/commit req))
(tag (requirement/tag req))
(source (requirement/source req))
(vcs-project (source/project source project-name))
(vcs-release (project/release vcs-project
(cond
(commit
`(:commit ,commit))
(branch
`(:branch ,branch))
(tag
`(:tag ,tag))))))
(install-release vcs-release)
(make-instance 'vcs-project-requirement
:commit (vcs-release/commit vcs-release)
:repo (requirement/repo req)
:source (requirement/source req)
:name (requirement/name req)
:systems (requirement/systems req)
:system-files (requirement/system-files req))))
(defun build-lockfile (clpmfile)
"Given a clpmfile instance, make a lockfile instance for it."
(let* ((sources (clpmfile/sources clpmfile))
(user-global-sources (clpmfile/user-global-sources clpmfile))
(raw-reqs (clpmfile/all-requirements clpmfile))
reqs)
(reqs (clpmfile/all-requirements clpmfile)))
(mapc #'sync-source user-global-sources)
;; Make sure all git releases are installed and replace their requirements
;; with a requirement on the commit.
(dolist (r raw-reqs)
(if (typep r 'vcs-requirement)
(push (ensure-vcs-req-installed-and-rewrite-req r) reqs)
(push r reqs)))
;; Resolve the requirements!
(multiple-value-bind (releases-to-install system-releases)
......
......@@ -9,6 +9,7 @@
#:clpm/cli/client
#:clpm/cli/config
#:clpm/cli/entry
#:clpm/cli/grovel
#:clpm/cli/install
#:clpm/cli/license-info
#:clpm/cli/sync))
......
......@@ -170,6 +170,16 @@ or raise an error if it does not exist."
(second version)))))
(push req (clpmfile/user-requirements clpmfile))))
(defun parse-project-statement (clpmfile name
&key source branch)
(push (make-instance 'vcs-project-requirement
:name (string-downcase (string name))
:source (when source
(find-source-or-error (clpmfile/user-global-sources clpmfile)
source))
:branch branch)
(clpmfile/user-requirements clpmfile)))
(defun parse-system-statement (clpmfile name &key source)
"Parse a ~:system~ statement from a ~clpmfile~ into a ~system-requirement~
instance."
......@@ -229,10 +239,10 @@ sources."
(error "The first form must be a list"))
(unless (eql :api-version (first (first forms)))
(error "The first form must specify the api version"))
(unless (equal '(:api-version "0.1") (first forms))
(error "This only supports api version 0.1"))
(unless (equal '(:api-version "0.2") (first forms))
(error "This only supports api version 0.2"))
(pop forms)
;; Now that we know we're using api version 0.1, let's make sure everything
;; Now that we know we're using api version 0.2, let's make sure everything
;; left is a list.
(unless (every #'listp forms)
(error "Every form must be a list."))
......@@ -255,6 +265,8 @@ sources."
(apply #'parse-gitlab-statement clpmfile args))
(:system
(apply #'parse-system-statement clpmfile args))
(:project
(apply #'parse-project-statement clpmfile args))
(:req
(apply #'parse-req-statement clpmfile args))
(:asd
......@@ -314,10 +326,10 @@ sources."
(error "The first form must be a list"))
(unless (eql :api-version (first (first forms)))
(error "The first form must specify the api version"))
(unless (equal '(:api-version "0.1") (first forms))
(error "This version of CLPM only supports api version 0.1"))
(unless (equal '(:api-version "0.2") (first forms))
(error "This version of CLPM only supports api version 0.2"))
(pop forms)
;; Now that we know we're using API version 0.1, let's make sure everything
;; Now that we know we're using API version 0.2, let's make sure everything
;; left is a list.
(unless (every #'listp forms)
(error "every form must be a list."))
......@@ -429,7 +441,7 @@ to a file."
(write-string ";;; -*- mode: common-lisp -*-" stream)
(terpri stream)
(write '(:api-version "0.1") :stream stream)
(write '(:api-version "0.2") :stream stream)
(terpri stream)
(write `(:user-global-sources ,@(mapcar #'source-to-form (clpmfile/user-global-sources clpmfile)))
......
;;;; Interface for using a groveler to determine .asd file contents and
;;;; dependencies as well as system dependencies.
;;;; Interface for caching the clpm-deps system, used to grovel system info
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
......@@ -7,22 +6,15 @@
(uiop:define-package #:clpm/deps
(:use #:cl
#:alexandria
#:anaphora
#:clpm/cache
#:clpm/config
#:clpm/sandbox
#:clpm/utils
#:exit-hooks)
(:export #:add-asd-and-retry
#:grovel-system-info
#:grovel-systems-in-file
#:groveler-dependency-missing
#:groveler-dependency-missing/system))
#:clpm/log)
(:export #:deps-asd-pathname
#:deps-version-string
#:ensure-deps-system-in-cache!))
(in-package #:clpm/deps)
(defvar *running-grovelers* (make-hash-table :test 'equal)
"Hash table that maps asd pathnames to running groveler processes.")
(setup-logger)
(defvar *deps-system* nil
"A string containing the contents of the groveler's clpm-deps.asd. Populated
......@@ -76,6 +68,13 @@ even if they exist.")
(setf *force-deps-cache-writing-p* nil))
(uiop:register-image-dump-hook 'unforce-cache-writing)
(defun deps-asd-pathname ()
"Return the pathname to the deps .asd file."
(clpm-cache-pathname
(list "deps-groveler-system"
(deps-version-string)
"clpm-deps.asd")))
(defun ensure-deps-system-in-cache! (&optional (forcep *force-deps-cache-writing-p*))
"Ensure the groveler source code is present in the cache. If ~forcep~ is
non-NIL, overwrite."
......@@ -106,202 +105,3 @@ non-NIL, overwrite."
(probe-file deps-version-pathname))
(with-open-file (s deps-version-pathname :direction :output :if-exists :supersede)
(print deps-version s)))))
(define-condition groveler-unknown-error ()
((backtrace
:initarg :backtrace
:reader groveler-unknown-error/backtrace))
(:report (lambda (c s)
(format s "Unknown error while groveling. Perhaps your asd file is malformed?~%Backtrace: ~A"
(groveler-unknown-error/backtrace c))))
(:documentation
"Condition signaled when the groveler encounters an unknown error."))
(define-condition groveler-dependency-missing ()
((system
:initarg :system
:reader groveler-dependency-missing/system))
(:report (lambda (c s)
(format s "Missing dependency: ~S" (groveler-dependency-missing/system c))))
(:documentation
"Condition signaled when the groveler cannot continue because of a missing
dependency."))
(defun sbcl-installed-p ()
(zerop (nth-value 2
(uiop:run-program '("sbcl" "--version")
:ignore-error-status t
:input nil
:output nil
:error-output nil))))
(defun ccl-installed-p ()
(zerop (nth-value 2
(uiop:run-program '("ccl" "--version")
:ignore-error-status t
:input nil
:output nil
:error-output nil))))
(defun launch-sub-lisp ()
"Start a SBCL or CCL process that does not load config files, has a disabled
debugger, and does not print things unless told. Set ASDF_OUTPUT_TRANSLATIONS
for process to confine build artifacts to CLPM's cache. Use
~sandbox-augment-command~ to run the child in a sandbox."
(let* ((cache-dir (clpm-cache-pathname '("deps-build")
:ensure-directory t))
(translations
(format nil
"(:output-translations :ignore-inherited-configuration (t (\"~A\" :implementation :**/ :*.*.*)))"
cache-dir)))
(ensure-directories-exist cache-dir)
(apply
#'uiop:launch-program
(sandbox-augment-command
(cond
((sbcl-installed-p)
`("sbcl"
"--noinform"
"--noprint"
"--no-sysinit"
"--no-userinit"
"--disable-debugger"))
((ccl-installed-p)
`("ccl"
"--batch"
"-Q"
"-n"))
(t
(error "SBCL or CCL must be installed")))
:read-write-pathnames (list cache-dir))
:input :stream
:output :stream
:error-output :interactive
(run-program-augment-env-args `(("ASDF_OUTPUT_TRANSLATIONS" . ,translations))))))
(defun start-grovel-process ()
"Start and return a process (using ~launch-sub-lisp~) that contains an
instance of SBCL or CCL with the groveling code loaded."
(ensure-deps-system-in-cache!)
(let* ((proc-info (launch-sub-lisp))
(in-stream (uiop:process-info-input proc-info))
(out-stream (uiop:process-info-output proc-info))
(asd-pathname (clpm-cache-pathname
(list "deps-groveler-system"
(deps-version-string)
"clpm-deps.asd"))))
(uiop:with-safe-io-syntax ()
(format in-stream "(progn (require :asdf) (values))~%")
;; Nuke any existing asdf configuration
(format in-stream "(progn (asdf:clear-configuration) (values))~%")
;; Make sure if ASDF reinitializes its configuration that it ignores
;; everything but the default (implementation specific) systems.
(format in-stream "(progn (setf asdf:*default-source-registries* nil) (values))~%")
(format in-stream "(progn (asdf:load-asd ~S) (values))~%" asd-pathname)
(format in-stream "(progn (asdf:load-system :clpm-deps) (values))~%")
(format in-stream "(progn (print \"ready\") (values))~%")
(format in-stream "(progn (finish-output) (values))~%")
(finish-output in-stream)
;; Wait until the process reports that it is ready.
(loop
:for val := (read out-stream)
:until (equal val "ready")))
proc-info))
(defun safe-load-asd-in-process (proc-info asd-pathname)
"Load the .asd file at ~asd-pathname~ into the ~proc-info~'s lisp process."
(let* ((in-stream (uiop:process-info-input proc-info))
(out-stream (uiop:process-info-output proc-info)))
(uiop:with-safe-io-syntax ()
(format in-stream "(progn (print (multiple-value-list (clpm-deps/main::safe-load-asd ~S))) (values))~%"
asd-pathname)
(format in-stream "(progn (finish-output) (values))~%")
(finish-output in-stream)
(values-list (read out-stream)))))
(defun determine-system-deps-in-process (proc-info system-name)
"Query and return a list of the dependencies of ~system-name~."
(let* ((in-stream (uiop:process-info-input proc-info))
(out-stream (uiop:process-info-output proc-info)))
(uiop:with-safe-io-syntax ()
(format in-stream "(progn (print (clpm-deps/main::system-direct-deps (asdf:find-system ~S))) (values))~%"
system-name)
(format in-stream "(progn (finish-output) (values))~%")
(finish-output in-stream)
(read out-stream))))
(defun determine-systems-from-file-in-process (proc-info system-pathname)
"Return a list of systems defined in the .asd file located at
~system-pathname~."
(let* ((in-stream (uiop:process-info-input proc-info))
(out-stream (uiop:process-info-output proc-info)))
(uiop:with-safe-io-syntax ()
(format in-stream "(progn (print (clpm-deps/main::determine-systems-from-file ~S)) (values))~%"
system-pathname)
(format in-stream "(progn (finish-output) (values))~%")
(finish-output in-stream)
(read out-stream))))
(defun ensure-process-ready! (proc-info asd-pathname dependency-asd-files)
"Ensures that the process has asd-pathname successfully loaded. Establishes a
~add-asd-and-retry~ restart."
(tagbody
start
(dolist (file (append dependency-asd-files (list asd-pathname)))
(multiple-value-bind (success-p unknown-error-backtrace missing-system)
(safe-load-asd-in-process proc-info file)
(unless success-p
(when unknown-error-backtrace
;; Uh-oh something happened that we don't know how to recover from
;; here. First, kill the process, then signal an error.
(kill-groveler-process! proc-info asd-pathname)
(error 'groveler-unknown-error
:backtrace unknown-error-backtrace))
;; We can provide a way to recover from this!
(restart-case
(error 'groveler-dependency-missing :system missing-system)
(add-asd-and-retry (asd)
:report "Add an asd file to preload and try again."
:interactive read-asd-path
(push asd dependency-asd-files)
(go start))))))))
(defun kill-groveler-process! (proc-info asd-file)
"Terminate the sublisp."
(when (uiop:process-alive-p proc-info)
(uiop:terminate-process proc-info :urgent t))
(remhash (truename asd-file) *running-grovelers*)
(uiop:wait-process proc-info))
(defun kill-groveler-process-for-file! (asd-file)
"Kill the groveler process associated with ~asd-file~."
(when-let ((proc-info (gethash (truename asd-file) *running-grovelers*)))
(kill-groveler-process! proc-info asd-file)))
(defun get-groveler-process (asd-file dependency-asd-files)
"Get the groveler process that has asd-file loaded and ready to be queried."
(ensure-gethash (truename asd-file) *running-grovelers*
(aprog1 (start-grovel-process)
(ensure-process-ready! it asd-file dependency-asd-files))))
(defun grovel-system-info (asd-file system-name)
"Grovel for the dependencies of ~system-name~ in ~asd-file~."
(determine-system-deps-in-process (get-groveler-process asd-file nil) system-name))
(defun grovel-systems-in-file (asd-file)
"Grovel for the systems defined in ~asd-file~."
(determine-systems-from-file-in-process (get-groveler-process asd-file nil)
(uiop:truename* asd-file)))
(defun exit-hook ()
"Terminates all groveler processes."
(maphash-keys (lambda (k)
(kill-groveler-process-for-file! k))
*running-grovelers*))
(add-exit-hook 'exit-hook)
(defun read-asd-path ()
(format t "Enter a path to an asd file (not evaluated): ")
(list (read-line)))
;;;; Interface for using a groveler to determine .asd file contents and
;;;; dependencies as well as system dependencies.
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/groveler
(:use #:cl
#:alexandria
#:anaphora
#:clpm/cache
#:clpm/deps
#:clpm/log
#:clpm/sandbox
#:clpm/sublisp
#:clpm/utils
#:exit-hooks)
(:export #:*active-groveler*
#:add-asd-and-retry
#:active-groveler-ensure-asd-loaded!
#:active-groveler-load-asd!
#:active-groveler-system-deps
#:active-groveler-systems-in-file
#:groveler-dependency-missing
#:groveler-dependency-missing/system
#:groveler-load-asd!
#:groveler-loaded-asds
#:make-groveler))
(in-package #:clpm/groveler)
(setup-logger)
(defvar *active-groveler* nil)
(define-condition groveler-unknown-error ()
((backtrace
:initarg :backtrace
:reader groveler-unknown-error/backtrace))
(:report (lambda (c s)
(format s "Unknown error while groveling. Perhaps your asd file is malformed?~%Backtrace: ~A"
(groveler-unknown-error/backtrace c))))
(:documentation
"Condition signaled when the groveler encounters an unknown error."))
(define-condition groveler-dependency-missing ()
((system
:initarg :system
:reader groveler-dependency-missing/system))
(:report (lambda (c s)
(format s "Missing dependency: ~S" (groveler-dependency-missing/system c))))
(:documentation
"Condition signaled when the groveler cannot continue because of a missing
dependency."))
(defclass groveler ()
((sub-lisp
:initarg :sub-lisp
:reader groveler-sub-lisp)
(loaded-asds
:initform nil
:initarg :loaded-asds
:accessor groveler-loaded-asds)))
(defun make-groveler ()
(let* ((sub-lisp (launch-sub-lisp))
(%input (sub-lisp-input sub-lisp))
(input (make-broadcast-stream %input *standard-output*))
(output (sub-lisp-output sub-lisp))
(asd-pathname (deps-asd-pathname)))
(ensure-deps-system-in-cache!)
(uiop:with-safe-io-syntax ()
;; Load ASDF
(format input "(progn (require :asdf) (values))~%")
;; Nuke any existing ASDF configuration
(format input "(progn (asdf:clear-configuration) (values))~%")
;; Make sure if ASDF reinitializes its configuration that it ignores
;; everything but the default (implementation specific) systems.
(format input "(progn (setf asdf:*default-source-registries* nil) (values))~%")
;; Load the groveler
(format input "(progn (asdf:load-asd ~S) (values))~%" asd-pathname)
(format input "(progn (asdf:load-system :clpm-deps) (values))~%")
;; Start the groveler's REPL.
(format input "(progn (clpm-deps:start-rel) (values))~%")
(format input "(print \"clpm-deps ready\")~%")
(finish-output input)
;; Wait until the process reports that it is ready.
(loop
:for val := (read output)
:until (equal val "clpm-deps ready")))
(aprog1 (make-instance 'groveler
:sub-lisp sub-lisp)
(exit-hooks:add-exit-hook (lambda ()
(kill-groveler! it))))))
(defun kill-groveler! (groveler)
"Terminate the groveler's sublisp."
(when (sub-lisp-alive-p (groveler-sub-lisp groveler))
(stop-sub-lisp (groveler-sub-lisp groveler) :signal t :urgent t)))
(defun groveler-load-asd! (groveler asd-pathname)
"Load the .asd file at ~asd-pathname~ into the groveler's lisp process."
(let* ((sub-lisp (groveler-sub-lisp groveler))
(in-stream (sub-lisp-input sub-lisp))
(out-stream (sub-lisp-output sub-lisp))
(asd-pathname (uiop:ensure-absolute-pathname asd-pathname)))
(tagbody
start
(log:debug "Loading ~S into groveler" asd-pathname)
(uiop:with-safe-io-syntax ()
(format in-stream "(print (multiple-value-list (clpm-deps:safe-load-asd ~S))) ~%"
asd-pathname)
(format in-stream "(finish-output)~%")
(finish-output in-stream)
(multiple-value-bind (success-p unknown-error-backtrace missing-system)
(values-list (read out-stream))
(unless success-p
(when (or (null missing-system) unknown-error-backtrace)
;; Uh-oh, something happened that we don't know how to recover
;; from here. Signal an error!
(error 'groveler-unknown-error
:backtrace unknown-error-backtrace))
;; We can provide a way to recover from this!
(restart-case
(error 'groveler-dependency-missing :system missing-system)
(add-asd-and-retry (asd &optional callback)
:report
"Add an asd file to load and try again."
:interactive read-asd-path
(groveler-load-asd! groveler asd)
(when callback
(funcall callback))
(go start))))
(push (namestring asd-pathname) (groveler-loaded-asds groveler)))))
groveler))
(defun groveler-ensure-asd-loaded! (groveler asd-pathname)
(let ((asd-pathname (uiop:ensure-absolute-pathname asd-pathname)))
(unless (member (namestring asd-pathname) (groveler-loaded-asds groveler) :test #'equal)
(groveler-load-asd! groveler asd-pathname))))
(defun groveler-system-deps (groveler system-name)
"Query and return a list of the dependencies of ~system-name~."
(let* ((sub-lisp (groveler-sub-lisp groveler))
(in-stream (sub-lisp-input sub-lisp))
(out-stream (sub-lisp-output sub-lisp)))
(log:debug "Querying groveler for dependencies of ~S" system-name)
(uiop:with-safe-io-syntax ()
(format in-stream "(print (clpm-deps:system-direct-deps (asdf:find-system ~S)))~%"
system-name)
(format in-stream "(finish-output)~%")
(finish-output in-stream)
(read out-stream))))
(defun groveler-systems-in-file (groveler asd-pathname)
"Return a list of systems defined in the provided asd file."
(let* ((sub-lisp (groveler-sub-lisp groveler))
(in-stream (sub-lisp-input sub-lisp))
(out-stream (sub-lisp-output sub-lisp))
(asd-pathname (uiop:ensure-absolute-pathname asd-pathname)))
(log:debug "Querying groveler for systems in file ~S" asd-pathname)
(uiop:with-safe-io-syntax ()
(format in-stream "(print (clpm-deps:determine-systems-from-file ~S))~%"
asd-pathname)
(format in-stream "(finish-output)~%")
(finish-output in-stream)
(read out-stream))))