Missing dependency in README

If a package has a failure log and a success log, then ignore the
success and only show "fails" in the build summary.

fixes https://github.com/racket/pkg-build/issues/9

README.md

@@ -4,7 +4,10 @@
 
 You will need to install the following Racket packages:
 
-    raco pkg install reloadable
+    raco pkg install --skip-installed \
+         'https://github.com/racket/infrastructure-userdb.git#main' \
+         reloadable \
+         aws
 
 ## Configuration
 
@@ -50,6 +53,11 @@ Keys useful for deployment:
    statically. The source file `static.rkt` in this codebase knows
    precisely which files and directories within
    `pkg-index-generated-directory` to upload to the final site.
+ - *user-directory*: directory containing the user database; should be
+   the same as `pkg-index` uses.
+ - *email-sender-address*: string; defaults to `pkgs@racket-lang.org`.
+   Used as the "from" address when sending authentication emails on
+   behalf of the server.
 
 Keys useful for development:
 

configs/live.rkt

@@ -9,6 +9,8 @@
               (format "file://~a/public_html/pkg-index-static/pkgs-all.json.gz" var)
             'backend-baseurl "https://localhost:9004"
             'pkg-index-generated-directory (build-path var "public_html/pkg-index-static")
+            'user-directory (build-path var "pkg-index/users.new")
+            'email-sender-address "The Racket Package Server <pkgs@racket-lang.org>"
             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
             ;; To configure a split, S3-based setup, comment out the following lines:
             ;;

configs/pkgd.rkt

@@ -1,13 +0,0 @@
-#lang racket/base
-;; Configuration for pkgd
-(require "../src/main.rkt")
-(main (hash 'port 8444
-            'backend-baseurl "https://localhost:9004"
-            'package-index-url "file:///home/ubuntu/local/new-plt/pkgs/plt-services/meta/pkg-index/official/static-gen/pkgs-all.json.gz"
-            'static-output-type 'aws-s3
-            'aws-s3-bucket+path "pkgn.racket-lang.org/"
-            'dynamic-urlprefix "https://pkgd.racket-lang.org/pkgn"
-            'static-urlprefix "https://pkgn.racket-lang.org"
-            'dynamic-static-urlprefix "https://pkgn.racket-lang.org"
-            'pkg-index-generated-directory "/home/ubuntu/local/new-plt/pkgs/plt-services/meta/pkg-index/official/static-gen/"
-            ))

configs/tonyg.rkt

@@ -1,9 +1,17 @@
 #lang racket/base
 ;; Configuration for tonyg's development setup.
 (require "../src/main.rkt")
+
+(define pkg-index-generated-directory
+  (build-path (find-system-path 'home-dir) "src/pkg-index/official/static-gen"))
+
 (main (hash 'port 8444
+            'ssl? #f
             'reloadable? #t
-            'package-index-url "file:///home/tonyg/public_html/pkg-index-static/pkgs-all.json.gz"
+            'package-index-url (format "file://~a/pkgs-all.json.gz" pkg-index-generated-directory)
+            'user-directory (build-path (find-system-path 'home-dir)
+                                        "src/pkg-index/official/root/users.new")
+            'email-sender-address "tonyg@racket-lang.org"
             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
             ;; Either:
             ;;
@@ -22,8 +30,7 @@
             ;; 'dynamic-static-urlprefix "https://localhost:8446"
             ;;
             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-            'dynamic-urlprefix "https://localhost:8444"
-            'backend-baseurl "https://localhost:8445"
-            'pkg-index-generated-directory (build-path (find-system-path 'home-dir)
-                                                       "public_html/pkg-index-static")
+            'dynamic-urlprefix "http://localhost:8444"
+            'backend-baseurl "http://localhost:8445"
+            'pkg-index-generated-directory pkg-index-generated-directory
             ))

configs/tonyg/nginx.locals3proxy.conf

@@ -1,30 +0,0 @@
-# As a regular user, run
-#
-#     nginx -p . -c nginx.locals3proxy.conf
-
-daemon off;
-pid ./nginx.pid;
-error_log locals3proxy-error.log;
-
-events {
-    worker_connections 768;
-}
-
-http {
-    server {
-        listen 8446 default_server ssl;
-
-        access_log locals3proxy-access.log;
-        error_log locals3proxy-error.log;
-
-        ssl_certificate /home/tonyg/src/racket-pkg-website/server-cert.pem;
-        ssl_certificate_key /home/tonyg/src/racket-pkg-website/private-key.pem;
-        ssl_protocols TLSv1 TLSv1.1 TLSv1.2;
-        ssl_ciphers HIGH:!aNULL:!MD5;
-
-        location / {
-            proxy_pass http://pkgs.leastfixedpoint.com.s3-website-us-east-1.amazonaws.com/;
-            proxy_http_version 1.1;
-        }
-    }
-}

configs/tonyg/run-s3-proxy.sh

@@ -1,2 +0,0 @@
-#!/bin/sh
-exec nginx -p . -c nginx.locals3proxy.conf

on-ping-service-failure.sh

@@ -0,0 +1,39 @@
+#!/bin/bash
+#
+# I am potentially invoked when ping-service.sh (which see) fails to
+# contact the racket-pkg-website service.
+#
+
+# Request a dump of running threads:
+dumprequestfile=$HOME/racket-pkg-website/signals/.dumpinfo
+touch $dumprequestfile
+
+# Wait a few seconds for the dump to complete:
+sleep 10
+
+# Tar up the most recent few hours' worth of logs:
+logarchive=$HOME/ping-failure-logs-$(date +%Y%m%d%H%M%S).tar.gz
+(
+    cd $HOME/service/racket-pkg-website/log/main/; \
+    ls -tr | tail -n 10 | xargs tar -zcf $logarchive \
+)
+
+# Restart the service using daemontools.
+if [ -f $dumprequestfile ]
+then
+    # If the `.dumpinfo` signal is still there after our sleep, then
+    # the process is so far off the rails we shouldn't bother waiting
+    # for it, so kill it hard.
+    echo "Killing service hard and restarting it."
+    svc -dku $HOME/service/racket-pkg-website
+else
+    # Otherwise, it's at least partially awake, so try asking it
+    # nicely.
+    echo "Politely requesting service termination before restart."
+    svc -du $HOME/service/racket-pkg-website
+fi
+
+# Finally, complain out loud. We expect to be running in some kind of
+# cron-ish context, so the output we produce here will likely find its
+# way into an email to a responsible party.
+echo "racket-pkg-website on-ping-service-failure.sh invoked. logarchive=$logarchive"

ping-service.sh

@@ -0,0 +1,32 @@
+#!/bin/bash
+#
+# I am a script, intended to run from `cron`, which pings a
+# configurable URL, and if no suitable response is forthcoming,
+# performs a configurable command.
+#
+# For example, to monitor racket-pkg-website, try
+#
+# ./ping-service.sh https://localhost:8444/ping $HOME/racket-pkg-website/on-ping-service-failure.sh
+
+if [ "$#" != "2" ]
+then
+    echo 'Usage: ping-service.sh <url> <command>'
+    echo 'Note that <command> has to be a single string.'
+    exit 1
+fi
+
+url="$1"
+failurecommand="$2"
+
+# curl flags:
+#  -f == fail, interrogate the HTTP response status code
+#  -s == silent, don't print a progress meter or any other cruft
+#  -k == Ignore certificates, where url is an HTTPS URL
+#
+if curl -f -s -k --max-time 10 "$url" > /dev/null
+then
+    # Do nothing -- the retrieval was successful
+    true
+else
+    exec sh -c "$failurecommand"
+fi

run

@@ -12,7 +12,22 @@ if [ ! -f configs/${CONFIG}.rkt ]; then
     exit 1
 fi
 
-PLTSTDERR="info warning@cm warning@compiler/cm warning@module-prefetch warning@setup/parallel-build warning@cm-accomplice warning@online-check-syntax error@racket/contract"
+PLTSTDERR="
+	info
+	warning@GC
+	warning@cm
+	warning@compiler/cm
+	warning@module-prefetch
+	warning@setup/parallel-build
+	warning@cm-accomplice
+	warning@online-check-syntax
+	error@racket/contract
+	error@collapsible-cache-fail
+	error@collapsible-contract-arrow-wrapper-arity
+	error@collapsible-contract-bailout
+	error@collapsible-merging
+	error@collapsible-value-bailout
+        "
 export PLTSTDERR
 echo '============================================='
 cd src

