asdf-install.installer.lisp Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of abcl-contrib Show documentation
Show all versions of abcl-contrib Show documentation
Extra packages--contribs--for ABCL
The newest version!
(in-package #:asdf-install)
(pushnew :asdf-install *features*)
(defun installer-msg (stream format-control &rest format-arguments)
(apply #'format stream "~&;;; ASDF-INSTALL: ~@?~%"
format-control format-arguments))
(defun verify-gpg-signatures-p (url)
(labels ((prefixp (prefix string)
(let ((m (mismatch prefix string)))
(or (not m) (>= m (length prefix))))))
(case *verify-gpg-signatures*
((nil) nil)
((:unknown-locations)
(notany
(lambda (x) (prefixp x url))
*safe-url-prefixes*))
(t t))))
(defun same-central-registry-entry-p (a b)
(flet ((ensure-string (x)
(typecase x
(string x)
(pathname (namestring (translate-logical-pathname x)))
(t nil))))
(and (setf a (ensure-string a))
(setf b (ensure-string b))
a b (string-equal a b))))
(defun add-registry-location (location)
(let ((location-directory (pathname-sans-name+type location)))
#+asdf
(pushnew location-directory
asdf:*central-registry*
:test #'same-central-registry-entry-p)
#+mk-defsystem
(mk:add-registry-location location-directory)))
;;; Fixing the handling of *LOCATIONS*
(defun add-locations (loc-name site system-site)
(declare (type string loc-name)
(type pathname site system-site))
#+asdf
(progn
(pushnew site asdf:*central-registry* :test #'equal)
(pushnew system-site asdf:*central-registry* :test #'equal))
#+mk-defsystem
(progn
(mk:add-registry-location site)
(mk:add-registry-location system-site))
(setf *locations*
(append *locations* (list (list site system-site loc-name)))))
;;;---------------------------------------------------------------------------
;;; URL handling.
(defun url-host (url)
(assert (string-equal url "http://" :end1 7))
(let* ((port-start (position #\: url :start 7))
(host-end (min (or (position #\/ url :start 7) (length url))
(or port-start (length url)))))
(subseq url 7 host-end)))
(defun url-port (url)
(assert (string-equal url "http://" :end1 7))
(let ((port-start (position #\: url :start 7)))
(if port-start
(parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
; This is from Juri Pakaste's base64.lisp
(defparameter *encode-table*
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")
(defun base64-encode (string)
(let ((result (make-array
(list (* 4 (truncate (/ (+ 2 (length string)) 3))))
:element-type 'base-char)))
(do ((sidx 0 (+ sidx 3))
(didx 0 (+ didx 4))
(chars 2 2)
(value nil nil))
((>= sidx (length string)) t)
(setf value (ash (logand #xFF (char-code (char string sidx))) 8))
(dotimes (n 2)
(when (< (+ sidx n 1) (length string))
(setf value
(logior value
(logand #xFF (char-code (char string (+ sidx n 1))))))
(incf chars))
(when (= n 0)
(setf value (ash value 8))))
(setf (elt result (+ didx 3))
(elt *encode-table* (if (> chars 3) (logand value #x3F) 64)))
(setf value (ash value -6))
(setf (elt result (+ didx 2))
(elt *encode-table* (if (> chars 2) (logand value #x3F) 64)))
(setf value (ash value -6))
(setf (elt result (+ didx 1))
(elt *encode-table* (logand value #x3F)))
(setf value (ash value -6))
(setf (elt result didx)
(elt *encode-table* (logand value #x3F))))
result))
(defun request-uri (url)
(assert (string-equal url "http://" :end1 7))
(if *proxy*
url
(let ((path-start (position #\/ url :start 7)))
(assert (and path-start) nil "url does not specify a file.")
(subseq url path-start))))
(defun url-connection (url)
(let ((stream (make-stream-from-url (or *proxy* url)))
(host (url-host url)))
(format stream "GET ~A HTTP/1.0~C~CHost: ~A~C~CCookie: CCLAN-SITE=~A~C~C"
(request-uri url) #\Return #\Linefeed
host #\Return #\Linefeed
*cclan-mirror* #\Return #\Linefeed)
(when (and *proxy-passwd* *proxy-user*)
(format stream "Proxy-Authorization: Basic ~A~C~C"
(base64-encode (format nil "~A:~A" *proxy-user* *proxy-passwd*))
#\Return #\Linefeed))
(format stream "~C~C" #\Return #\Linefeed)
(force-output stream)
(list
(let* ((l (read-header-line stream))
(space (position #\Space l)))
(parse-integer l :start (1+ space) :junk-allowed t))
(loop for line = (read-header-line stream)
until (or (null line)
(zerop (length line))
(eql (elt line 0) (code-char 13)))
collect
(let ((colon (position #\: line)))
(cons (intern (string-upcase (subseq line 0 colon)) :keyword)
(string-trim (list #\Space (code-char 13))
(subseq line (1+ colon))))))
stream)))
(defun download-link-for-package (package-name-or-url)
(if (= (mismatch package-name-or-url "http://") 7)
package-name-or-url
(format nil "http://www.cliki.net/~A?download"
package-name-or-url)))
(defun download-link-for-signature (url)
(concatenate 'string url ".asc"))
;;; XXX unsightful hack
(defvar *dont-check-signature* nil)
(defun download-files-for-package (package-name-or-url)
(setf *dont-check-signature* nil)
(multiple-value-bind (package-url package-file)
(download-url-to-temporary-file
(download-link-for-package package-name-or-url))
(if (verify-gpg-signatures-p package-name-or-url)
(restart-case
(multiple-value-bind (signature-url signature-file)
(download-url-to-temporary-file
(download-link-for-signature package-url))
(declare (ignore signature-url))
(values package-file signature-file))
(skip-gpg-check ()
:report "Don't check GPG signature for this package"
(progn
(setf *dont-check-signature* t)
(values package-file nil))))
(values package-file nil))))
(defun verify-gpg-signature (file-name signature-name)
(block verify
(when (and (null signature-name) *dont-check-signature*)
(return-from verify t))
(loop
(restart-case
(let ((tags (gpg-results file-name signature-name)))
;; test that command returned something
(unless tags
(error 'gpg-shell-error))
;; test for obvious key/sig problems
(let ((errsig (header-value :errsig tags)))
(and errsig (error 'key-not-found :key-id errsig)))
(let ((badsig (header-value :badsig tags)))
(and badsig (error 'key-not-found :key-id badsig)))
(let* ((good (header-value :goodsig tags))
(id (first good))
(name (format nil "~{~A~^ ~}" (rest good))))
;; good signature, but perhaps not trusted
(restart-case
(let ((trusted? (or (header-pair :trust_ultimate tags)
(header-pair :trust_fully tags)))
(in-list? (assoc id *trusted-uids* :test #'equal)))
(cond ((or trusted? in-list?)
;; ok
)
((not trusted?)
(error 'key-not-trusted
:key-user-name name :key-id id))
((not in-list?)
(error 'author-not-trusted
:key-user-name name :key-id id))))
(add-key (&rest rest)
:report "Add to package supplier list"
(declare (ignore rest))
(pushnew (list id name) *trusted-uids*))))
(return-from verify t))
(install-anyways
(&rest rest)
:report "Don't check GPG signature for this package"
(declare (ignore rest))
(return-from verify t))
(retry-gpg-check
(&rest args)
:report "Retry GPG check \(e.g., after downloading the key\)"
(declare (ignore args))
nil)))))
(defun header-value (name headers)
"Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the value if name is found or nil if it is not."
(cdr (header-pair name headers)))
(defun header-pair (name headers)
"Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the \(name value\) pair if name is found or nil if it is not."
(assoc name headers
:test (lambda (a b)
(string-equal (symbol-name a) (symbol-name b)))))
(defun validate-preferred-location ()
(typecase *preferred-location*
(null t)
((integer 0)
(assert (<= 1 *preferred-location* (length *locations*))
(*preferred-location*)
'invalid-preferred-location-number-error
:preferred-location *preferred-location*))
((or symbol string)
(assert (find *preferred-location* *locations*
:test (if (typep *preferred-location* 'symbol)
#'eq #'string-equal) :key #'third)
(*preferred-location*)
'invalid-preferred-location-name-error
:preferred-location *preferred-location*))
(t
(assert nil
(*preferred-location*)
'invalid-preferred-location-error
:preferred-location *preferred-location*)))
*preferred-location*)
(defun select-location ()
(loop with n-locations = (length *locations*)
for response = (progn
(format t "Install where?~%")
(loop for (source system name) in *locations*
for i from 1
do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
i name system source))
(format t "0) Abort installation.~% --> ")
(force-output)
(read))
when (and (numberp response)
(<= 1 response n-locations))
return response
when (and (numberp response)
(zerop response))
do (abort (make-condition 'installation-abort))))
(defun install-location ()
(validate-preferred-location)
(let ((location-selection (or *preferred-location*
(select-location))))
(etypecase location-selection
(integer
(elt *locations* (1- location-selection)))
((or symbol string)
(find location-selection *locations* :key #'third
:test (if (typep location-selection 'string)
#'string-equal #'eq))))))
;;; install-package --
(defun find-shell-command (command)
(loop for directory in *shell-search-paths* do
(let ((target (make-pathname :name command :type nil
:directory directory)))
(when (probe-file target)
(return-from find-shell-command (namestring target)))))
(values nil))
(defun tar-command ()
#-(or :win32 :mswindows)
(find-shell-command *gnu-tar-program*)
#+(or :win32 :mswindows)
*cygwin-bash-program*)
(defun tar-arguments (source packagename)
#-(or :win32 :mswindows :scl)
(list "-C" (namestring (truename source))
"-xzvf" (namestring (truename packagename)))
#+(or :win32 :mswindows)
(list "-l"
"-c"
(format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
(namestring (truename source))
(namestring (truename packagename))))
#+scl
(list "-C" (ext:unix-namestring (truename source))
"-xzvf" (ext:unix-namestring (truename packagename))))
(defun extract-using-tar (to-dir tarball)
(let ((tar-command (tar-command)))
(if (and tar-command (probe-file tar-command))
(return-output-from-program tar-command
(tar-arguments to-dir tarball))
(warn "Cannot find tar command ~S." tar-command))))
(defun extract (to-dir tarball)
(or (some #'(lambda (extractor) (funcall extractor to-dir tarball))
*tar-extractors*)
(error "Unable to extract tarball ~A." tarball)))
(defun install-package (source system packagename)
"Returns a list of system names (ASDF or MK:DEFSYSTEM) for installed systems."
(ensure-directories-exist source)
(ensure-directories-exist system)
(let* ((tar (extract source packagename))
;; Some tar programs (OSX) list entries with preceeding "x "
;; as in "x entry/file.asd"
(pos-begin (if (string= (subseq tar 0 2) "x ")
2
0))
(pos-slash (or (position #\/ tar)
(position #\Return tar)
(position #\Linefeed tar)))
(*default-pathname-defaults*
(merge-pathnames
(make-pathname :directory
`(:relative ,(subseq tar pos-begin pos-slash)))
source)))
(loop for sysfile in (append
(directory
(make-pathname :defaults *default-pathname-defaults*
:name :wild
:type "asd"))
(directory
(make-pathname :defaults *default-pathname-defaults*
:name :wild
:type "system")))
do (maybe-symlink-sysfile system sysfile)
do (installer-msg t "Found system definition: ~A" sysfile)
do (maybe-update-central-registry sysfile)
collect sysfile)))
(defun maybe-update-central-registry (sysfile)
;; make sure that the systems we install are accessible in case
;; asdf-install:*locations* and asdf:*central-registry* are out
;; of sync
(add-registry-location sysfile))
(defun temp-file-name (p)
(declare (ignore p))
(let ((pathname nil))
(loop for i = 0 then (1+ i) do
(setf pathname
(merge-pathnames
(make-pathname
:name (format nil "asdf-install-~d" i)
:type "asdf-install-tmp")
*temporary-directory*))
(unless (probe-file pathname)
(return-from temp-file-name pathname)))))
;;; install
;;; This is the external entry point.
(defun install (packages &key (propagate nil) (where *preferred-location*))
(let* ((*preferred-location* where)
(*temporary-files* nil)
(trusted-uid-file
(merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))
(*trusted-uids*
(when (probe-file trusted-uid-file)
(with-open-file (f trusted-uid-file) (read f))))
(old-uids (copy-list *trusted-uids*))
#+asdf
(*defined-systems* (if propagate
(make-hash-table :test 'equal)
*defined-systems*))
(packages (if (atom packages) (list packages) packages))
(*propagate-installation* propagate)
(*systems-installed-this-time* nil))
(unwind-protect
(destructuring-bind (source system name) (install-location)
(declare (ignore name))
(labels
((one-iter (packages)
(let ((packages-to-install nil))
(loop for p in (mapcar #'string packages) do
(cond ((local-archive-p p)
(setf packages-to-install
(append packages-to-install
(install-package source system p))))
(t
(multiple-value-bind (package signature)
(download-files-for-package p)
(when (verify-gpg-signatures-p p)
(verify-gpg-signature package signature))
(installer-msg t "Installing ~A in ~A, ~A"
p source system)
(install-package source system package))
(setf packages-to-install
(append packages-to-install
(list p))))))
(dolist (package packages-to-install)
(setf package
(etypecase package
(symbol package)
(string (intern package :asdf-install))
(pathname (intern
(namestring (pathname-name package))
:asdf-install))))
(handler-bind
(
#+asdf
(asdf:missing-dependency
(lambda (c)
(installer-msg
t
"Downloading package ~A, required by ~A~%"
(asdf::missing-requires c)
(asdf:component-name
(asdf::missing-required-by c)))
(one-iter
(list (asdf::coerce-name
(asdf::missing-requires c))))
(invoke-restart 'retry)))
#+mk-defsystem
(make:missing-component
(lambda (c)
(installer-msg
t
"Downloading package ~A, required by ~A~%"
(make:missing-component-name c)
package)
(one-iter (list (make:missing-component-name c)))
(invoke-restart 'retry))))
(loop (multiple-value-bind (ret restart-p)
(with-simple-restart
(retry "Retry installation")
(push package *systems-installed-this-time*)
(load-package package))
(declare (ignore ret))
(unless restart-p (return)))))))))
(one-iter packages)))
;;; cleanup
(unless (equal old-uids *trusted-uids*)
(let ((create-file-p nil))
(unless (probe-file trusted-uid-file)
(installer-msg t "Trusted UID file ~A does not exist"
(namestring trusted-uid-file))
(setf create-file-p
(y-or-n-p "Do you want to create the file?")))
(when (or create-file-p (probe-file trusted-uid-file))
(ensure-directories-exist trusted-uid-file)
(with-open-file (out trusted-uid-file
:direction :output
:if-exists :supersede)
(with-standard-io-syntax
(prin1 *trusted-uids* out))))))
(dolist (l *temporary-files* t)
(when (probe-file l) (delete-file l))))
(nreverse *systems-installed-this-time*)))
(defun local-archive-p (package)
#+(or :sbcl :allegro) (probe-file package)
#-(or :sbcl :allegro) (and (/= (mismatch package "http://") 7)
(probe-file package)))
(defun load-package (package)
#+asdf
(progn
(installer-msg t "Loading system ~S via ASDF." package)
(asdf:operate 'asdf:load-op package))
#+mk-defsystem
(progn
(installer-msg t "Loading system ~S via MK:DEFSYSTEM." package)
(mk:load-system package)))
;;; uninstall --
(defun uninstall (system &optional (prompt t))
#+asdf
(let* ((asd (asdf:system-definition-pathname system))
(system (asdf:find-system system))
(dir (pathname-sans-name+type
(asdf::resolve-symlinks asd))))
(when (or (not prompt)
(y-or-n-p
"Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
system asd dir))
#-(or :win32 :mswindows)
(delete-file asd)
(let ((dir (#-scl namestring #+scl ext:unix-namestring (truename dir))))
(when dir
(asdf:run-shell-command "rm -r '~A'" dir)))))
#+mk-defsystem
(multiple-value-bind (sysfile sysfile-exists-p)
(mk:system-definition-pathname system)
(when sysfile-exists-p
(let ((system (ignore-errors (mk:find-system system :error))))
(when system
(when (or (not prompt)
(y-or-n-p
"Delete system ~A.~%system file: ~A~%Are you sure?"
system
sysfile))
(mk:clean-system system)
(delete-file sysfile)
(dolist (f (mk:files-in-system system))
(delete-file f)))
))
)))
;;; some day we will also do UPGRADE, but we need to sort out version
;;; numbering a bit better first
#+(and :asdf (or :win32 :mswindows))
(defun sysdef-source-dir-search (system)
(let ((name (asdf::coerce-name system)))
(dolist (location *locations*)
(let* ((dir (first location))
(files (directory (merge-pathnames
(make-pathname :name name
:type "asd"
:version :newest
:directory '(:relative :wild)
:host nil
:device nil)
dir))))
(dolist (file files)
(when (probe-file file)
(return-from sysdef-source-dir-search file)))))))
(defmethod asdf:find-component :around
((module (eql nil)) name)
(when (or (not *propagate-installation*)
(member name *systems-installed-this-time*
:test (lambda (a b)
(flet ((ensure-string (x)
(etypecase x
(symbol (symbol-name x))
(string x))))
(string-equal (ensure-string a) (ensure-string b))))))
(call-next-method)))
(defun show-version-information ()
(let ((version (asdf-install-version)))
(if version
(format *standard-output* "~&;;; ASDF-Install version ~A"
version)
(format *standard-output* "~&;;; ASDF-Install version unknown; unable to find ASDF system definition."))
(values)))
(defun asdf-install-version ()
"Returns the ASDf-Install version information as a string or nil if it cannot be determined."
(let ((system (asdf:find-system 'asdf-install)))
(when system (asdf:component-version system))))
;; load customizations if any
(eval-when (:load-toplevel :execute)
(let* ((*package* (find-package :asdf-install-customize))
(file (probe-file (merge-pathnames
(make-pathname :name ".asdf-install")
(truename (user-homedir-pathname))))))
(when file (load file))))
;;; end of file -- install.lisp --
© 2015 - 2025 Weber Informatics LLC | Privacy Policy