README.md

@@ -4,10 +4,7 @@
 
 You will need to install the following Racket packages:
 
-    raco pkg install --skip-installed \
+    raco pkg install reloadable
-         'https://github.com/racket/infrastructure-userdb.git#main' \
-         reloadable \
-         aws
 
 ## Configuration
 
@@ -53,11 +50,6 @@ 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,8 +9,6 @@
               (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

@@ -0,0 +1,13 @@
+#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,17 +1,9 @@
 #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 (format "file://~a/pkgs-all.json.gz" pkg-index-generated-directory)
+            'package-index-url "file:///home/tonyg/public_html/pkg-index-static/pkgs-all.json.gz"
-            'user-directory (build-path (find-system-path 'home-dir)
-                                        "src/pkg-index/official/root/users.new")
-            'email-sender-address "tonyg@racket-lang.org"
             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
             ;; Either:
             ;;
@@ -30,7 +22,8 @@
             ;; 'dynamic-static-urlprefix "https://localhost:8446"
             ;;
             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-            'dynamic-urlprefix "http://localhost:8444"
+            'dynamic-urlprefix "https://localhost:8444"
-            'backend-baseurl "http://localhost:8445"
+            'backend-baseurl "https://localhost:8445"
-            'pkg-index-generated-directory pkg-index-generated-directory
+            'pkg-index-generated-directory (build-path (find-system-path 'home-dir)
+                                                       "public_html/pkg-index-static")
             ))

configs/tonyg/nginx.locals3proxy.conf

@@ -0,0 +1,30 @@
+# 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

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

on-ping-service-failure.sh

@@ -1,39 +0,0 @@
-#!/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

@@ -1,32 +0,0 @@
-#!/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,22 +12,7 @@ if [ ! -f configs/${CONFIG}.rkt ]; then
     exit 1
 fi
 
-PLTSTDERR="
+PLTSTDERR="info warning@cm warning@compiler/cm warning@module-prefetch warning@setup/parallel-build warning@cm-accomplice warning@online-check-syntax error@racket/contract"
-	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,7 +53,6 @@
                             #:code [code 200]
                             #:message [message #"Okay"]
                             #:body-class [body-class #f]