src/bootstrap.rkt

@@ -53,6 +53,7 @@
                             #:code [code 200]
                             #:message [message #"Okay"]
                             #:body-class [body-class #f]
+                            #:description [description #f]
 			    .
 			    body-contents)
   (response/xexpr
@@ -65,6 +66,10 @@
 	   (meta ((http-equiv "X-UA-Compatible") (content "IE=edge")))
 	   (meta ((name "viewport") (content "width=device-width, initial-scale=1")))
 	   (title ,title)
+	   ,@(if (non-empty-string? description)
+               `((meta ((name "description")
+                        (content ,description))))
+               '())
 	   (link ((rel "stylesheet") (href ,(static "/bootstrap/css/bootstrap.min.css")) (type "text/css")))
 	   (link ((rel "stylesheet") (href ,(static "/jquery-ui.min.css")) (type "text/css")))
            (link ((rel "stylesheet") (href ,(static "/style.css")) (type "text/css")))

src/challenge.rkt

@@ -0,0 +1,48 @@
+#lang racket/base
+
+(provide (struct-out challenge)
+         generate-challenge
+         challenge-passed?)
+
+(require racket/pretty)
+
+(struct challenge (expr question answer) #:transparent)
+
+(define (random-element lst)
+  (list-ref lst (random (length lst))))
+
+(define (generate-expr)
+  (if (>= (random) 0.5)
+      `(,(random-element '(car cadr caddr))
+        (map (lambda (v) (+ ,(random 4) (* v ,(random 4))))
+             (list ,(random 4) ,(random 4) ,(random 4))))
+      (let ()
+        (define (random-op) (random-element '(+ * -)))
+        (define (e fuel)
+          (if (zero? fuel)
+              (random 10)
+              (cons (random-op)
+                    (for/list [(i (in-range (+ 1 (random 2))))]
+                      (e (- fuel 1))))))
+        (e 2))))
+
+(define (generate-challenge)
+  (define expr (generate-expr))
+  (challenge expr
+             `(div
+               (p (b "What is the result of evaluating:"))
+               (pre (code ,(pretty-format expr 40 #:mode 'write))))
+             (eval expr (make-base-namespace))))
+
+(define (safe-string->value str)
+  (parameterize (;; Hmm, this is a big list. Did I miss any important ones?
+                 (read-accept-box #f)
+                 (read-accept-compiled #f)
+                 (read-accept-graph #f)
+                 (read-accept-reader #f)
+                 (read-accept-lang #f))
+    (read (open-input-string str))))
+
+(define (challenge-passed? challenge response-str)
+  (define response (safe-string->value response-str))
+  (equal? response (challenge-answer challenge)))

src/daemon.rkt

@@ -6,19 +6,21 @@
 (require (only-in racket/exn exn->string))
 
 (define (daemonize-thunk name boot-thunk)
-  (lambda ()
-    (let reboot ()
-      ;; We would catch exn:fail? here, but exn:pretty in the web
-      ;; server is a subtype of exn, not of exn:fail, and that causes
-      ;; spurious permanent daemon exits.
-      (with-handlers* ((exn? (lambda (e)
-                               (log-error "*** DAEMON CRASHED: ~a ***\n~a"
-                                          name
-                                          (exn->string e))
-                               (sleep 5)
-                               (reboot))))
-        (define result (boot-thunk))
-        (log-warning "Daemon thread ~a exited normally (returning ~v)" name result)))))
+  (procedure-rename
+   (lambda ()
+     (let reboot ()
+       ;; We would catch exn:fail? here, but exn:pretty in the web
+       ;; server is a subtype of exn, not of exn:fail, and that causes
+       ;; spurious permanent daemon exits.
+       (with-handlers* ((exn? (lambda (e)
+                                (log-error "*** DAEMON CRASHED: ~a ***\n~a"
+                                           name
+                                           (exn->string e))
+                                (sleep 5)
+                                (reboot))))
+         (define result (boot-thunk))
+         (log-warning "Daemon thread ~a exited normally (returning ~v)" name result))))
+   (string->symbol (format "~v" name))))
 
 (define (daemon-thread name boot-thunk)
   (thread (daemonize-thunk name boot-thunk)))

src/debug.rkt

@@ -0,0 +1,36 @@
+#lang racket/base
+;; Code for debugging a live server.
+
+(provide debug-information-dump!)
+
+(require "main.rkt")
+(require racket/exn)
+(require racket/tcp)
+(require (only-in racket/string string-join))
+
+(define (format-path path)
+  (string-join (map number->string (reverse path)) "."))
+
+(define (enumerate-custodian-managed-items cust super path)
+  (for [(index (in-naturals))
+        (item (custodian-managed-list cust super))]
+    (eprintf "\nItem ~a.\n~v\n" (format-path (cons index path)) item)
+    (cond
+      [(thread? item)
+       (eprintf "~a" (exn->string (exn "Stack snapshot:" (continuation-marks item))))]
+      [(tcp-port? item)
+       (eprintf "TCP port: (addresses ~v)\n"
+                (call-with-values (lambda () (tcp-addresses item #t)) list))]
+      [(custodian? item)
+       (enumerate-custodian-managed-items item cust (cons index path))]
+      [else (void)])))
+
+(define (debug-information-dump!)
+  (eprintf "===========================================================================\n")
+  (eprintf "======================================================================\n")
+  (eprintf "=================================================================")
+  (collect-garbage)
+  (enumerate-custodian-managed-items (current-custodian) (outermost-custodian) '())
+  (eprintf "=================================================================\n")
+  (eprintf "======================================================================\n")
+  (eprintf "===========================================================================\n"))

src/html-utils.rkt

@@ -1,10 +1,13 @@
 #lang racket/base
 ;; A utilities module :-/
 
-(require web-server/servlet)
-
 (provide maybe-splice
-	 define-form-bindings)
+         define-form-bindings/xform
+	 define-form-bindings
+         define-form-bindings/trim)
+
+(require web-server/servlet)
+(require (only-in racket/string string-trim))
 
 ;; Boolean XExpr ... -> (Listof XExpr)
 ;; Useful for optionally splicing in some contents to a list.
@@ -12,22 +15,28 @@
 (define-syntax-rule (maybe-splice guard contents ...)
   (if guard (list contents ...) '()))
 
-;; Extracts named single-valued bindings from the given request.
-;; If a given binding is missing, the extracted value will be #f.
-(define-syntax-rule (define-form-bindings req (specs ...))
-  (begin (define bs (request-bindings req))
-         (define-form-bindings* bs (specs ...))))
-
 (define-syntax define-form-bindings*
   (syntax-rules ()
-    [(_ bs ())
+    [(_ bs xform ())
      (begin)]
-    [(_ bs ([name fieldname defaultval] rest ...))
+    [(_ bs xform ([name fieldname defaultval] rest ...))
      (begin (define name (if (exists-binding? 'fieldname bs)
-                             (extract-binding/single 'fieldname bs)
+                             (xform (extract-binding/single 'fieldname bs))
                              defaultval))
-            (define-form-bindings* bs (rest ...)))]
-    [(_ bs ([name defaultval] rest ...))
-     (define-form-bindings* bs ([name name defaultval] rest ...))]
-    [(_ bs (name rest ...))
-     (define-form-bindings* bs ([name #f] rest ...))]))
+            (define-form-bindings* bs xform (rest ...)))]
+    [(_ bs xform ([name defaultval] rest ...))
+     (define-form-bindings* bs xform ([name name defaultval] rest ...))]
+    [(_ bs xform (name rest ...))
+     (define-form-bindings* bs xform ([name #f] rest ...))]))
+
+;; Extracts named single-valued bindings from the given request.
+;; If a given binding is missing, the extracted value will be #f.
+(define-syntax-rule (define-form-bindings/xform req xform (specs ...))
+  (begin (define bs (request-bindings req))
+         (define-form-bindings* bs xform (specs ...))))
+
+(define-syntax-rule (define-form-bindings req (specs ...))
+  (define-form-bindings/xform req values (specs ...)))
+
+(define-syntax-rule (define-form-bindings/trim req (specs ...))
+  (define-form-bindings/xform req string-trim (specs ...)))

src/http-utils.rkt

@@ -6,7 +6,7 @@
          http-interpret-response
          http-simple-interpret-response
          http-follow-redirects
-         http-sendrecv/url
+         custom-http-sendrecv/url
 
          http/interpret-response
          http/simple-interpret-response
@@ -17,7 +17,7 @@
 (require racket/match)
 (require net/http-client)
 (require net/head)
-(require (except-in net/url http-sendrecv/url))
+(require net/url)
 
 ;; (Parameterof Number)
 ;; Number of redirections to automatically follow when retrieving via GET or HEAD.
@@ -64,9 +64,9 @@
           reason-phrase
           (parse-headers response-headers downcase-header-names?)
           (if read-body?
-              (begin0 (port->bytes response-body-port)
-                (close-input-port response-body-port))
-              response-body-port)))
+            (begin0 (port->bytes response-body-port)
+              (close-input-port response-body-port))
+            response-body-port)))
 
 (define (http-simple-interpret-response status-line response-headers response-body-port)
   (define-values (_http-version
@@ -79,64 +79,39 @@
           headers
           body))
 
-(define ((http-follow-redirects method
-                                #:version [version #"1.1"])
+(define ((check-response method remaining-redirect-count)
          status-line
          response-headers
          response-body-port)
-  (define ((check-response remaining-redirect-count)
-           status-line
-           response-headers
-           response-body-port)
-    (log-debug "http-follow-redirects: Checking request result: ~a\n" status-line)
-    (define-values (http-version status-code reason-phrase) (parse-status-line status-line))
-    (if (and (positive? remaining-redirect-count)
-             (eq? (http-classify-status-code status-code) 'redirection))
-        (match (assq 'location (parse-headers response-headers))
-          [#f (values status-line response-headers response-body-port)]
-          [(cons _location-header-label location-urlbytes)
-           (define location (string->url (bytes->string/latin-1 location-urlbytes)))
-           (void (port->bytes response-body-port)) ;; consume and discard input
-           (close-input-port response-body-port)
-           (log-debug "http-follow-redirects: Following redirection to ~a\n" location-urlbytes)
-           (call-with-values (lambda () (http-sendrecv/url location
-                                                           #:version version
-                                                           #:method method))
-                             (check-response (- remaining-redirect-count 1)))])
-        (values status-line response-headers response-body-port)))
-  ((check-response (http-redirection-limit))
+  (log-debug "http-follow-redirects: Checking request result: ~a\n" status-line)
+  (define-values (http-version status-code reason-phrase)
+    (parse-status-line status-line))
+  (if (and (positive? remaining-redirect-count)
+           (eq? (http-classify-status-code status-code) 'redirection))
+    (match (assq 'location (parse-headers response-headers))
+      [#f (values status-line response-headers response-body-port)]
+      [(cons _location-header-label location-urlbytes)
+       (define location (string->url (bytes->string/latin-1 location-urlbytes)))
+       (void (port->bytes response-body-port)) ;; consume and discard input
+       (close-input-port response-body-port)
+       (log-debug "http-follow-redirects: Following redirection to ~a\n"
+                  location-urlbytes)
+       (call-with-values (lambda () (custom-http-sendrecv/url location
+                                                              #:method method))
+                         (check-response method (- remaining-redirect-count 1)))])
+    (values status-line response-headers response-body-port)))
+
+(define ((http-follow-redirects method)
+         status-line
+         response-headers
+         response-body-port)
+  ((check-response method (http-redirection-limit))
    status-line
    response-headers
    response-body-port))
 
-;; Already present in net/url, but that variant doesn't take #:version
-;; or allow overriding of #:ssl? and #:port.
-;;
-;; Furthermore, currently 2016-08-14 there is a fd leak when using
-;; method HEAD with `http-sendrecv` [1], so we implement our own crude
-;; connection management here.
-;;
-;; [1] https://github.com/racket/racket/issues/1414
-;;
-(define (http-sendrecv/url u
-                           #:ssl? [ssl? (equal? (url-scheme u) "https")]
-                           #:port [port (or (url-port u) (if ssl? 443 80))]
-                           #:version [version #"1.1"]
-                           #:method [method #"GET"]
-                           #:headers [headers '()]
-                           #:data [data #f]
-                           #:content-decode [decodes '(gzip)])
-  (define hc (http-conn-open (url-host u) #:ssl? ssl? #:port port))
-  (http-conn-send! hc (url->string u)
-                   #:version version
-                   #:method method
-                   #:headers headers
-                   #:data data
-                   #:content-decode decodes
-                   #:close? #t)
-  (begin0 (http-conn-recv! hc #:method method #:content-decode decodes #:close? #t)
-    (when (member method (list #"HEAD" "HEAD" 'HEAD))
-      (http-conn-close! hc))))
+(define (custom-http-sendrecv/url u #:method method)
+  (http-sendrecv/url u #:method method))
 
 (define-syntax-rule (http/interpret-response customization ... req-expr)
   (call-with-values (lambda () req-expr)
@@ -151,10 +126,15 @@
                     (http-follow-redirects customization ...)))
 
 (module+ test
-  (require rackunit)
-
-  (http/simple-interpret-response
-   (http/follow-redirects
-    #"HEAD"
-    (http-sendrecv/url (string->url "http://google.com/") #:method #"HEAD")))
-  )
+  (define parent-cust (current-custodian))
+  (define this-cust (make-custodian))
+  (parameterize ([current-custodian this-cust])
+    (for ([i (in-range 100)])
+      (http/simple-interpret-response
+       (http/follow-redirects
+        #"HEAD"
+        (custom-http-sendrecv/url (string->url "http://google.com/")
+                                  #:method #"HEAD")))))
+  (require racket/pretty)
+  (pretty-print
+   (custodian-managed-list this-cust parent-cust)))

src/main-inner.rkt

@@ -0,0 +1,21 @@
+#lang racket/base
+;; Inner startup module - required after establishment of server-wide custodian.
+
+(provide main)
+
+(require reloadable)
+(require "entrypoint.rkt")
+
+(define (main [config (hash)])
+  (make-persistent-state '*config* (lambda () config))
+  (void (make-reloadable-entry-point 'refresh-packages! "packages.rkt"))
+  (void (make-reloadable-entry-point 'rerender! "site.rkt"))
+  (void (make-reloadable-entry-point 'debug-information-dump! "debug.rkt"))
+  (start-service #:port (hash-ref config 'port (lambda ()
+                                                 (let ((port-str (getenv "SITE_PORT")))
+                                                   (if port-str (string->number port-str) 7443))))
+                 #:ssl? (hash-ref config 'ssl? (lambda () #t))
+                 #:reloadable? (hash-ref config 'reloadable? (lambda () (getenv "SITE_RELOADABLE")))
+                 (make-reloadable-entry-point 'request-handler "site.rkt")
+                 (make-reloadable-entry-point 'on-continuation-expiry "site.rkt")
+                 (make-reloadable-entry-point 'extra-files-paths "static.rkt")))

src/main.rkt

@@ -1,19 +1,12 @@
 #lang racket/base
+;; Outer startup module - delegates to main-inner.rkt after installing a custodian
 
-(provide main)
+(provide main
+         outermost-custodian)
 
-(require reloadable)
-(require "entrypoint.rkt")
+(define *outermost-custodian* (current-custodian))
+(define (outermost-custodian) *outermost-custodian*)
 
 (define (main [config (hash)])
-  (make-persistent-state '*config* (lambda () config))
-  (void (make-reloadable-entry-point 'refresh-packages! "packages.rkt"))
-  (void (make-reloadable-entry-point 'rerender! "site.rkt"))
-  (start-service #:port (hash-ref config 'port (lambda ()
-                                                 (let ((port-str (getenv "SITE_PORT")))
-                                                   (if port-str (string->number port-str) 7443))))
-                 #:ssl? (hash-ref config 'ssl? (lambda () #t))
-                 #:reloadable? (hash-ref config 'reloadable? (lambda () (getenv "SITE_RELOADABLE")))
-                 (make-reloadable-entry-point 'request-handler "site.rkt")
-                 (make-reloadable-entry-point 'on-continuation-expiry "site.rkt")
-                 (make-reloadable-entry-point 'extra-files-paths "static.rkt")))
+  (parameterize ((current-custodian (make-custodian (outermost-custodian))))
+    ((dynamic-require "main-inner.rkt" 'main) config)))

src/packages.rkt

@@ -34,7 +34,7 @@
 
 (define package-index-url
   (or (@ (config) package-index-url)
-      "http://pkgs.racket-lang.org/pkgs-all.json.gz"))
+      "https://pkgs.racket-lang.org/pkgs-all.json.gz"))
 
 (define package-fetch-interval
   (* (or (@ (config) package-fetch-interval)
@@ -73,9 +73,12 @@
   (eq? pkg 'tombstone))
 
 (define (asynchronously-fetch-remote-packages state)
-  (thread (lambda ()
-            (define raw-remote-packages (fetch-remote-packages))
-            (manager-rpc 'refresh-packages! raw-remote-packages)))
+  (thread
+   (procedure-rename
+    (lambda ()
+      (define raw-remote-packages (fetch-remote-packages))
+      (manager-rpc 'refresh-packages! raw-remote-packages))
+    (string->symbol (format "~v" (list 'asynchronously-fetch-remote-packages (current-inexact-milliseconds))))))
   (struct-copy package-manager-state state
                [next-fetch-deadline (+ (current-inexact-milliseconds) package-fetch-interval)]))
 
@@ -287,19 +290,55 @@
                              ;; to do this at package save time, but this will do for now.
                              (pkg->searchable-text pkg)))))
 
+;; sort-package-names/priority :: (listof string?) (listof (cons/c symbol? package?)) -> (listof symbol?)
+;; Rank packages by favoring those whose name prefixes or contains search strings
+;; and whose description contains search strings
+(define (sort-package-names/priority text-list packages)
+  ;; A key is a pair of a priority and a package name
+  ;; where higher priority means it's more relevant to the search text
+  ;; Note that the tombstone packages are filtered already,
+  ;; so it's safe to use (@ pkg ...)
+  (define (package-pair->key package-pair)
+    (define pkg (cdr package-pair))
+    (define pkg-name (@ pkg name))
+    (define pkg-desc (@ pkg description))
+    (define priority
+      (for/sum ([text (in-list text-list)])
+        (cond
+          ;; NOTE: no need to check for string=? (the exact match)
+          ;; because it will also be a prefix, and will be
+          ;; weighted more due to its lexicographic order.
+          [(string-prefix? pkg-name text) 100]
+          [(string-contains? pkg-name text) 10]
+          [(and pkg-desc (string-contains? pkg-desc text)) 1]
+          [else 0])))
+    (cons priority pkg-name))
+
+  (define (key< a b)
+    (cond
+      [(= (car a) (car b)) (string-ci<? (cdr a) (cdr b))]
+      [else (> (car a) (car b))]))
+
+  (define sorted (sort packages key< #:key package-pair->key #:cache-keys? #t))
+  (map car sorted))
+
 (define (package-search text tags)
-  (define res (map (lambda (r) (regexp (regexp-quote r #f))) (string-split text)))
+  (define text-list (remove-duplicates (string-split text)))
+  (define res (map (lambda (r) (regexp (regexp-quote r #f))) text-list))
   (define packages (manager-rpc 'packages))
-  (sort-package-names
-   (filter (lambda (package-name)
-             (define pkg (hash-ref packages package-name))
+
+  (sort-package-names/priority
+   text-list
+   (filter (lambda (package-pair)
+             (define pkg (cdr package-pair))
              (andmap (package-text-matches? pkg) res))
-           (hash-keys
+           (hash->list
             (for/fold ((ps packages)) ((tag-spec tags))
               (match-define (list tag-name include?) tag-spec)
               (for/hash (((package-name pkg) (in-hash ps))
                          #:when (and (not (tombstone? pkg))
-                                     ((if include? values not) (@ref (@ pkg search-terms) tag-name))))
+                                     ((if include? values not)
+                                      (@ref (@ pkg search-terms) tag-name))))
                 (values package-name pkg)))))))
 
 (define (packages-jsexpr)

src/signals.rkt

@@ -51,5 +51,10 @@
                        (if (eof-object? items-to-rerender)
                            #f
                            items-to-rerender))))
+       (poll-signal "../signals/.dumpinfo"
+                    "Debug information dump request received"
+                    (lambda ()
+                      ((reloadable-entry-point->procedure
+                        (lookup-reloadable-entry-point 'debug-information-dump! "debug.rkt")))))
        (sleep 0.5)
        (loop)))))

src/site.rkt

@@ -10,13 +10,13 @@
 (require racket/match)
 (require racket/format)
 (require racket/date)
-(require racket/string)
+(require (only-in racket/string string-join string-split))
 (require racket/port)
 (require (only-in racket/list filter-map drop-right))
 (require (only-in racket/exn exn->string))
-(require (except-in net/url http-sendrecv/url))
+(require net/url)
 (require net/uri-codec)
-(require (except-in web-server/servlet http-sendrecv/url))
+(require web-server/servlet)
 (require json)
 (require "gravatar.rkt")
 (require "bootstrap.rkt")
@@ -31,6 +31,8 @@
 (require "static.rkt")
 (require "package-source.rkt")
 (require "http-utils.rkt")
+(require "challenge.rkt")
+(require "users.rkt")
 
 (define static-urlprefix
   (or (@ (config) static-urlprefix)
@@ -52,7 +54,7 @@
 (define nav-search "Search")
 
 (define (navbar-header)
-  `(a ((href "http://www.racket-lang.org/"))
+  `(a ((href "https://www.racket-lang.org/"))
     (img ((src ,(static-resource-url "/logo-and-text.png"))
           (height "60")
           (alt "Racket Package Index")))))
@@ -62,7 +64,7 @@
       "https://pkgd.racket-lang.org"))
 
 (define default-empty-parsed-package-source
-  (git-source "git://github.com/" #f 'git 'git "github.com" #f "" "" ""))
+  (git-source "https://github.com/" #f 'git 'git "github.com" #f "" "" ""))
 
 (define COOKIE "pltsession")
 
@@ -72,7 +74,7 @@
 
 (define pkg-build-baseurl
   (or (@ (config) pkg-build-baseurl)
-      "http://pkg-build.racket-lang.org/"))
+      "https://pkg-build.racket-lang.org/"))
 
 (struct draft-package (old-name name description authors tags versions) #:prefab)
 
@@ -95,6 +97,8 @@
    [("json" "tag-search-completions") json-tag-search-completions]
    [("json" "formal-tags") json-formal-tags]
    [("pkgs-all.json") pkgs-all-json]
+   [("ping") ping-page]
+   [("bulk-operation") #:method "post" bulk-operation-page]
    ))
 
 (define (on-continuation-expiry request)
@@ -142,11 +146,11 @@
                     (,nav-search ,(named-url search-page))
                     ("About"
                      (("The Racket Package System"
-                       "http://docs.racket-lang.org/pkg/getting-started.html")
+                       "https://docs.racket-lang.org/pkg/getting-started.html")
                       ("Package Builds" "https://pkg-build.racket-lang.org/about.html")))
                     ((div ,(glyphicon 'download-alt)
                           " Download Racket")
-                     "http://download.racket-lang.org/")
+                     "https://download.racket-lang.org/")
                     ))
                  (bootstrap-static-urlprefix
                   (if (rendering-static-page?)
@@ -243,17 +247,23 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define ((generic-input type) name [initial-value ""] #:placeholder [placeholder #f])
-  `(input ((class "form-control")
+(define ((generic-input type #:extra-classes [extra-classes1 '()])
+         name
+         [initial-value ""]
+         #:id [id name]
+         #:extra-classes [extra-classes2 '()]
+         #:placeholder [placeholder #f])
+  `(input ((class ,(string-join (cons "form-control" (append extra-classes1 extra-classes2)) " "))
            (type ,type)
            (name ,name)
-           (id ,name)
+           ,@(maybe-splice id `(id ,id))
            ,@(maybe-splice placeholder `(placeholder ,placeholder))
            (value ,initial-value))))
 
 (define email-input (generic-input "email"))
 (define password-input (generic-input "password"))
 (define text-input (generic-input "text"))
+(define checkbox-input (generic-input "checkbox"))
 
 (define (label for . content)
   `(label ((class "control-label") ,@(maybe-splice for `(for ,for)))
@@ -334,7 +344,7 @@
                                   (role "form"))
                             ,(form-group 2 2 (label "email" "Email address")
                                          0 5 (email-input "email"))
-                            ,(form-group 2 2 (label "password" "Password:")
+                            ,(form-group 2 2 (label "password" "Password")
                                          0 5 (password-input "password"))
                             ,(form-group 4 5
                                          `(a ((href ,(embed-url (lambda (req) (register-form)))))
@@ -349,45 +359,39 @@
                                              (p ,error-message))))
                             ,(form-group 4 5 (primary-button "Log in"))))))))
 
-(define (authenticate-with-server! email password code)
-  (simple-json-rpc! #:sensitive? #t
-                    #:include-credentials? #f
-                    backend-baseurl
-                    "/api/authenticate"
-                    (hash 'email email
-                          'passwd password
-                          'code code)))
-
-(define (create-session-from-authentication-success! email password success)
-  ;; An "authentication success" is either #t, signalling a new user,
-  ;; or a hash-table with interesting facts in it.
-  (define user-facts (cond [(eq? success #t) (hasheq)]
-                           [(hash? success) success]
-                           [else (log-warning "Bad auth success for user ~v: ~v" email success)
-                                 (hasheq)]))
+(define (create-session-after-authentication-success! email password)
+  (define user-facts
+    (simple-json-rpc! #:sensitive? #t
+                      #:include-credentials? #f
+                      backend-baseurl
+                      "/api/authenticate"
+                      (hash 'email email
+                            'passwd password)))
+  (when (not (hash? user-facts)) ;; Uh-oh. Something went wrong
+    (error 'create-session-after-authentication-success! "Cannot retrieve user-facts for ~v" email))
   (create-session! email password
                    #:curator? (if (hash-ref user-facts 'curation #f) #t #f)
                    #:superuser? (if (hash-ref user-facts 'superuser #f) #t #f)))
 
 (define (process-login-credentials request)
-  (define-form-bindings request (email password))
-  (if (or (equal? (string-trim email) "")
-          (equal? (string-trim password) ""))
-      (login-form "Please enter your email address and password.")
-      (match (authenticate-with-server! email password "")
-        [(or "wrong-code" (? eof-object?))
-         (login-form "Something went awry; please try again.")]
-        [(or "emailed" #f)
-         (summarise-code-emailing "Incorrect password, or nonexistent user." email)]
-        [success
-         (create-session-from-authentication-success! email password success)])))
+  (define-form-bindings/trim request (email password))
+  (cond [(or (equal? email "") (equal? password ""))
+         (login-form "Please enter your email address and password.")]
+        [(not (login-password-correct? email password))
+         (login-form "Incorrect password, or nonexistent user.")]
+        [else
+         (create-session-after-authentication-success! email password)]))
 
 (define (register-form #:email [email ""]
+                       #:email_for_code [email_for_code ""]
                        #:code [code ""]
-                       #:error-message [error-message #f])
+                       #:step1a-error-message [step1a-error-message #f]
+                       #:step1b-error-message [step1b-error-message #f]
+                       #:step2-error-message [step2-error-message #f])
   (with-site-config
    (send/suspend/dispatch/dynamic
     (lambda (embed-url)
+      (define challenge (generate-challenge))
       (bootstrap-response "Register/Reset Account"
                           #:title-element ""
                           `(div ((class "registration-step-container"))
@@ -404,10 +408,32 @@
                             (p "Enter your email address below, and we'll send you one.")
                             (form ((class "form-horizontal")
                                    (method "post")
-                                   (action ,(embed-url notify-of-emailing))
+                                   (action ,(embed-url (check-challenge challenge)))
                                    (role "form"))
                                   ,(form-group 1 3 (label "email" "Email address")
-                                               0 5 (email-input "email_for_code"))
+                                               0 5 (email-input "email_for_code" email_for_code))
+                                  ,@(maybe-splice
+                                     step1a-error-message
+                                     (form-group 4 5
+                                                 `(div ((class "alert alert-danger"))
+                                                       (p ,step1a-error-message))))
+                                  ,(form-group 1 3 (label "antispam" "Anti-spam")
+                                               0 5 `(div ((class "form-control-static"))
+                                                         (p "Please help us defend our "
+                                                            "infrastructure from spammers "
+                                                            "by answering the following question.")
+                                                         ,@(maybe-splice
+                                                            step1b-error-message
+                                                            `(div ((class "alert alert-danger"))
+                                                                  (p ,step1b-error-message)))
+                                                         ,(challenge-question challenge)
+                                                         ,(form-group
+                                                           0 2 `(p ((class "form-control-static"))
+                                                                   (b "Answer:"))
+                                                           0 10 (text-input "question_answer"))
+                                                         ,(text-input "body"
+                                                                      #:extra-classes
+                                                                      '("not-shown-to-humans"))))
                                   ,(form-group 4 5 (primary-button "Email me a code"))))
 
                           `(div
@@ -426,57 +452,76 @@
                                   ,(form-group 1 3 (label "password" "Confirm password")
                                                0 5 (password-input "confirm_password"))
                                   ,@(maybe-splice
-                                     error-message
+                                     step2-error-message
                                      (form-group 4 5
                                                  `(div ((class "alert alert-danger"))
-                                                   (p ,error-message))))
+                                                   (p ,step2-error-message))))
                                   ,(form-group 4 5 (primary-button "Continue")))))))))
 
 (define (apply-account-code request)
-  (define-form-bindings request (email code password confirm_password))
+  (define-form-bindings/trim request (email code password confirm_password))
   (define (retry msg)
     (register-form #:email email
                    #:code code
-                   #:error-message msg))
+                   #:step2-error-message msg))
   (cond
-   [(equal? (string-trim email) "")
-    (retry "Please enter your email address.")]
-   [(equal? (string-trim code) "")
-    (retry "Please enter the code you received in your email.")]
-   [(not (equal? password confirm_password))
-    (retry "Please make sure the two password fields match.")]
-   [(equal? (string-trim password) "")
-    (retry "Please enter a password.")]
-   [else
-    (match (authenticate-with-server! email password code)
-      [(? eof-object?)
-       (retry "Something went awry. Please try again.")]
-      ["wrong-code"
-       (retry "The code you entered was incorrect. Please try again.")]
-      [(or "emailed" #f)
-       (retry "Something went awry; you have been emailed another code. Please check your email.")]
-      [success
-       ;; The email and password combo we have been given is good to go.
-       ;; Set a cookie and consider ourselves logged in.
-       (create-session-from-authentication-success! email password success)])]))
+    [(equal? email "")
+     (retry "Please enter your email address.")]
+    [(equal? code "")
+     (retry "Please enter the code you received in your email.")]
+    [(not (equal? password confirm_password))
+     (retry "Please make sure the two password fields match.")]
+    [(equal? password "")
+     (retry "Please enter a password.")]
+    [(not (registration-code-correct? email code))
+     (retry "The code you entered was incorrect. Please try again.")]
+    [else
+     (register-or-update-user! email password)
+     (create-session-after-authentication-success! email password)]))
 
-(define (notify-of-emailing request)
-  (define-form-bindings request (email_for_code))
-  (authenticate-with-server! email_for_code "" "") ;; TODO check result?
-  (summarise-code-emailing "Account registration/reset code emailed" email_for_code))
-
-(define (summarise-code-emailing reason email)
-  (with-site-config
-   (send/suspend/dispatch/dynamic
-    (lambda (embed-url)
-      (bootstrap-response reason
-                          `(p
-                            "We've emailed an account registration/reset code to "
-                            (code ,email) ". Please check your email and then click "
-                            "the button to continue:")
-                          `(a ((class "btn btn-primary")
-                               (href ,(embed-url (lambda (req) (register-form)))))
-                            "Enter your code"))))))
+(define ((check-challenge challenge) request)
+  (define-form-bindings/trim request (email_for_code question_answer))
+  (define (retry msg-a msg-b)
+    (register-form #:email_for_code email_for_code
+                   #:step1a-error-message msg-a
+                   #:step1b-error-message msg-b))
+  (cond
+    [(equal? email_for_code "")
+     (log-info "REGISTRATION/RESET EMAIL: address missing")
+     (retry "Please enter your email address."
+            "Don't forget to answer the new question!")]
+    [(equal? question_answer "")
+     (log-info "REGISTRATION/RESET EMAIL: no challenge answer provided")
+     (retry #f
+            "Please answer the anti-spam question. (It changes each time!)")]
+    [(not (challenge-passed? challenge question_answer))
+     (log-info "REGISTRATION/RESET EMAIL: challenge answer incorrect")
+     (log-info "  ✗ email: ~v" email_for_code)
+     (log-info "  ✗ challenge expr: ~a" (challenge-expr challenge))
+     (log-info "  ✗ expected answer: ~v" (~a (challenge-answer challenge)))
+     (log-info "  ✗ provided answer: ~v" question_answer)
+     (log-info "  ✗ HTTP request details: ~v" request)
+     (retry #f
+            "Unfortunately, that was not the correct answer. Please try this new question.")]
+    [else
+     (log-info "REGISTRATION/RESET EMAIL: sent")
+     (log-info "  ✓ email: ~v" email_for_code)
+     (log-info "  ✓ challenge expr: ~a" (challenge-expr challenge))
+     (log-info "  ✓ expected answer: ~v" (~a (challenge-answer challenge)))
+     (log-info "  ✓ provided answer: ~v" question_answer)
+     (log-info "  ✓ HTTP request details: ~v" request)
+     (send-registration-or-reset-email! email_for_code)
+     (with-site-config
+       (send/suspend/dispatch/dynamic
+        (lambda (embed-url)
+          (bootstrap-response "Account registration/reset code emailed"
+                              `(p
+                                "We've emailed an account registration/reset code to "
+                                (code ,email_for_code) ". Please check your email and then click "
+                                "the button to continue:")
+                              `(a ((class "btn btn-primary")
+                                   (href ,(embed-url (lambda (req) (register-form)))))
+                                  "Enter your code")))))]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -552,6 +597,10 @@
       (string-append (date->string (seconds->date utc #f) #t) " (UTC)")
       "N/A"))
 
+(define (get-implied-docs pkg)
+  (define implied-names (map string->symbol (package-implies pkg)))
+  (append-map package-docs (package-batch-detail implied-names)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Package hashtable getters.
 ;; TODO factor this stuff out into a proper data structure
@@ -582,6 +631,7 @@
 (define (package-last-updated pkg)      (or (@ pkg last-updated) 0))
 (define (package-last-checked pkg)      (or (@ pkg last-checked) 0))
 (define (package-last-edit pkg)         (or (@ pkg last-edit) 0))
+(define (package-date-added pkg)         (or (@ pkg date-added) 0))
 (define (package-authors pkg)           (or (@ pkg authors) '()))
 (define (package-description pkg)       (or (@ pkg description) ""))
 (define (package-tags pkg)              (or (@ pkg tags) '()))
@@ -595,30 +645,50 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (package-summary-table package-names)
+  (define bulk-operations-enabled? (current-user-curator?))
+  (define column-count (+ 4 (if bulk-operations-enabled? 1 0)))
   (define-values (pkg-rows num-todos)
-    (build-pkg-rows/num-todos package-names))
-  `(table
-    ((class "packages sortable") (data-todokey ,(number->string num-todos)))
-    (thead
-     (tr
-      (th 'nbsp)
-      (th "Package")
-      (th "Description")
-      (th "Build")
-      (th ((style "display: none")) 'nbsp))) ;; todokey
-    (tbody
-     ,@(maybe-splice (null? package-names)
-                     `(tr (td ((colspan "4"))
-                              (div ((class "alert alert-info"))
-                                   "No packages found."))))
-     ,@pkg-rows)))
+    (build-pkg-rows/num-todos bulk-operations-enabled? package-names))
+  `(form ((role "form")
+          (action ,(named-url bulk-operation-page))
+          (method "post"))
+    (table
+     ((class "packages sortable") (data-todokey ,(number->string num-todos)))
+     (thead
+      ,@(maybe-splice
+         bulk-operations-enabled?
+         `(tr
+           (td ((colspan ,(~a column-count)))
+               (div ((class "input-group"))
+                    (select ((class "form-control") (id "bulk-action") (name "bulk-action"))
+                            (option ((value "")) "--- Select a bulk action to perform ---")
+                            (option ((value "make-ring-0")) "Set selected packages to ring 0")
+                            (option ((value "make-ring-1")) "Set selected packages to ring 1")
+                            (option ((value "make-ring-2")) "Set selected packages to ring 2")
+                            )
+                    (span ((class "input-group-btn"))
+                          (button ((class "btn btn-default") (type "submit"))
+                                  "Go!")))
+               (div ((class "input-group"))
+                    (button ((class "btn")
+                             (type "button")
+                             (onclick "toggleBulkOperationSelections()"))
+                            "Select all/none")))))
+      (tr
+       (th 'nbsp)
+       ,@(maybe-splice bulk-operations-enabled? `(th 'nbsp))
+       (th "Package")
+       (th "Description")
+       (th "Build")
+       (th ((style "display: none")) 'nbsp))) ;; todokey
+     (tbody
+      ,@(maybe-splice (null? package-names)
+                      `(tr (td ((colspan ,(~a column-count)))
+                               (div ((class "alert alert-info"))
+                                    "No packages found."))))
+      ,@pkg-rows))))
 
-(define (get-implied-docs pkg)
-  (let* ([implied-names (package-implies pkg)]
-         [implied-pkgs (package-batch-detail implied-names)])
-    (map package-docs implied-pkgs)))
-
-(define (build-pkg-rows/num-todos package-names)
+(define (build-pkg-rows/num-todos bulk-operations-enabled? package-names)
   ;; Builds the list of rows in the package table as an x-exp.
   ;; Also returns the total number of non-zero todo keys,
   ;; representing packages with outstanding build errors or
@@ -627,12 +697,7 @@
   (define-values (pkg-rows num-todos)
     (for/fold ([pkg-rows null] [num-todos 0])
               ([pkg (package-batch-detail package-names)])
-      (define pkg-docs
-        (let ([implied-docs (get-implied-docs)]
-              [pkg-docs (package-docs pkg)])
-          (if (null? pkg-docs)
-              implied-docs
-              (list* pkg-docs implied-docs))))
+      (define pkg-docs (append (package-docs pkg) (get-implied-docs pkg)))
       (define has-docs? (pair? pkg-docs))
       (define has-readme? (pair? (package-readme-url pkg)))
       (define has-tags? (pair? (package-tags pkg)))
@@ -657,6 +722,13 @@
                  (label-p (if (< todokey 5)
                               "label-warning"
                               "label-danger") "Todo")))
+          ,@(maybe-splice
+             bulk-operations-enabled?
+             `(td (p "Ring " ,(~a (package-ring pkg)))
+                  ,(checkbox-input "selected-packages"
+                                   (package-name pkg)
+                                   #:id #f
+                                   #:extra-classes `("selected-packages"))))
           (td (h2 ,(package-link (package-name pkg)))
               ,(authors-list (package-authors pkg)))
           (td (p ,(if (string=? "" (package-description pkg))
@@ -698,15 +770,18 @@
   (define dep-failure-log-url (package-build-dep-failure-log pkg))
   (define test-failure-log-url (package-build-test-failure-log pkg))
   (define test-success-log-url (package-build-test-success-log pkg))
+  (define conflicts-log-url (package-build-conflicts-log pkg))
 
-  (define td-class (cond [failure-log-url "build_red"]
+  (define td-class (cond [(or failure-log-url conflicts-log-url) "build_red"]
                          [(not success-log-url) ""]
                          [(or dep-failure-log-url test-failure-log-url) "build_yellow"]
                          [else "build_green"]))
 
   `(td ((class ,td-class))
-       ,@(for/list [(e (list (list failure-log-url "" "fails")
-                             (list success-log-url "" "succeeds")
+       ,@(for/list [(e (list (if failure-log-url
+                               (list failure-log-url "" "fails")
+                               (list success-log-url "" "succeeds"))
+                             (list conflicts-log-url "; has " "conflicts")
                              (list dep-failure-log-url "; has " "dependency problems")
                              (list test-failure-log-url "; has " "failing tests")))]
            (match-define (list u p l) e)
@@ -719,7 +794,7 @@
   (parameterize ((bootstrap-active-navigation nav-index)
                  (bootstrap-page-scripts (list (static-resource-url "/searchbox.js")
                                                (static-resource-url "/index.js")
-                                               (static-resource-url "/todos.js"))))
+                                               (static-resource-url "/package-list.js"))))
     (define package-name-list (package-search "" '((main-distribution #f)
                                                    (main-tests #f)
                                                    (deprecated #f))))
@@ -733,9 +808,9 @@
            `(div ((class "jumbotron"))
                  (h1 "Racket Packages")
                  (p "These are the packages in the official "
-                    (a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
+                    (a ((href "https://docs.racket-lang.org/pkg/getting-started.html"))
                        "package catalog") ".")
-                 (p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
+                 (p (a ((href "https://docs.racket-lang.org/pkg/cmdline.html"))
                        (kbd "raco pkg install " (var "package-name")))
                     " installs a package.")
                  (p "You can "
@@ -805,10 +880,17 @@
                        `(ul (li (a ((href ,(main-page-url)))
                                    "Return to the package index"))))))
 
+(define (current-user-superuser?)
+  (and (current-session)
+       (session-superuser? (current-session))))
+
+(define (current-user-curator?)
+  (and (current-session)
+       (session-curator? (current-session))))
+
 (define (current-user-may-edit? pkg)
   (or (member (current-email) (package-authors pkg))
-      (and (current-session)
-           (session-superuser? (current-session)))))
+      (current-user-superuser?)))
 
 (define (package-page request package-name-str)
   (define package-name (string->symbol package-name-str))
@@ -831,6 +913,7 @@
       (let ((default-version (package-default-version pkg)))
         (bootstrap-response (~a package-name)
           #:title-element ""
+          #:description (package-description pkg)
           `(div ((class "jumbotron"))
                 (h1 ,(~a package-name))
                 (p ,(package-description pkg))
@@ -935,9 +1018,7 @@
                   (tr (th "Ring")
                       (td ,(~a (or (package-ring pkg) "N/A"))
                           ,@(maybe-splice
-                             (and (package-ring pkg)
-                                  (current-session)
-                                  (session-curator? (current-session)))
+                             (and (package-ring pkg) (current-user-curator?))
                              " "
                              (ring-change-link pkg (- (package-ring pkg) 1) 'blacktriangledown)
                              (ring-change-link pkg (+ (package-ring pkg) 1) 'blacktriangle))))
@@ -988,7 +1069,7 @@
                                  (values k v))))
                       (maybe-splice
                        (not (hash-empty? vs))
-                       `(tr (th "Versions")
+                       `(tr (th (a ([href "https://docs.racket-lang.org/pkg/getting-started.html#%28part._.Version_.Exceptions%29"]) "Version Exceptions"))
                             (td (table ((class "package-versions"))
                                        (tr (th "Version")
                                            (th "Source")
@@ -1005,6 +1086,8 @@
                       (td ,(utc->string (package-last-checked pkg))))
                   (tr (th "Last edited")
                       (td ,(utc->string (package-last-edit pkg))))
+                  (tr (th "Date added")
+                      (td ,(utc->string (package-date-added pkg))))
                   (tr (th "Modules")
                       (td (ul ((class "module-list"))
                               ,@(for/list ((mod (package-modules pkg)))
@@ -1128,18 +1211,7 @@
                             ,(textfield "g_host_port" "Host" g-host+port)
                             ,(textfield "g_repo" "Repository" g-repo "user/repo")
                             ,(textfield "g_commit" "Branch or commit" g-commit "master")
-                            ,(textfield "g_path" "Path within repository" g-path)
-                            ,(row #:id (group-name "g_transport")
-                                  0 3
-                                  (label (control-name "g_transport") "Transport")
-                                  0 9
-                                  `(select ((id ,(control-name "g_transport"))
-                                            (name ,(control-name "g_transport")))
-                                           ,@(for/list [(t (list "git" "https" "http"))]
-                                               `(option ((value ,t)
-                                                         ,@(maybe-splice (equal? t g-transport)
-                                                                         '(selected "selected")))
-                                                        ,t)))))))))
+                            ,(textfield "g_path" "Path within repository" g-path))))))
 
           (tr (td ((colspan "2"))
                   (div ((class "form-inline"))
@@ -1236,7 +1308,7 @@
 
 (define ((update-draft draft0) request)
   (define draft (read-draft-form draft0 (request-bindings request)))
-  (define-form-bindings request (action new_version))
+  (define-form-bindings/trim request (action new_version))
   (match action
     ["save_changes"
      (if (save-draft! draft)
@@ -1248,7 +1320,7 @@
                        draft))]
     ["add_version"
      (cond
-      [(equal? (string-trim new_version) "")
+      [(equal? new_version "")
        (package-form "Please enter a version number to add." draft)]
       [(assoc new_version (draft-package-versions draft))
        (package-form (format "Could not add version ~a, as it already exists." new_version)
@@ -1272,12 +1344,10 @@
       (g (string->symbol (format "version__~a__~a" version name)) d))
     (define type (vg 'type "simple"))
     (define simple_url (vg 'simple_url ""))
-    (define g_transport (vg 'g_transport ""))
     (define g_host_port (vg 'g_host_port ""))
     (define g_repo0 (vg 'g_repo ""))
     (define g_repo (cond
                      [(regexp-match #rx"[.]git$" g_repo0) g_repo0]
-                     [(equal? g_transport "git") g_repo0]
                      [else (string-append g_repo0 ".git")]))
     (define g_commit0 (vg 'g_commit ""))
     (define g_path (vg 'g_path ""))
@@ -1291,7 +1361,7 @@
       (match type
         ["simple" simple_url]
         ["git" (unparse-package-source (git-source "" #f #f
-                                                   (string->symbol g_transport)
+                                                   'https
                                                    g_host
                                                    g_port
                                                    g_repo
@@ -1411,27 +1481,35 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (update-package-ring-page request package-name-str proposed-new-ring)
-  (define new-ring (clamp-ring proposed-new-ring))
   (authentication-wrap/require-login
    #:request request
-   (when (session-curator? (current-session))
-     (when (simple-json-rpc! backend-baseurl
-                             "/api/package/curate"
-                             (hash 'pkg package-name-str
-                                   'ring new-ring))
-       (define old-pkg (package-detail (string->symbol package-name-str)))
-       (let* ((new-pkg (hash-set old-pkg 'ring new-ring))
-              (completion-ch (make-channel)))
-         (replace-package! completion-ch old-pkg new-pkg)
-         (channel-get completion-ch))))
+   (update-package-rings! (list package-name-str) proposed-new-ring)
    (bootstrap-redirect (view-package-url package-name-str))))
 
+(define (update-package-rings! package-name-strings proposed-new-ring)
+  (if (not (current-user-curator?))
+      #f
+      (let ((new-ring (clamp-ring proposed-new-ring)))
+        (if (not (simple-json-rpc! backend-baseurl
+                                   "/api/package/curate"
+                                   (hash 'package-names package-name-strings
+                                         'ring new-ring)))
+            #f
+            (begin
+              (for [(package-name-str (in-list package-name-strings))]
+                (define old-pkg (package-detail (string->symbol package-name-str)))
+                (define new-pkg (hash-set old-pkg 'ring new-ring))
+                (let ((completion-ch (make-channel)))
+                  (replace-package! completion-ch old-pkg new-pkg)
+                  (channel-get completion-ch)))
+              #t)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (search-page request)
   (parameterize ((bootstrap-active-navigation nav-search)
                  (bootstrap-page-scripts (list (static-resource-url "/searchbox.js")
-                                               (static-resource-url "/todos.js"))))
+                                               (static-resource-url "/package-list.js"))))
     (authentication-wrap
      #:request request
      (define-form-bindings request ([search-text q ""]
@@ -1452,16 +1530,16 @@
                                         0 10(text-input "tags" tags-input
                                                         #:placeholder
                                                         "tag1 tag2 tag3 ..."))
-                           ,(form-group 2 10 (primary-button (glyphicon 'search) " Search"))
-                           (div ((class "search-results"))
-                                ,@(maybe-splice
-                                   (or (pair? tags) (not (equal? search-text "")))
-                                   (let ((package-name-list (package-search search-text tags)))
-                                     `(div
-                                       (p ((class "package-count"))
-                                          ,(format "~a packages found" (length package-name-list)))
-                                       (p ((class "package-count") (id "todo-msg")) "")
-                                       ,(package-summary-table package-name-list))))))))))
+                           ,(form-group 2 10 (primary-button (glyphicon 'search) " Search")))
+                         `(div ((class "search-results"))
+                               ,@(maybe-splice
+                                  (or (pair? tags) (not (equal? search-text "")))
+                                  (let ((package-name-list (package-search search-text tags)))
+                                    `(div
+                                      (p ((class "package-count"))
+                                         ,(format "~a packages found" (length package-name-list)))
+                                      (p ((class "package-count") (id "todo-msg")) "")
+                                      ,(package-summary-table package-name-list)))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -1486,6 +1564,46 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define (ping-page request)
+  (response/full 200 #"Alive" (current-seconds) #"text/plain" '() '()))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (bulk-operation-page request)
+  (authentication-wrap/require-login
+   #:request request
+   (cond
+     [(not (or (current-user-curator?) (current-user-superuser?)))
+      (bootstrap-redirect (main-page-url))]
+     [else
+      (define bindings (request-bindings request))
+      (define action (extract-binding/single 'bulk-action bindings))
+      (define package-names (extract-bindings 'selected-packages bindings))
+      (cond
+        [(equal? action "")
+         (bootstrap-response "No action selected.")]
+        [else
+         (send/suspend/dynamic
+          (lambda (k-url)
+            (bootstrap-response "Confirm bulk operation"
+                                `(div ((class "confirm-bulk-operation"))
+                                      (h2 "You are about to " (code ,action) " the following packages:")
+                                      (ul ,@(map (lambda (p) `(li ,p))
+                                                 package-names))
+                                      (p "This cannot be undone.")
+                                      (form ((action ,k-url) (method "post"))
+                                            (button ((class "btn btn-default") (type "submit"))
+                                                    "Confirm bulk operation"))))))
+         (match action
+           ["make-ring-0" (update-package-rings! package-names 0)]
+           ["make-ring-1" (update-package-rings! package-names 1)]
+           ["make-ring-2" (update-package-rings! package-names 2)]
+           [_ (error 'bulk-operation-page "No such action: ~a" action)])
+         (bootstrap-response "Bulk operation complete."
+                             `(a ((href ,(main-page-url))) "Return to main index page."))])])))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 ;; TODO: fold the collection of this information into the package
 ;; database itself.
 (define (update-external-package-information! package-name)
@@ -1532,7 +1650,7 @@
      (match/values (http/simple-interpret-response
                     (http/follow-redirects
                      #"HEAD"
-                     (http-sendrecv/url readme-u #:method #"HEAD")))
+                     (custom-http-sendrecv/url readme-u #:method #"HEAD")))
        [('success _headers _body) (url->string readme-u)]
        [(_ _ _) #f])))
 
@@ -1546,7 +1664,7 @@
      (match/values (http/simple-interpret-response
                     (http/follow-redirects
                      #"GET"
-                     (http-sendrecv/url u #:method #"GET")))
+                     (custom-http-sendrecv/url u #:method #"GET")))
        [('success _headers body)
         (and (regexp-match? #px"(?i:id=.readme.)" body)
              (string-append (url->string u) "#readme"))]

src/static.rkt

@@ -173,12 +173,14 @@
 (define (put/bytes^ p cb mt h)
   (semaphore-wait put-bytes-sema)
   (thread
-   (lambda ()
-     (with-handlers ((values (lambda (e)
-                               (semaphore-post put-bytes-sema)
-                               (raise e))))
-       (put/bytes p cb mt h)
-       (semaphore-post put-bytes-sema)))))
+   (procedure-rename
+    (lambda ()
+      (with-handlers ((values (lambda (e)
+                                (semaphore-post put-bytes-sema)
+                                (raise e))))
+        (put/bytes p cb mt h)
+        (semaphore-post put-bytes-sema)))
+    (string->symbol (format "~v" (list 'put/bytes^ p))))))
 
 (define (aws-put-file! index absolute-path content-bytes mime-type [headers '()])
   (define relative-path (absolute-path->relative-path absolute-path))

src/users.rkt

@@ -0,0 +1,84 @@
+#lang racket/base
+;; User management - userdb, plus registration and emailing
+
+(provide login-password-correct?
+         send-registration-or-reset-email!
+         registration-code-correct?
+         register-or-update-user!)
+
+(require net/sendmail)
+(require reloadable)
+(require infrastructure-userdb)
+(require "config.rkt")
+(require "hash-utils.rkt")
+
+(define-logger racket-pkg-website/users)
+
+(define userdb (userdb-config (@ (config) user-directory)
+                              #t ;; writeable!
+                              ))
+
+(define *codes*
+  (make-persistent-state '*codes* (lambda () (make-registration-state))))
+
+(define (login-password-correct? email given-password)
+  (log-racket-pkg-website/users-info "Checking password for ~v" email)
+  (user-password-correct? (lookup-user userdb email) given-password))
+
+(define (send-registration-or-reset-email! email)
+  (if (user-exists? userdb email)
+      (send-password-reset-email! email)
+      (send-account-registration-email! email)))
+
+(define (sender-address)
+  (or (@ (config) email-sender-address)
+      "pkgs@racket-lang.org"))
+
+(log-racket-pkg-website/users-info "Will use sender address ~v" (sender-address))
+
+(define (send-password-reset-email! email)
+  (log-racket-pkg-website/users-info "Sending password reset email to ~v" email)
+  (send-mail-message
+   (sender-address)
+   "Account password reset for Racket Package Catalog"
+   (list email)
+   '()
+   '()
+   (list
+    "Someone tried to login with your email address for an account on the Racket Package Catalog, but failed."
+    "If this was you, please use this code to reset your password:"
+    ""
+    (generate-registration-code! (*codes*) email)
+    ""
+    "This code will expire, so if it is not available, you'll have to try again.")))
+
+(define (send-account-registration-email! email)
+  (log-racket-pkg-website/users-info "Sending account registration email to ~v" email)
+  (send-mail-message
+   (sender-address)
+   "Account confirmation for Racket Package Catalog"
+   (list email)
+   '()
+   '()
+   (list
+    "Someone tried to register your email address for an account on the Racket Package Catalog."
+    "If you want to proceed, use this code:"
+    ""
+    (generate-registration-code! (*codes*) email)
+    ""
+    "This code will expire, so if it is not available, you'll have to try to register again.")))
+
+(define (registration-code-correct? email given-code)
+  (log-racket-pkg-website/users-info "Checking registration code for ~v" email)
+  (check-registration-code (*codes*)
+                           email
+                           given-code
+                           (lambda () #t)
+                           (lambda () #f)))
+
+(define (register-or-update-user! email password)
+  (log-racket-pkg-website/users-info "Updating user record ~v" email)
+  (save-user! userdb
+              (user-password-set (or (lookup-user userdb email)
+                                     (make-user email password))
+                                 password)))

static/editpackage.js

@@ -34,7 +34,7 @@ function preenSourceType(e) {
     case "git":
       previewGroup.show();
       pieces = showhide(false, true, true, true, true, true);
-      previewUrl = pieces[1] + "://" + pieces[2] + "/" + pieces[3] +
+      previewUrl = "https" + "://" + pieces[2] + "/" + pieces[3] +
         (pieces[5] ? "?path=" + pieces[5] : "") +
         (pieces[4] && (pieces[4] !== 'master') ? '#' + pieces[4] : "");
       break;

static/package-list.js

@@ -1,3 +1,12 @@
+// Functions related to package listings as produced by `package-summary-table` in site.rkt
+
+function toggleBulkOperationSelections() {
+  var checkboxes = Array.from(document.querySelectorAll("input.selected-packages"));
+  var anySelected = checkboxes.some(function (n) { return n.checked; });
+  var newState = anySelected ? false : true;
+  checkboxes.forEach(function (n) { n.checked = newState; });
+}
+
 $(function() {
   "use strict";
 

static/style.css

@@ -83,6 +83,10 @@ input#new_version {
     width: 6em;
 }
 
+.not-shown-to-humans {
+    display: none;
+}
+
 .confirm-package-deletion {
     background-color: red;
     padding: 2em;
@@ -98,6 +102,20 @@ input#new_version {
     margin: 0;
 }
 
+.confirm-bulk-operation {
+    background-color: #ffdddd;
+    padding: 2em;
+    display: block;
+    border: solid black 1rem;
+    font-size: 120%;
+}
+.confirm-bulk-operation h2 {
+    margin: 0;
+}
+.confirm-bulk-operation ul {
+    margin: 2em;
+}
+
 .package-count {
     font-size: 120%;
 }