mirror of
https://github.com/roswell/roswell.git
synced 2026-09-10 07:16:17 -04:00
97 lines
4.4 KiB
Common Lisp
97 lines
4.4 KiB
Common Lisp
(roswell:include "util")
|
|
(in-package :roswell)
|
|
(defun asd-p (file)
|
|
(equal (pathname-type file) "asd"))
|
|
(setf *load* (acons 'asd-p 'asdf:load-asd (remove 'asd-p *load* :key 'first)))
|
|
(in-package :roswell.util)
|
|
(defun fetch-via-roswell (url file &key (follow-redirects t) quietly (maximum-redirects 10))
|
|
"Request URL and write the body of the response to FILE."
|
|
(declare (ignorable follow-redirects quietly maximum-redirects))
|
|
(download (ql-http::urlstring (ql-http:url url)) file
|
|
:verbose "2"
|
|
:output (if (find :abcl *features*)
|
|
:interactive
|
|
*standard-output*))
|
|
(values (make-instance 'ql-http::header :status 200)
|
|
(probe-file file)))
|
|
(dolist (x '("https" "http"))
|
|
(setf ql-http:*fetch-scheme-functions*
|
|
(acons x 'fetch-via-roswell
|
|
(remove x ql-http:*fetch-scheme-functions* :key 'first :test 'equal))))
|
|
(pushnew :quicklisp-support-https *features*)
|
|
|
|
(defun roswell-installed-system-name (system-name)
|
|
;; should return repo part of system-name.
|
|
;; "user/repo" "user/repo/branch" "git://bra/bra/bra/repo.git" "github://user/repo"
|
|
(if (find #\: system-name)
|
|
(values nil "not implemented yet");; TBD
|
|
(let ((beg (position #\/ system-name)))
|
|
(and beg (incf beg) (/= (length system-name) beg)
|
|
(subseq system-name beg (position #\/ system-name :start beg))))))
|
|
|
|
(defun roswell-installable-searcher (system-name)
|
|
(let ((name (roswell-installed-system-name system-name))
|
|
pname)
|
|
(and
|
|
name
|
|
(not (when (setf pname (read-call "asdf/find-system:primary-system-name" system-name))
|
|
(asdf:find-system pname nil)))
|
|
(prog1
|
|
(or (quicklisp-client:local-projects-searcher name)
|
|
(progn
|
|
(roswell:roswell `("install" ,system-name))
|
|
(quicklisp-client:register-local-projects)
|
|
(quicklisp-client:local-projects-searcher name))
|
|
(return-from roswell-installable-searcher)) ;;can't find.
|
|
(eval `(asdf:defsystem ,system-name :depends-on (,name)))))))
|
|
|
|
(unless (find 'roswell-installable-searcher asdf:*system-definition-search-functions*)
|
|
(setf asdf:*system-definition-search-functions*
|
|
(append asdf:*system-definition-search-functions* (list 'roswell-installable-searcher))))
|
|
|
|
(in-package #:ql-dist)
|
|
(let ((*error-output* (make-broadcast-stream)))
|
|
(when
|
|
(or
|
|
(loop for k in '(:win32 :windows :mswindows)
|
|
never (find k *features*))
|
|
(probe-file
|
|
(merge-pathnames
|
|
(format nil "impls/~A/windows/7za/9.20/7za.exe"
|
|
(roswell:roswell '("roswell-internal-use" "uname" "-m") :string
|
|
T))
|
|
(roswell.util:homedir))))
|
|
(defmethod install ((release release))
|
|
(let ((archive (ensure-local-archive-file release))
|
|
(output
|
|
(relative-to (dist release)
|
|
(make-pathname :directory (list :relative "software"))))
|
|
(tracking (install-metadata-file release)))
|
|
(ensure-directories-exist output)
|
|
(ensure-directories-exist tracking)
|
|
(roswell:roswell
|
|
`("roswell-internal-use" "tar" "-xf" ,archive "-C" ,output))
|
|
(ensure-directories-exist tracking)
|
|
(with-open-file
|
|
(stream tracking :direction :output :if-exists :supersede)
|
|
(write-line (qenough (base-directory release)) stream))
|
|
(let ((provided (provided-systems release)) (dist (dist release)))
|
|
(dolist (file (system-files release))
|
|
(let ((system (find-system-in-dist (pathname-name file) dist)))
|
|
(unless (member system provided)
|
|
(error
|
|
"FIND-SYSTEM-IN-DIST returned ~A but I expected one of ~A"
|
|
system provided))
|
|
(let ((system-tracking (install-metadata-file system))
|
|
(system-file
|
|
(merge-pathnames file (base-directory release))))
|
|
(ensure-directories-exist system-tracking)
|
|
(unless (probe-file system-file)
|
|
(error "release claims to have ~A, but I can't find it"
|
|
system-file))
|
|
(with-open-file
|
|
(stream system-tracking :direction :output :if-exists
|
|
:supersede)
|
|
(write-line (qenough system-file) stream))))))
|
|
release))))
|