-                            #:description [description #f]
 			    .
 			    body-contents)
   (response/xexpr
@@ -66,10 +65,6 @@
 	   (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

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

@@ -1,36 +0,0 @@
-#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,13 +1,10 @@
 #lang racket/base
 ;; A utilities module :-/
 
-(provide maybe-splice
-         define-form-bindings/xform
-	 define-form-bindings
-         define-form-bindings/trim)
-
 (require web-server/servlet)
-(require (only-in racket/string string-trim))
+
+(provide maybe-splice
+	 define-form-bindings)
 
 ;; Boolean XExpr ... -> (Listof XExpr)
 ;; Useful for optionally splicing in some contents to a list.
@@ -15,28 +12,22 @@
 (define-syntax-rule (maybe-splice guard contents ...)
   (if guard (list contents ...) '()))
 
-(define-syntax define-form-bindings*
-  (syntax-rules ()
-    [(_ bs xform ())
-     (begin)]
-    [(_ bs xform ([name fieldname defaultval] rest ...))
-     (begin (define name (if (exists-binding? 'fieldname bs)
-                             (xform (extract-binding/single 'fieldname bs))
-                             defaultval))
-            (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 ...)))
+  (begin (define bs (request-bindings req))
+         (define-form-bindings* bs (specs ...))))
 
-(define-syntax-rule (define-form-bindings/trim req (specs ...))
+(define-syntax define-form-bindings*
-  (define-form-bindings/xform req string-trim (specs ...)))
+  (syntax-rules ()
+    [(_ bs ())
+     (begin)]
+    [(_ bs ([name fieldname defaultval] rest ...))
+     (begin (define name (if (exists-binding? 'fieldname bs)
+                             (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 ...))]))

src/http-utils.rkt

@@ -6,7 +6,7 @@
          http-interpret-response
          http-simple-interpret-response
          http-follow-redirects
-         custom-http-sendrecv/url
+         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 net/url)
+(require (except-in net/url http-sendrecv/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)
+              (begin0 (port->bytes response-body-port)
-              (close-input-port response-body-port))
+                (close-input-port response-body-port))
-            response-body-port)))
+              response-body-port)))
 
 (define (http-simple-interpret-response status-line response-headers response-body-port)
   (define-values (_http-version
@@ -79,39 +79,64 @@
           headers
           body))
 
-(define ((check-response method remaining-redirect-count)
+(define ((http-follow-redirects method
+                                #:version [version #"1.1"])
          status-line
          response-headers
          response-body-port)
-  (log-debug "http-follow-redirects: Checking request result: ~a\n" status-line)
+  (define ((check-response remaining-redirect-count)
-  (define-values (http-version status-code reason-phrase)
+           status-line
-    (parse-status-line status-line))
+           response-headers
-  (if (and (positive? remaining-redirect-count)
+           response-body-port)
-           (eq? (http-classify-status-code status-code) 'redirection))
+    (log-debug "http-follow-redirects: Checking request result: ~a\n" status-line)
-    (match (assq 'location (parse-headers response-headers))
+    (define-values (http-version status-code reason-phrase) (parse-status-line status-line))
-      [#f (values status-line response-headers response-body-port)]
+    (if (and (positive? remaining-redirect-count)
-      [(cons _location-header-label location-urlbytes)
+             (eq? (http-classify-status-code status-code) 'redirection))
-       (define location (string->url (bytes->string/latin-1 location-urlbytes)))
+        (match (assq 'location (parse-headers response-headers))
-       (void (port->bytes response-body-port)) ;; consume and discard input
+          [#f (values status-line response-headers response-body-port)]
-       (close-input-port response-body-port)
+          [(cons _location-header-label location-urlbytes)
-       (log-debug "http-follow-redirects: Following redirection to ~a\n"
+           (define location (string->url (bytes->string/latin-1 location-urlbytes)))
-                  location-urlbytes)
+           (void (port->bytes response-body-port)) ;; consume and discard input
-       (call-with-values (lambda () (custom-http-sendrecv/url location
+           (close-input-port response-body-port)
-                                                              #:method method))
+           (log-debug "http-follow-redirects: Following redirection to ~a\n" location-urlbytes)
-                         (check-response method (- remaining-redirect-count 1)))])
+           (call-with-values (lambda () (http-sendrecv/url location
-    (values status-line response-headers response-body-port)))
+                                                           #:version version
-
+                                                           #:method method))
-(define ((http-follow-redirects method)
+                             (check-response (- remaining-redirect-count 1)))])
-         status-line
+        (values status-line response-headers response-body-port)))
-         response-headers
+  ((check-response (http-redirection-limit))
-         response-body-port)
-  ((check-response method (http-redirection-limit))
    status-line
    response-headers
    response-body-port))
 
-(define (custom-http-sendrecv/url u #:method method)
+;; Already present in net/url, but that variant doesn't take #:version
-  (http-sendrecv/url u #:method method))
+;; 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-syntax-rule (http/interpret-response customization ... req-expr)
   (call-with-values (lambda () req-expr)
@@ -126,15 +151,10 @@
                     (http-follow-redirects customization ...)))
 
 (module+ test
-  (define parent-cust (current-custodian))
+  (require rackunit)
-  (define this-cust (make-custodian))
+
-  (parameterize ([current-custodian this-cust])
+  (http/simple-interpret-response
-    (for ([i (in-range 100)])
+   (http/follow-redirects
-      (http/simple-interpret-response
+    #"HEAD"
-       (http/follow-redirects
+    (http-sendrecv/url (string->url "http://google.com/") #:method #"HEAD")))
-        #"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

@@ -1,21 +0,0 @@
-#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,12 +1,19 @@
 #lang racket/base
-;; Outer startup module - delegates to main-inner.rkt after installing a custodian
 
-(provide main
+(provide main)
-         outermost-custodian)
 
-(define *outermost-custodian* (current-custodian))
+(require reloadable)
-(define (outermost-custodian) *outermost-custodian*)
+(require "entrypoint.rkt")
 
 (define (main [config (hash)])
-  (parameterize ((current-custodian (make-custodian (outermost-custodian))))
+  (make-persistent-state '*config* (lambda () config))
-    ((dynamic-require "main-inner.rkt" 'main) 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")))

src/packages.rkt

@@ -34,7 +34,7 @@
 
 (define package-index-url
   (or (@ (config) package-index-url)
-      "https://pkgs.racket-lang.org/pkgs-all.json.gz"))
+      "http://pkgs.racket-lang.org/pkgs-all.json.gz"))
 
 (define package-fetch-interval
   (* (or (@ (config) package-fetch-interval)
@@ -73,12 +73,9 @@
   (eq? pkg 'tombstone))
 
 (define (asynchronously-fetch-remote-packages state)
-  (thread
+  (thread (lambda ()
-   (procedure-rename
+            (define raw-remote-packages (fetch-remote-packages))
-    (lambda ()
+            (manager-rpc 'refresh-packages! raw-remote-packages)))
-      (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)]))
 
@@ -290,55 +287,19 @@
                              ;; 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 text-list (remove-duplicates (string-split text)))
+  (define res (map (lambda (r) (regexp (regexp-quote r #f))) (string-split text)))
-  (define res (map (lambda (r) (regexp (regexp-quote r #f))) text-list))
   (define packages (manager-rpc 'packages))
-
+  (sort-package-names
-  (sort-package-names/priority
+   (filter (lambda (package-name)
-   text-list
+             (define pkg (hash-ref packages package-name))
-   (filter (lambda (package-pair)
-             (define pkg (cdr package-pair))
              (andmap (package-text-matches? pkg) res))
-           (hash->list
+           (hash-keys
             (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)
+                                     ((if include? values not) (@ref (@ pkg search-terms) tag-name))))
-                                      (@ref (@ pkg search-terms) tag-name))))
                 (values package-name pkg)))))))
 
 (define (packages-jsexpr)

src/signals.rkt

@@ -51,10 +51,5 @@
                        (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 (only-in racket/string string-join string-split))
+(require racket/string)
 (require racket/port)
 (require (only-in racket/list filter-map drop-right))
 (require (only-in racket/exn exn->string))
-(require net/url)
+(require (except-in net/url http-sendrecv/url))
 (require net/uri-codec)
-(require web-server/servlet)
+(require (except-in web-server/servlet http-sendrecv/url))
 (require json)
 (require "gravatar.rkt")
 (require "bootstrap.rkt")
@@ -31,8 +31,6 @@
 (require "static.rkt")
 (require "package-source.rkt")
 (require "http-utils.rkt")
-(require "challenge.rkt")
-(require "users.rkt")
 
 (define static-urlprefix
   (or (@ (config) static-urlprefix)
@@ -54,7 +52,7 @@
 (define nav-search "Search")
 
 (define (navbar-header)
-  `(a ((href "https://www.racket-lang.org/"))
+  `(a ((href "http://www.racket-lang.org/"))
     (img ((src ,(static-resource-url "/logo-and-text.png"))
           (height "60")
           (alt "Racket Package Index")))))
@@ -64,7 +62,7 @@
       "https://pkgd.racket-lang.org"))
 
 (define default-empty-parsed-package-source
-  (git-source "https://github.com/" #f 'git 'git "github.com" #f "" "" ""))
+  (git-source "git://github.com/" #f 'git 'git "github.com" #f "" "" ""))
 
 (define COOKIE "pltsession")
 
@@ -74,7 +72,7 @@
 
 (define pkg-build-baseurl
   (or (@ (config) pkg-build-baseurl)
-      "https://pkg-build.racket-lang.org/"))
+      "http://pkg-build.racket-lang.org/"))
 
 (struct draft-package (old-name name description authors tags versions) #:prefab)
 
@@ -97,8 +95,6 @@
    [("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)
@@ -146,11 +142,11 @@
                     (,nav-search ,(named-url search-page))
                     ("About"
                      (("The Racket Package System"
-                       "https://docs.racket-lang.org/pkg/getting-started.html")
+                       "http://docs.racket-lang.org/pkg/getting-started.html")
                       ("Package Builds" "https://pkg-build.racket-lang.org/about.html")))
                     ((div ,(glyphicon 'download-alt)
                           " Download Racket")
-                     "https://download.racket-lang.org/")
+                     "http://download.racket-lang.org/")
                     ))
                  (bootstrap-static-urlprefix
                   (if (rendering-static-page?)
@@ -247,23 +243,17 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define ((generic-input type #:extra-classes [extra-classes1 '()])
+(define ((generic-input type) name [initial-value ""] #:placeholder [placeholder #f])
-         name
+  `(input ((class "form-control")
-         [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)
-           ,@(maybe-splice id `(id ,id))
+           (id ,name)
            ,@(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)))
@@ -344,7 +334,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)))))
@@ -359,39 +349,45 @@
                                              (p ,error-message))))
                             ,(form-group 4 5 (primary-button "Log in"))))))))
 
-(define (create-session-after-authentication-success! email password)
+(define (authenticate-with-server! email password code)
-  (define user-facts
+  (simple-json-rpc! #:sensitive? #t
-    (simple-json-rpc! #:sensitive? #t
+                    #:include-credentials? #f
-                      #:include-credentials? #f
+                    backend-baseurl
-                      backend-baseurl
+                    "/api/authenticate"
-                      "/api/authenticate"
+                    (hash 'email email
-                      (hash 'email email
+                          'passwd password
-                            'passwd password)))
+                          'code code)))
-  (when (not (hash? user-facts)) ;; Uh-oh. Something went wrong
+
-    (error 'create-session-after-authentication-success! "Cannot retrieve user-facts for ~v" email))
+(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)]))
   (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/trim request (email password))
+  (define-form-bindings request (email password))
-  (cond [(or (equal? email "") (equal? password ""))
+  (if (or (equal? (string-trim email) "")
-         (login-form "Please enter your email address and password.")]
+          (equal? (string-trim password) ""))
-        [(not (login-password-correct? email password))
+      (login-form "Please enter your email address and password.")
-         (login-form "Incorrect password, or nonexistent user.")]
+      (match (authenticate-with-server! email password "")
-        [else
+        [(or "wrong-code" (? eof-object?))
-         (create-session-after-authentication-success! email password)]))
+         (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 (register-form #:email [email ""]
-                       #:email_for_code [email_for_code ""]
                        #:code [code ""]
-                       #:step1a-error-message [step1a-error-message #f]
+                       #:error-message [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"))
@@ -408,32 +404,10 @@
                             (p "Enter your email address below, and we'll send you one.")
                             (form ((class "form-horizontal")
                                    (method "post")
-                                   (action ,(embed-url (check-challenge challenge)))
+                                   (action ,(embed-url notify-of-emailing))
                                    (role "form"))
                                   ,(form-group 1 3 (label "email" "Email address")
-                                               0 5 (email-input "email_for_code" email_for_code))
+                                               0 5 (email-input "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
@@ -452,76 +426,57 @@
                                   ,(form-group 1 3 (label "password" "Confirm password")
                                                0 5 (password-input "confirm_password"))
                                   ,@(maybe-splice
-                                     step2-error-message
+                                     error-message
                                      (form-group 4 5
                                                  `(div ((class "alert alert-danger"))
-                                                   (p ,step2-error-message))))
+                                                   (p ,error-message))))
                                   ,(form-group 4 5 (primary-button "Continue")))))))))
 
 (define (apply-account-code request)
-  (define-form-bindings/trim request (email code password confirm_password))
+  (define-form-bindings request (email code password confirm_password))
   (define (retry msg)
     (register-form #:email email
                    #:code code
-                   #:step2-error-message msg))
+                   #:error-message msg))
   (cond
-    [(equal? email "")
+   [(equal? (string-trim email) "")
-     (retry "Please enter your email address.")]
+    (retry "Please enter your email address.")]
-    [(equal? code "")
+   [(equal? (string-trim code) "")
-     (retry "Please enter the code you received in your email.")]
+    (retry "Please enter the code you received in your email.")]
-    [(not (equal? password confirm_password))
+   [(not (equal? password confirm_password))
-     (retry "Please make sure the two password fields match.")]
+    (retry "Please make sure the two password fields match.")]
-    [(equal? password "")
+   [(equal? (string-trim password) "")
-     (retry "Please enter a password.")]
+    (retry "Please enter a password.")]
-    [(not (registration-code-correct? email code))
+   [else
-     (retry "The code you entered was incorrect. Please try again.")]
+    (match (authenticate-with-server! email password code)
-    [else
+      [(? eof-object?)
-     (register-or-update-user! email password)
+       (retry "Something went awry. Please try again.")]
-     (create-session-after-authentication-success! email password)]))
+      ["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)])]))
 
-(define ((check-challenge challenge) request)
+(define (notify-of-emailing request)
-  (define-form-bindings/trim request (email_for_code question_answer))
+  (define-form-bindings request (email_for_code))
-  (define (retry msg-a msg-b)
+  (authenticate-with-server! email_for_code "" "") ;; TODO check result?
-    (register-form #:email_for_code email_for_code
+  (summarise-code-emailing "Account registration/reset code emailed" email_for_code))
-                   #:step1a-error-message msg-a
+
-                   #:step1b-error-message msg-b))
+(define (summarise-code-emailing reason email)
-  (cond
+  (with-site-config
-    [(equal? email_for_code "")
+   (send/suspend/dispatch/dynamic
-     (log-info "REGISTRATION/RESET EMAIL: address missing")
+    (lambda (embed-url)
-     (retry "Please enter your email address."
+      (bootstrap-response reason
-            "Don't forget to answer the new question!")]
+                          `(p
-    [(equal? question_answer "")
+                            "We've emailed an account registration/reset code to "
-     (log-info "REGISTRATION/RESET EMAIL: no challenge answer provided")
+                            (code ,email) ". Please check your email and then click "
-     (retry #f
+                            "the button to continue:")
-            "Please answer the anti-spam question. (It changes each time!)")]
+                          `(a ((class "btn btn-primary")
-    [(not (challenge-passed? challenge question_answer))
+                               (href ,(embed-url (lambda (req) (register-form)))))
-     (log-info "REGISTRATION/RESET EMAIL: challenge answer incorrect")
+                            "Enter your code"))))))
-     (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")))))]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -597,10 +552,6 @@
       (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
@@ -631,7 +582,6 @@
 (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) '()))
@@ -645,50 +595,30 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (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 bulk-operations-enabled? package-names))
+    (build-pkg-rows/num-todos package-names))
-  `(form ((role "form")
+  `(table
-          (action ,(named-url bulk-operation-page))
+    ((class "packages sortable") (data-todokey ,(number->string num-todos)))
-          (method "post"))
+    (thead
-    (table
+     (tr
-     ((class "packages sortable") (data-todokey ,(number->string num-todos)))
+      (th 'nbsp)
-     (thead
+      (th "Package")
-      ,@(maybe-splice
+      (th "Description")
-         bulk-operations-enabled?
+      (th "Build")
-         `(tr
+      (th ((style "display: none")) 'nbsp))) ;; todokey
-           (td ((colspan ,(~a column-count)))
+    (tbody
-               (div ((class "input-group"))
+     ,@(maybe-splice (null? package-names)
-                    (select ((class "form-control") (id "bulk-action") (name "bulk-action"))
+                     `(tr (td ((colspan "4"))
-                            (option ((value "")) "--- Select a bulk action to perform ---")
+                              (div ((class "alert alert-info"))
-                            (option ((value "make-ring-0")) "Set selected packages to ring 0")
+                                   "No packages found."))))
-                            (option ((value "make-ring-1")) "Set selected packages to ring 1")
+     ,@pkg-rows)))
-                            (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 (build-pkg-rows/num-todos bulk-operations-enabled? package-names)
+(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)
   ;; 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
@@ -697,7 +627,12 @@
   (define-values (pkg-rows num-todos)
     (for/fold ([pkg-rows null] [num-todos 0])
               ([pkg (package-batch-detail package-names)])
-      (define pkg-docs (append (package-docs pkg) (get-implied-docs pkg)))
+      (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 has-docs? (pair? pkg-docs))
       (define has-readme? (pair? (package-readme-url pkg)))
       (define has-tags? (pair? (package-tags pkg)))
@@ -722,13 +657,6 @@
                  (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))
@@ -770,18 +698,15 @@
   (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 [(or failure-log-url conflicts-log-url) "build_red"]
+  (define td-class (cond [failure-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 (if failure-log-url
+       ,@(for/list [(e (list (list failure-log-url "" "fails")
-                               (list failure-log-url "" "fails")
+                             (list success-log-url "" "succeeds")
-                               (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)
@@ -794,7 +719,7 @@
   (parameterize ((bootstrap-active-navigation nav-index)
                  (bootstrap-page-scripts (list (static-resource-url "/searchbox.js")
                                                (static-resource-url "/index.js")
-                                               (static-resource-url "/package-list.js"))))
+                                               (static-resource-url "/todos.js"))))
     (define package-name-list (package-search "" '((main-distribution #f)
                                                    (main-tests #f)
                                                    (deprecated #f))))
@@ -808,9 +733,9 @@
            `(div ((class "jumbotron"))
                  (h1 "Racket Packages")
                  (p "These are the packages in the official "
-                    (a ((href "https://docs.racket-lang.org/pkg/getting-started.html"))
+                    (a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
                        "package catalog") ".")
-                 (p (a ((href "https://docs.racket-lang.org/pkg/cmdline.html"))
+                 (p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
                        (kbd "raco pkg install " (var "package-name")))
                     " installs a package.")
                  (p "You can "
@@ -880,17 +805,10 @@
                        `(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))
-      (current-user-superuser?)))
+      (and (current-session)
+           (session-superuser? (current-session)))))
 
 (define (package-page request package-name-str)
   (define package-name (string->symbol package-name-str))
@@ -913,7 +831,6 @@
       (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))
@@ -1018,7 +935,9 @@
                   (tr (th "Ring")
                       (td ,(~a (or (package-ring pkg) "N/A"))
                           ,@(maybe-splice
-                             (and (package-ring pkg) (current-user-curator?))
+                             (and (package-ring pkg)
+                                  (current-session)
+                                  (session-curator? (current-session)))
                              " "
                              (ring-change-link pkg (- (package-ring pkg) 1) 'blacktriangledown)
                              (ring-change-link pkg (+ (package-ring pkg) 1) 'blacktriangle))))
@@ -1069,7 +988,7 @@
                                  (values k v))))
                       (maybe-splice
                        (not (hash-empty? vs))
-                       `(tr (th (a ([href "https://docs.racket-lang.org/pkg/getting-started.html#%28part._.Version_.Exceptions%29"]) "Version Exceptions"))
+                       `(tr (th "Versions")
                             (td (table ((class "package-versions"))
                                        (tr (th "Version")
                                            (th "Source")
@@ -1086,8 +1005,6 @@
                       (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)))
@@ -1211,7 +1128,18 @@
                             ,(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))))))
+                            ,(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)))))))))
 
           (tr (td ((colspan "2"))
                   (div ((class "form-inline"))
@@ -1308,7 +1236,7 @@
 
 (define ((update-draft draft0) request)
   (define draft (read-draft-form draft0 (request-bindings request)))
-  (define-form-bindings/trim request (action new_version))
+  (define-form-bindings request (action new_version))
   (match action
     ["save_changes"
      (if (save-draft! draft)
@@ -1320,7 +1248,7 @@
                        draft))]
     ["add_version"
      (cond
-      [(equal? new_version "")
+      [(equal? (string-trim 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)
@@ -1344,10 +1272,12 @@
       (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 ""))
@@ -1361,7 +1291,7 @@
       (match type
         ["simple" simple_url]
         ["git" (unparse-package-source (git-source "" #f #f
-                                                   'https
+                                                   (string->symbol g_transport)
                                                    g_host
                                                    g_port
                                                    g_repo
@@ -1481,35 +1411,27 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (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
-   (update-package-rings! (list package-name-str) proposed-new-ring)
+   (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))))
    (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 "/package-list.js"))))
+                                               (static-resource-url "/todos.js"))))
     (authentication-wrap
      #:request request
      (define-form-bindings request ([search-text q ""]
@@ -1530,16 +1452,16 @@
                                         0 10(text-input "tags" tags-input
                                                         #:placeholder
                                                         "tag1 tag2 tag3 ..."))
-                           ,(form-group 2 10 (primary-button (glyphicon 'search) " Search")))
+                           ,(form-group 2 10 (primary-button (glyphicon 'search) " Search"))
-                         `(div ((class "search-results"))
+                           (div ((class "search-results"))
-                               ,@(maybe-splice
+                                ,@(maybe-splice
-                                  (or (pair? tags) (not (equal? search-text "")))
+                                   (or (pair? tags) (not (equal? search-text "")))
-                                  (let ((package-name-list (package-search search-text tags)))
+                                   (let ((package-name-list (package-search search-text tags)))
-                                    `(div
+                                     `(div
-                                      (p ((class "package-count"))
+                                       (p ((class "package-count"))
-                                         ,(format "~a packages found" (length package-name-list)))
+                                          ,(format "~a packages found" (length package-name-list)))
-                                      (p ((class "package-count") (id "todo-msg")) "")
+                                       (p ((class "package-count") (id "todo-msg")) "")
-                                      ,(package-summary-table package-name-list)))))))))
+                                       ,(package-summary-table package-name-list))))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -1564,46 +1486,6 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(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)
@@ -1650,7 +1532,7 @@
      (match/values (http/simple-interpret-response
                     (http/follow-redirects
                      #"HEAD"
-                     (custom-http-sendrecv/url readme-u #:method #"HEAD")))
+                     (http-sendrecv/url readme-u #:method #"HEAD")))
        [('success _headers _body) (url->string readme-u)]
        [(_ _ _) #f])))
 
@@ -1664,7 +1546,7 @@
      (match/values (http/simple-interpret-response
                     (http/follow-redirects
                      #"GET"
-                     (custom-http-sendrecv/url u #:method #"GET")))
+                     (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,14 +173,12 @@
 (define (put/bytes^ p cb mt h)
   (semaphore-wait put-bytes-sema)
   (thread
-   (procedure-rename
+   (lambda ()
-    (lambda ()
+     (with-handlers ((values (lambda (e)
-      (with-handlers ((values (lambda (e)
+                               (semaphore-post put-bytes-sema)
-                                (semaphore-post put-bytes-sema)
+                               (raise e))))
-                                (raise e))))
+       (put/bytes p cb mt h)
-        (put/bytes p cb mt h)
+       (semaphore-post put-bytes-sema)))))
-        (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

@@ -1,84 +0,0 @@
-#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 = "https" + "://" + pieces[2] + "/" + pieces[3] +
+      previewUrl = pieces[1] + "://" + pieces[2] + "/" + pieces[3] +
         (pieces[5] ? "?path=" + pieces[5] : "") +
         (pieces[4] && (pieces[4] !== 'master') ? '#' + pieces[4] : "");
       break;

static/style.css

@@ -83,10 +83,6 @@ input#new_version {
     width: 6em;
 }
 
-.not-shown-to-humans {
-    display: none;
-}
-
 .confirm-package-deletion {
     background-color: red;
     padding: 2em;
@@ -102,20 +98,6 @@ 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%;
 }

static/todos.js

@@ -1,12 +1,3 @@
-// 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";