branch: elpa-admin
commit 8f9126bfe718bc10c794cfd73c996373568ded4d
Merge: b3591656cf 4d031d6e6b
Author: Stefan Monnier <monn...@iro.umontreal.ca>
Commit: Stefan Monnier <monn...@iro.umontreal.ca>
Merge branch 'elpa-admin' of git+ssh://git.sv.gnu.org/srv/git/emacs/elpa
into elpa-admin
---
elpa-admin.el | 314 ++++++++++++++++++++++++++++++++++++++++++++++++++++------
1 file changed, 283 insertions(+), 31 deletions(-)
diff --git a/elpa-admin.el b/elpa-admin.el
index 21f0a649f3..c5a8e2676a 100644
--- a/elpa-admin.el
+++ b/elpa-admin.el
@@ -32,6 +32,8 @@
;;; Code:
(require 'cl-lib)
+(eval-when-compile (require 'map))
+(require 'xml)
(require 'lisp-mnt)
(require 'package)
@@ -40,9 +42,14 @@
"Subdirectory where the ELPA release files (tarballs, ...) will be placed.")
(defvar elpaa--devel-subdir "archive-devel/"
"Subdirectory where the ELPA bleeding edge files (tarballs, ...) will be
placed.")
+
+(defvar elpaa--wsl-stats-file "wsl-stats.eld"
+ "File where web-server access stats are kept.")
+
(defvar elpaa--name "NonGNU")
(defvar elpaa--gitrepo "emacs/nongnu.git")
(defvar elpaa--url "https://elpa.gnu.org/nongnu/";)
+(defvar elpaa--css-url "https://www.gnu.org/software/emacs/manual.css";)
(defvar elpaa--branch-prefix "elpa/")
(defvar elpaa--release-branch-prefix "elpa-release/")
@@ -727,6 +734,7 @@ auxiliary files unless TARBALL-ONLY is non-nil ."
(default-directory
(expand-file-name (file-name-directory tarball))))
(and (file-readable-p (format "%s-readme.txt" pkgname))
+ (file-readable-p (format "%s.xml" pkgname))
(file-readable-p (format "%s.html" pkgname))
(file-readable-p (format "%s.svg" pkgname))))))
(progn
@@ -870,7 +878,7 @@ auxiliary files unless TARBALL-ONLY is non-nil ."
(if revision-function
(* 60 60 24 365 2)))))
(let ((default-directory (expand-file-name destdir)))
- ;; This also creates <pkg>-readme.txt and <pkg>.svg.
+ ;; This also creates <pkg>.xml (atom feed), <pkg>-readme.txt and
<pkg>.svg.
(elpaa--html-make-pkg pkgdesc pkg-spec
`((,vers . ,(file-name-nondirectory tarball))
. ,oldtarballs)
@@ -1864,6 +1872,36 @@ arbitrary code."
))
(insert "</dd>\n"))))
+(defun elpaa--make-atom-feed (pkg pkg-spec srcdir files)
+ (let* ((name (symbol-name (car pkg)))
+ (path (if (string-match "\\`https?://[^/]+/\\(.*\\)" elpaa--url)
+ (match-string 1 elpaa--url)
+ (error "Failed to infer path from %S" elpaa--url)))
+ (metadata (elpaa--metadata srcdir pkg-spec))
+ (desc (nth 2 metadata)))
+ (with-temp-buffer
+ (elpaa--render-atom
+ (format "Update feed for %s" name)
+ (concat "/" path name ".xml")
+ (mapcan
+ (lambda (file)
+ (let ((version (car file)))
+ `(( :title ,(format "%s ELPA: Release of \"%s\", Version %s"
+ elpaa--name name version)
+ :time ,(file-attribute-modification-time
+ (file-attributes (cdr file)))
+ :path ,(format "%s%s.xml#v%s" path name version)
+ :content
+ ((p nil
+ ,(concat "Version " version " of package ")
+ (a ((href . ,(elpaa--default-url name))) ,name)
+ ,(concat " has just been released in " elpaa--name "
ELPA."))
+ (p nil "You can now find it in " (kbd nil "M-x list-packages
RET") ".")
+ (p nil ,(concat name " describes itself as:"))
+ (blockquote nil ,desc))))))
+ files))
+ (write-region (point-min) (point-max) (concat name ".xml")))))
+
(defun elpaa--html-make-pkg (pkg pkg-spec files srcdir plain-readme)
(let* ((name (symbol-name (car pkg)))
(latest (package-version-join (aref (cdr pkg) 0)))
@@ -1873,11 +1911,14 @@ arbitrary code."
(elpaa--make-badge (concat name ".svg")
(format "%s ELPA" elpaa--name)
(format "%s %s" name latest))
+ (elpaa--make-atom-feed pkg pkg-spec srcdir files)
(with-temp-buffer
(insert (elpaa--html-header
(format "%s ELPA - %s" elpaa--name name)
(format "<a href=\"index.html\">%s ELPA</a> - %s"
- elpaa--name name)))
+ elpaa--name name)
+ (format "<link href=\"%s.atom\" type=\"application/atom+xml\"
rel=\"alternate\" />"
+ name)))
(insert (format "<h2 class=\"package\">%s</h2>" name))
(insert "<dl>")
(insert (format "<dt>Description</dt><dd>%s</dd>\n" (elpaa--html-quote
desc)))
@@ -1908,6 +1949,7 @@ arbitrary code."
(list maints))
", ")
"</dd>\n"))
+ (insert "<dt>Atom feed</dt><dd><a href=\"" name ".xml\">" name
".xml</a></dd>")
(elpaa--insert-repolinks
pkg-spec
(or (cdr (assoc :url (aref (cdr pkg) 4)))
@@ -1955,22 +1997,34 @@ arbitrary code."
(defun elpaa--html-make-index (pkgs)
(with-temp-buffer
- (insert (elpaa--html-header
- (concat elpaa--name " ELPA Packages")
- nil elpaa--index-javascript-headers))
- (insert "<table id=\"packages\">\n")
- (insert
"<thead><tr><th>Package</th><th>Version</th><th>Description</th></tr></thead>\n")
- (insert "<tbody>")
- (dolist (pkg pkgs)
- (insert (format "<tr><td><a
href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td></tr>\n"
- (car pkg) (car pkg)
- (package-version-join (aref (cdr pkg) 0))
- (aref (cdr pkg) 2))))
- (insert "</tbody></table>
+ (let ((scores (and elpaa--wsl-stats-file
+ (file-readable-p elpaa--wsl-stats-file)
+ (nth 3 (elpaa--form-from-file-contents
+ elpaa--wsl-stats-file)))))
+ (insert (elpaa--html-header
+ (concat elpaa--name " ELPA Packages")
+ nil elpaa--index-javascript-headers))
+ (insert "<table id=\"packages\">\n")
+ (insert
"<thead><tr><th>Package</th><th>Version</th><th>Description</th><th>Rank</th></tr></thead>\n")
+ (insert "<tbody>")
+ (dolist (pkg pkgs)
+ (insert (format "<tr><td><a
href=\"%s.html\">%s</a></td><td>%s</td><td>%s</td><td>%s</td></tr>\n"
+ (car pkg) (car pkg)
+ (package-version-join (aref (cdr pkg) 0))
+ (aref (cdr pkg) 2)
+ ;; Average rank over all the weeks' ranks.
+ ;; FIXME: Only use the more recent weeks?
+ (let* ((ranks (and (hash-table-p scores)
+ (gethash (symbol-name (car pkg))
+ scores)))
+ (total (apply #'+ (mapcar #'cdr ranks))))
+ (if (null ranks) "?"
+ (format "%d%%" (/ total (length ranks))))))))
+ (insert "</tbody></table>
<div class=\"push\"></div>
</main>")
- (insert (elpaa--html-footer))
- (write-region (point-min) (point-max) "index.html")))
+ (insert (elpaa--html-footer))
+ (write-region (point-min) (point-max) "index.html"))))
(defun elpaa-batch-html-make-index ()
(let* ((ac-file (pop command-line-args-left))
@@ -1980,6 +2034,148 @@ arbitrary code."
(default-directory (file-name-directory (expand-file-name ac-file))))
(elpaa--html-make-index (cdr ac))))
+;;; Statistics from the web server log
+
+(defconst elpaa--wsl-time-re
+ (rx (group (repeat 2 digit)) ;Day
+ "/" (group (repeat 3 alpha)) ;Month
+ "/" (group (repeat 4 digit)) ;Year
+ ":" (group ;Time
+ (repeat 2 digit) ":" (repeat 2 digit) ":" (repeat 2 digit)
+ " " (or "+" "-") (repeat 4 digit))))
+
+(defconst elpaa--wsl-line-re
+ (rx bol
+ (\? (+ (not " ")) " ") ; VHost
+ (+ (or xdigit "." ":")) ; IP of client
+ " - - "
+ "[" (group (+ (not "]"))) "]" ; Date/time
+ " \"" (or (seq (+ (or alpha "_")) ; Method
+ " " (group (+ (not (any blank)))) ; Path
+ " " "HTTP/" (+ (or alnum "."))) ; Protocol
+ (* (not (any "\"" " ")))) ; Garbage
+ "\""
+ " " (+ digit) ; Status code
+ " " (or (+ digit) "-") ; Size
+ " \"" (* (or (not (any "\"")) "\\\"")) "\" " ; Referrer
+ "\"" (* (or (not (any "\"")) "\\\"")) "\"" ; User-Agent
+ eol))
+
+(defun elpaa--wsl-read (logfile fn)
+ (with-temp-buffer
+ (insert-file-contents logfile)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (not (looking-at elpaa--wsl-line-re))
+ (message "Unrecognized log line: %s"
+ (buffer-substring (point) (line-end-position)))
+ (let* ((timestr (match-string 1))
+ (file (match-string 2))
+ (timestr
+ (if (string-match "/\\([^/]*\\)/\\([^/:]*\\):" timestr)
+ (replace-match " \\1 \\2 " t nil timestr)
+ (message "Unrecognized timestamp: %s" timestr)
+ timestr))
+ (time (encode-time (parse-time-string timestr))))
+ (when file
+ (let ((pkg (if (string-match
+ (rx bos "/"
+ (or "packages" "devel" "nongnu" "nongnu-devel")
+ "/"
+ (group (+? any))
+ (\?
+ "-" (or
+ (seq
+ (+ (or digit "."))
+ (* (or "pre" "beta" "alpha" "snapshot")
+ (* (or digit "."))))
+ "readme"))
+ "."
+ (or "tar" "txt" "el" "html"))
+ file)
+ (match-string 1 file))))
+ (funcall fn time pkg file)))))
+ (forward-line 1))))
+
+(defun elpaa--wsl-one-file (logfile stats)
+ (elpaa--wsl-read
+ logfile
+ ;; Keep a counter of accesses indexed by package and week.
+ (lambda (time pkg _file)
+ (let* ((secs (time-convert time 'integer))
+ (week (/ secs 3600 24 7)))
+ (cl-incf (alist-get week (gethash pkg stats) 0))))))
+
+(defvar elpaa--wsl-directory "/var/log/apache2/")
+
+(defun elpaa--wsl-scores (table)
+ (let ((scores-by-week ()))
+ (maphash (lambda (pkg data)
+ (when (and pkg (not (string-match "/" pkg)))
+ (pcase-dolist (`(,week . ,count) data)
+ (push (cons count pkg) (alist-get week scores-by-week)))))
+ table)
+ ;; For each week, we sort packages by number of downloads, to
+ ;; compute their percentile ranking.
+ ;; FIXME: We don't take into account that several (many?) packages can
+ ;; have the same number of downloads, in which case their relative ranking
+ ;; (within the equiv class) is a lie.
+ (dolist (scores scores-by-week)
+ (setf (cdr scores)
+ (nreverse (mapcar #'cdr (sort (cdr scores)
+ #'car-less-than-car)))))
+ (let ((score-table (make-hash-table :test 'equal)))
+ (pcase-dolist (`(,week . ,pkgs) scores-by-week)
+ (let* ((total (length pkgs))
+ (rest total))
+ (dolist (pkg pkgs)
+ (setq rest (1- rest))
+ (let ((percentile (/ (* 100 rest) total)))
+ (push (cons week percentile) (gethash pkg score-table))))))
+ score-table)))
+
+(defun elpaa--wsl-collect ()
+ (let* ((stats (elpaa--form-from-file-contents elpaa--wsl-stats-file))
+ (seen (nth 1 stats))
+ (table (nth 2 stats))
+ (changed nil))
+ (cl-assert (eq :web-server-log-stats (nth 0 stats)))
+ (unless table (setq table (make-hash-table :test 'equal)))
+ ;; Only consider the compressed files, because we don't want to process
+ ;; files that may still be modified.
+ (dolist (logfile (directory-files elpaa--wsl-directory t "\\.[lgx]z\\'"))
+ (let ((attrs (file-attributes logfile)))
+ (cond
+ ((string-match "error.log" logfile) nil) ;Ignore the error log files.
+ ((member attrs seen) nil) ;Already processed.
+ (t
+ (push attrs seen)
+ (setq changed t)
+ (elpaa--wsl-one-file logfile table)))))
+ (when changed
+ (with-temp-buffer
+ (funcall (if (fboundp 'pp-28) #'pp-28 #'pp)
+ `(:web-server-log-stats ,seen ,table
+ ;; Rebuild the scoreboard "by week".
+ ,(elpaa--wsl-scores table))
+ (current-buffer))
+ (princ "\n" (current-buffer))
+ (write-region nil nil elpaa--wsl-stats-file)))))
+
+;; (defun elpaa--wsl-foo ()
+;; (let ((diff (time-convert (time-subtract curtime time) 'integer))
+;; (diff-weeks (/ diff 3600 24 7))
+;; (timelog (/ (logb (1+ diff-weeks)) 2))
+;; (vec (gethash pkg stats)))
+;; (unless vec
+;; (setf (gethash pkg stats) (setq vec (make-vector 4 0))))
+;; (if (> timelog (length vec))
+;; (message "Entry too old: %s" timestr)
+;; (cl-incf (aref vec timelog)))))
+;; stats)))
+
+;;; Maintain worktrees in the `packages' subdirectory
+
(defun elpaa--pull (dirname)
(let ((default-directory (elpaa--dirname dirname)))
(with-temp-buffer
@@ -2031,8 +2227,6 @@ arbitrary code."
" " "\n")
(buffer-string))))))
-;;; Maintain worktrees in the `packages' subdirectory
-
(defun elpaa--sync-emacs-repo ()
"Sync Emacs repository, if applicable.
Return non-nil if there's an \"emacs\" repository present."
@@ -2450,7 +2644,7 @@ If WITH-CORE is non-nil, it means we manage :core
packages as well."
(insert "\n## Summary:\n\n")
(let ((beg (point)))
(insert (if (not readme)
- "[Not available 🙁]"
+ "[Not provided 🙁]"
(elpaa--section-to-plain-text readme)))
;; Keep a max of about 10 lines of full-length text.
(delete-region (min (+ beg 800) (point)) (point))
@@ -2466,7 +2660,7 @@ If WITH-CORE is non-nil, it means we manage :core
packages as well."
(unless (bolp) (insert "\n"))
(insert "\n## Recent NEWS:\n\n"
(if (not news)
- "[Not available 🙁]"
+ "[Not provided 🙁]"
(elpaa--section-to-plain-text news))))
(elpaa--send-email
`((From . ,elpaa--email-from)
@@ -2521,6 +2715,9 @@ directory; one of archive, archive-devel."
(let ((default-directory
(if input-dir (expand-file-name input-dir)
default-directory)))
+ ;; FIXME: The name of the output file is splattered all over the output
+ ;; file, so it ends up wrong after renaming. Maybe it's harmless,
+ ;; I don't know, but it's not satisfactory.
(apply #'elpaa--call-sandboxed
t "makeinfo" "--no-split" input-name "-o" tmpfile extraargs))
(message "%s" (buffer-string)))
@@ -2533,20 +2730,25 @@ directory; one of archive, archive-devel."
(html-file (expand-file-name destname html-dir))
(html-xref-file
(expand-file-name destname (file-name-directory html-dir))))
- (elpaa--makeinfo docfile html-file '("--html"))
- ;; FIXME: Use `push' in Emacs≥28
- (plist-put (cdr pkg-spec)
- :internal--html-docs
- (cons (cons (file-name-base html-file)
- (file-name-nondirectory html-file))
- (plist-get (cdr pkg-spec) :internal--html-docs)))
+ (elpaa--makeinfo docfile html-file
+ (list "--html" (format "--css-ref=%s" elpaa--css-url)))
+ (push (cons (file-name-base html-file)
+ (file-name-nondirectory html-file))
+ (plist-get (cdr pkg-spec) :internal--html-docs))
;; Create a symlink from elpa/archive[-devel]/doc/* to
;; the actual file, so html references work.
- (with-demoted-errors "%S" ;; 'make-symbolic-link' doesn't work on Windows
- (make-symbolic-link
- (concat (file-name-nondirectory html-dir) "/" destname)
- html-xref-file t))))
+ (let ((target (file-name-concat (file-name-nondirectory html-dir)
+ destname))
+ (current-target (file-attribute-type
+ (file-attributes html-xref-file))))
+ (cond
+ ((not (stringp current-target))
+ (with-demoted-errors "%S" ;; 'make-symbolic-link' fails on Windows.
+ (make-symbolic-link target html-xref-file)))
+ ((equal target current-target) nil) ;Nothing to do.
+ (t (error "Manual name %S conflicts with %S"
+ destname current-target))))))
(defun elpaa--build-Info-1 (pkg-spec docfile dir html-dir)
"Build an info file from DOCFILE (a texinfo source file).
@@ -2977,6 +3179,56 @@ relative to elpa root."
(when (file-readable-p "elpa-config") (elpaa-read-config "elpa-config"))
+;;; Atom feed generation
+
+(defun elpaa--render-atom (title path articles)
+ "Insert an Atom feed at point.
+TITLE sets the title of the feed, PATH is the request path
+relative to the server route of where the Atom feed will be
+hosted. ARTICLES is a list of plists, consisting of the keys
+`:title' for an article title, `:time' a timestamp in in
+`current-time'-format, `:path' is a root-relative HTTP path to
+the article."
+ (cl-flet ((newer-p (a1 a2)
+ (time-less-p (plist-get a1 :time) (plist-get a2 :time)))
+ (rfc3339 (time)
+ (format-time-string "%Y-%m-%dT%H:%M:%SZ" time)))
+ (let* ((articles (sort articles #'newer-p))
+ (domain (if (string-match "\\`https?://\\([^/]+\\)/" elpaa--url)
+ (match-string 1 elpaa--url)
+ (error "Failed to infer domain from %S" elpaa--url)))
+ (self (concat "https://"; domain path)))
+ (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
+ (xml-print
+ ;; See https://validator.w3.org/feed/docs/rfc4287.html
+ `((feed
+ ((xmlns . "http://www.w3.org/2005/Atom";))
+ (title nil ,title)
+ (link ((href . ,self) (rel . "self")))
+ (id nil ,self)
+ (updated nil ,(rfc3339 (plist-get :time (car articles))))
+ ,@(mapcar
+ (pcase-lambda ((map (:title title) (:time time)
+ (:path path) (:content content)))
+ `(entry
+ nil
+ (title nil ,title)
+ (updated nil ,(rfc3339 time))
+ (author
+ nil
+ (name nil "elpa-admin")
+ (email nil "emacs-de...@gnu.org"))
+ (id nil ,(format "tag:%s,%s:%s"
+ domain
+ (format-time-string "%F" time)
+ path))
+ (content
+ ((type . "html"))
+ ,(with-temp-buffer
+ (xml-print content)
+ (buffer-string)))))
+ articles)))))))
+
(provide 'elpa-admin)
;; Local Variables:
