feature request: More precise source reference

[informatimago]

The information recorded and reported in the distributed system only includes the git repository (when the source is git). It would be nice if quicklisp recorded the commit hash of the code it fetched and distributes.

Eg. for hunchentoot, currently we have a label "latest-github-release" but this is meaningless. It would be more useful to have "fe7605a818409d756b72e50975c67d1497048b50".

? (quick-where-from :hunchentoot)

(:SYSTEM "hunchentoot" :DISTRIBUTION "quicklisp" :DIRECTORY #P"/Users/pjb/quicklisp/dists/quicklisp/software/hunchentoot-v1.3.0/" :WHERE-FROM ("latest-github-release" "https://github.com/edicl/hunchentoot.git")) 
NIL
? 

For other git repositories, having the url of the git repository (and the commit hash) would also be more useful.
eg. for cl-base64, "kmr-git" "cl-base64" are rather useless.
It would be more useful to have something like: "9d5a88ecfd67b28c1c2b3b3497f2237e37032691" "http://git.kpe.io/cl-base64.git"

? (quick-where-from :cl-base64)

(:SYSTEM "cl-base64" :DISTRIBUTION "quicklisp" :DIRECTORY #P"/Users/pjb/quicklisp/dists/quicklisp/software/cl-base64-20201016-git/" :WHERE-FROM ("kmr-git" "cl-base64")) 
NIL

If a specific branch or tag is fetched, this could also be added with the commit hash.

( with quick-where-from from https://github.com/informatimago/lisp/blob/master/tools/quicklisp.lisp )

(defconstant +one-month+ (* 30 24 60 60 ))
(defvar *projects-dir* nil)

(defun update-project-dir (&key force)
  (symbol-macrolet ((timestamp (sexp-file-contents (merge-pathnames "timestamp" *projects-dir*)
                                                   :if-does-not-exist 0)))
    (macrolet ((run-command-reporting-error (label command)
                 (let ((vout (gensym)) (verr (gensym)) (vstat (gensym)))
                   `(multiple-value-bind (,vout ,verr ,vstat)
                        (uiop:run-program ,command
                                          :ignore-error-status t :force-shell t
                                          :output 'string :error-output 'string)
                      (unless (zerop ,vstat)
                        (error "~A exited with status ~D:~%~A~%~A~%"
                               ,label ,vstat ,vout ,verr))))))
      (let* ((cache-dir   (merge-pathnames ".cache/" (user-homedir-pathname) nil))
             (project-dir (merge-pathnames "quicklisp-projects/" cache-dir nil))
             (probe       (merge-pathnames "README.md" project-dir nil)))
        (setf *projects-dir* project-dir)
        (unless (probe-file probe)
          (ensure-directories-exist probe)
          (run-command-reporting-error
           "git cloning quicklisp-project"
           (format nil "cd ~S && git clone git@github.com:quicklisp/quicklisp-projects.git" (namestring cache-dir)))
          (setf timestamp (get-universal-time))))
      (when (or force (< timestamp (- (get-universal-time) +one-month+)))
        (run-command-reporting-error
         "git pulling quicklisp-project"
         (format nil "cd ~S && git pull" (namestring *projects-dir*)))
        (setf timestamp (get-universal-time))))))

(defun project-where-from (pname)
  "Return the contents of the source.txt file of the project PNAME in quicklisp-projects."
  (update-project-dir)
  (split-string (string-trim #(#\newline)
                             (text-file-contents (merge-pathnames
                                                  (make-pathname :directory (list :relative "projects" pname)
                                                                 :name "source" :type "txt" :version nil)
                                                  *projects-dir*)
                                                 :if-does-not-exist nil))
                " " t))

(defun system-where-is (system)
  "Return the path where the SYSTEM is stored (where the asd file is found)."
  #+#.(cl:if (cl:find-symbol "WHERE-IS-SYSTEM" "QUICKLISP-CLIENT") '(:and) '(:or))
  (ql:where-is-system system)
  #-#.(cl:if (cl:find-symbol "WHERE-IS-SYSTEM" "QUICKLISP-CLIENT") '(:and) '(:or))
  nil)

(defun system-where-from (system)
  "Return a list indicating where the project in the release that provided the SYSTEM originated from.
This is the contents of the source.txt file of the project in quicklisp-projects."
  (let* ((system       (ql-dist:find-system system))
         (release      (ql-dist:release system))
         (distribution (ql-dist:dist    system))
         (dname        (and distribution
                            (ql-dist:name distribution)))
         (pname        (and release
                            (ql-dist:project-name release))))
    (cond
      ((null pname)
       '())
      ((equal dname "quicklisp")
       (project-where-from pname))
      (t
       '()))))

(defun quick-where-from (system &rest systems)
  "Says where the systems are from."
  (let ((local-systems (ql:list-local-systems)))
    (dolist (sys (cons system systems))
      (let ((sname (asdf-system-name (asdf:find-system sys))))
        (if (member sname local-systems :test (function string=))
            (print (list :system sname
                         :distribution :local
                         :directory (system-where-is sname)
                         :from nil #|TODO: we could look in the directory if there's a .git and show-remotes |#))
            (let* ((system       (ql-dist:find-system sname))
                   (release      (ql-dist:release system))
                   (distribution (ql-dist:dist    system))
                   (dname        (ql-dist:name distribution))
                   (pname        (and release
                                      (ql-dist:project-name release)))
                   (wfrom        (cond
                                   ((null pname)
                                    '())
                                   ((string= dname "quicklisp")
                                    (project-where-from pname))
                                   (t
                                    '()))))
              (print (list :system sname
                           :distribution dname
                           :directory (system-where-is sname)
                           :where-from wfrom))))))))