indexes.lisp

;;;; indexes.lisp

(in-package #:quicklisp-controller)

(defvar *index-file-format-version* 27)
(defparameter *s3-bucket* "beta.quicklisp.org")
(defparameter *system-file-header*
  "# project system-file system-name [dependency1..dependencyN]")

(defun slashed-system-p (system-name)
  (position #\/ system-name))

(defun unslashify-system-name (system-name)
  (let ((slash (position #\/ system-name)))
    (if slash
        (subseq system-name 0 slash)
        system-name)))

(defun cleanse-dependencies (system-name dependencies)
  (let ((unslashed (mapcar 'unslashify-system-name dependencies)))
    (remove system-name unslashed :test 'string=)))

(defun find-resolved-winning-systems (source)
  "Like FIND-WINNING-SYSTEMS, but each dependency with a slash is
replaced by the dependencies of that slashed system, recursively."
  (let* ((winners (find-winning-systems source))
         (required (make-string-table)))
    (labels ((required (system)
               (gethash system required))
             (knownp (system)
               (nth-value 1 (gethash (unslashify-system-name system)
                                     required)))
             (resolve (system)
               (if (slashed-system-p system)
                   (if (knownp system)
                       (mapcar #'resolve (required system))
                       (unslashify-system-name system))
                   system))
             (resolve-one (system)
               (remove-duplicates
                (alexandria:flatten (mapcar #'resolve (required system)))
                :test 'equal)))
      (loop for (nil system-name . required-systems) in winners
            do (setf (gethash system-name required) required-systems))
      (loop for (system-file system-name . nil) in winners
            collect (list* system-file system-name (resolve-one system-name))))))

(defun write-system-index (file)
  (with-open-file (stream file :direction :output
                          :if-exists :supersede)
    (format stream "~A~%" *system-file-header*)
    (map-sources
     (lambda (source)
       (let ((winners (find-resolved-winning-systems source)))
         (when winners
           (dolist (winner winners)
             (destructuring-bind (system-file system-name &rest dependencies)
                 winner
               (setf dependencies (cleanse-dependencies system-name
                                                        dependencies))
               (format stream "~A ~A ~A~{ ~A~}~%"
                       (project-name source)
                       system-file
                       system-name
                       (sort (copy-list dependencies) #'string<))))))))))

(defun write-release-index (file)
  (with-open-file (stream file :direction :output
                          :if-exists :supersede)
    (flet ((trim-prefix (file)
             (subseq file (1+ (position #\/ file)))))
      (format stream "# project url size file-md5 content-sha1 prefix ~
                      [system-file1..system-fileN]~%")
      (map-sources
       (lambda (source)
         (when (find-winning-systems source)
           (let* ((tarball (ensure-cached-release-tarball source))
                  (prefix (pathname-name tarball))
                  (project-name (project-name source))
                  (system-files (mapcar #'trim-prefix
                                        (winning-system-files source))))
             (format stream "~A http://~A/archive/~A/~A/~A ~A ~D ~A ~A~{ ~A~}~%"
                     project-name
                     *s3-bucket*
                     project-name
                     (dist-string (file-write-date tarball))
                     (file-namestring tarball)
                     (file-size tarball)
                     (file-md5 tarball)
                     (first (last (pathname-directory tarball)))
                     prefix
                     system-files))))))))

(defun s3-already-exists-p (content-sha1 bucket key)
  "If an object already exists in S3 with the given SHA1, return
true. If there's a SHA1 mismatch, signal an error."
  (multiple-value-bind (headers status-code)
      (zs3:head :bucket bucket :key key)
    (let ((s3-content-sha1 (cdr (assoc :x-amz-meta-content-sha1 headers))))
      (cond ((not (<= 200 status-code 299))
             nil)
            ((string= s3-content-sha1 content-sha1)
             t)
            (t
             (error "~A ~A exists but does not match sha1"
                    bucket key))))))

(defun upload-release-files ()
  (map-sources
   (lambda (source)
     (when (find-winning-systems source)
       (format *trace-output* "~&; uploading ~A~%" source)
       (let* ((tarball (ensure-cached-release-tarball source))
              (content-sha1 (first (last (pathname-directory tarball))))
              (key (format nil "archive/~A/~A/~A"
                           (project-name source)
                           (dist-string (file-write-date tarball))
                           (file-namestring tarball))))
         (unless (s3-already-exists-p content-sha1 *s3-bucket* key)
           (zs3:put-file tarball *s3-bucket* key :public t
                         :metadata (zs3:parameters-alist :content-sha1
                                                         content-sha1))))))))

(defun put-index-file (index-file)
  (let ((key (format nil "~A/~A/~A"
                     (pathname-name index-file)
                     (dist-string (file-write-date index-file))
                     (file-namestring index-file))))
    (zs3:put-file index-file *s3-bucket* key :public t :content-type "text/plain")))

(defun put-bootstrap-file (bootstrap-file)
  (put-index-file bootstrap-file)
  (zs3:put-file bootstrap-file "b.quicklisp.org"
                (file-namestring bootstrap-file)
                :public t
                :content-type "text/plain"))


(defclass distinfo ()
  ((name
    :initarg :name
    :accessor name)
   (version
    :initarg :version
    :accessor version)))

(defmethod print-object ((distinfo distinfo) stream)
  (print-unreadable-object (distinfo stream :type t)
    (format stream "~A ~A"
            (name distinfo)
            (version distinfo))))

(defun make-distinfo (name version)
  (make-instance 'distinfo :name name :version version))

(defgeneric archive-base-url (distinfo)
  (:method (distinfo)
    (format nil "http://beta.quicklisp.org/")))

(defgeneric system-index-key (distinfo)
  (:method (distinfo)
    (format nil "dist/~A/~A/systems.txt"
            (name distinfo)
            (version distinfo))))

(defgeneric release-index-key (distinfo)
  (:method (distinfo)
    (format nil "dist/~A/~A/releases.txt"
            (name distinfo)
            (version distinfo))))

(defgeneric system-index-url (distinfo)
  (:method (distinfo)
    (format nil "~A~A"
            (archive-base-url distinfo)
            (system-index-key distinfo))))

(defgeneric release-index-url (distinfo)
  (:method (distinfo)
    (format nil "~A~A"
            (archive-base-url distinfo)
            (release-index-key distinfo))))



(defgeneric distinfo-subscription-url (distinfo)
  (:method (distinfo)
    (format nil "http://~A/dist/~A.txt"
            *s3-bucket*
            (name distinfo))))

(defgeneric canonical-distinfo-key (distinfo)
  (:method (distinfo)
    (format nil "dist/~A/~A/distinfo.txt"
            (name distinfo)
            (version distinfo))))

(defgeneric canonical-distinfo-url (distinfo)
  (:method (distinfo)
    (format nil "~A~A"
            (archive-base-url distinfo)
            (canonical-distinfo-key distinfo))))

(defgeneric write-distinfo (distinfo file)
  (:method (distinfo file)
    (with-open-file (stream file :direction :output
                            :if-exists :supersede)
      (flet ((store (name value)
               (format stream "~A: ~A~%" name value)))
        (store "name" (name distinfo))
        (store "version" (version distinfo))
        (store "system-index-url" (system-index-url distinfo))
        (store "release-index-url" (release-index-url distinfo))
        (store "archive-base-url" (archive-base-url distinfo))
        (store "canonical-distinfo-url" (canonical-distinfo-url distinfo))
        (store "distinfo-subscription-url"
               (distinfo-subscription-url distinfo))))))

(defun file-sha256 (file)
  (string-downcase
   (ironclad:byte-array-to-hex-string
    (ironclad:digest-file :sha256 file))))

(defun write-release-digests (dist output-file)
  (with-open-file (stream output-file :direction :output)
    (format stream "# key sha256~%")
    (dolist (release (provided-releases dist))
      (let* ((file (ql-dist:local-archive-file release))
	     (sha256 (file-sha256 file)))
	(format stream "release/~A ~A~%"
		(ql-dist:name release)
		sha256))))
  (probe-file output-file))

(defun upload-distinfo (distinfo)
  (let ((sysindex #p"quicklisp-controller:tmp;systems.txt")
        (relindex #p"quicklisp-controller:tmp;releases.txt")
        (distfile #p"quicklisp-controller:tmp;distinfo.txt")
        (primary-key (format nil "dist/~A.txt" (name distinfo))))
    (write-system-index sysindex)
    (write-release-index relindex)
    (write-distinfo distinfo distfile)
    (flet ((put (file bucket key)
             (zs3:put-file file bucket key :public t :content-type "text/plain")))
      (put distfile "beta.quicklisp.org" primary-key)
      (invalidate-quickstart-paths (list primary-key))
      (put distfile *s3-bucket* (canonical-distinfo-key distinfo))
      (put sysindex *s3-bucket* (system-index-key distinfo))
      (put relindex *s3-bucket* (release-index-key distinfo)))))


(defun make-mock-dist (name version directory)
  (let ((distinfo (make-distinfo name version))
        (*default-pathname-defaults* (pathname directory)))
    (ensure-directories-exist *default-pathname-defaults*)
    (open "enabled.txt" :direction :probe :if-does-not-exist :create)
    (write-system-index "systems.txt")
    (write-release-index "releases.txt")
    (write-distinfo distinfo "distinfo.txt")
    (ensure-directories-exist #p"archives/")
    (map-sources
     (lambda (source)
       (let ((tarball (ensure-cached-release-tarball source)))
         (copy tarball #p"archives/"))))
    (write-release-digests (dist name) "digests.txt")))

(defun mail-mock-report ()
  (if *report-to-email*
      (with-output-to-mail (*standard-output* :to *report-to-email*
                                              :from *report-to-email*
                                              :subject "Quicklisp Mock Report Results")
        (mock-report :build nil :mail nil))
      (warn "~S unset, cowardly refusing to email any report"
            '*report-to-email*)))

(defun mock-report (&key (build t) (mail nil))
  (with-system-index
    (with-skipping
      (when build
        (let ((target-directory (ql-setup:qmerge "dists/mock/")))
          (run "rm" "-rf" target-directory)
          (make-mock-dist "mock" "9999-99-99" target-directory)))
      (flet ((projects (dist)
	       (mapcar 'name (provided-releases (ql-dist:find-dist dist)))))
	(let ((ql-projects (projects "quicklisp"))
	      (mock-projects (projects "mock")))
	  (let ((new-projects (set-difference mock-projects ql-projects
					      :test 'string=))
		(removed-projects (set-difference ql-projects mock-projects
						  :test 'string=)))
	    (format t "New:~%~{  ~A~%~}~%" new-projects)
	    (format t "Removed: ~%~{  ~A~%~}~%" removed-projects)))
	(multiple-value-bind (new-systems removed-systems)
	    (system-differences "quicklisp" "mock")
	  (format t "New systems:~%  ~S~%" new-systems)
	  (terpri)
	  (format t "Removed systems:~%  ~S" removed-systems))
	(sanity-check-report "mock"))))
  (when mail
    (mail-mock-report)))

(defun system-differences (old-dist new-dist)
  "Report on the systems that differ between old-dist and new-dist."
  (flet ((dist-table (dist)
           (let ((table (make-hash-table :test 'equalp)))
             (dolist (system (ql-dist:provided-systems (ql-dist:dist dist)))
               (setf (gethash (ql-dist:name system) table) system))
             table)))
    (let ((old-table (dist-table old-dist))
          (new-table (dist-table new-dist))
          (added '())
          (removed '()))
      (maphash (lambda (key system)
                 (declare (ignore system))
                 (if (gethash key old-table)
                     (remhash key old-table)
                     (push key added)))
               new-table)
      (maphash (lambda (key system)
                 (declare (ignore system))
                 (push key removed))
               old-table)
      (values added
              (mapcar (=system-from-release old-dist)
                      removed)))))

(defun newly-removed-releases ()
  (let ((removed (nth-value 1 (system-differences "quicklisp" "mock"))))
    (remove-duplicates
     (mapcar (lambda (removed)
	       ;; Either "project" or ("system" :from "project") syntax
	       (if (consp removed)
		   (third removed)
		   removed))
	     removed)
     :test 'equalp)))

(defun dist-differences (old-dist new-dist &key enumerator)
  "Report on the systems that differ between old-dist and new-dist."
  (flet ((dist-table (dist)
           (let ((table (make-hash-table :test 'equalp)))
             (dolist (object (funcall enumerator (ql-dist:dist dist)))
               (setf (gethash (ql-dist:name object) table) object))
             table)))
    (let ((old-table (dist-table old-dist))
          (new-table (dist-table new-dist))
          (added '())
          (removed '()))
      (maphash (lambda (key object)
                 (declare (ignore object))
                 (if (gethash key old-table)
                     (remhash key old-table)
                     (push key added)))
               new-table)
      (maphash (lambda (key object)
                 (declare (ignore object))
                 (push key removed))
               old-table)
      (values added removed))))