Packages display docs for implied packages (#49)

* Added todo level for no description.

* Added todo category for no description, added warnings in table for todos.

* Fixed label xexps

* now displays implied docs.

* fixed formatting

* removed comment

README.md

@@ -23,26 +23,33 @@ a hashtable to `main`.
 Keys useful for deployment:
 
  - *port*: number; default the value of the `SITE_PORT` environment
-   variable, if defined; otherwise, 8443.
+   variable, if defined; otherwise, 7443.
  - *ssl?*: boolean; default `#t`.
  - *reloadable?*: boolean; `#t` if the `SITE_RELOADABLE` environment
    variable is defined; otherwise, `#f`.
  - *recent-seconds*: number, in seconds; default 172800. Packages
    modified fewer than this many seconds ago are considered "recent",
    and displayed as such in the UI.
- - *static-content-target-directory*: either `#f` or a string denoting
+ - *static-output-type*: either `'aws-s3` or `'file`.
-   a path to a folder to which the static content of the site will be
+    - When `'file`,
-   copied.
+	   - *static-content-target-directory*: either `#f` or a string
- - *static-content-update-hook*: either `#f`, or a string containing a
+		 denoting a path to a folder to which the static content of
-   shell command to invoke every time files are updated in
+		 the site will be copied.
-   *static-content-target-directory*.
+    - When `'aws-s3`,
+       - *aws-s3-bucket+path*: a string naming an S3 bucket and path.
+         Must end with a forward slash, ".../". AWS access keys are
+         loaded per the documentation for the `aws` module; usually
+         from a file `~/.aws-keys`.
  - *dynamic-urlprefix*: string; absolute or relative URL, prepended to
    URLs targetting dynamic content on the site.
  - *static-urlprefix*: string; absolute or relative URL, prepended to
    relative URLs referring to static HTML files placed in
    `static-generated-directory`.
- - *extra-static-content-directories*: list of strings; defaults to
+ - *pkg-index-generated-directory*: a string pointing to where the
-   the empty list.
+   `pkg-index` package places its redered files, to be served
+   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.
 
 Keys useful for development:
 
@@ -116,6 +123,43 @@ To enable replication, set configuration variable
 set `static-content-update-hook` to a string containing a shell
 command to execute every time the static content is updated.
 
+#### S3 Content
+
+To set up an S3 bucket---let's call it `s3.example`---for use with
+this site, follow these steps:
+
+ 0. Create the bucket ("`s3.example`")
+ 0. Optionally add a CNAME record to DNS mapping `s3.example` to
+    `s3.example.s3-website-us-east-1.amazonaws.com`. If you do, static
+    resources will be available at `http://s3.example/`; if not, at
+    the longer URL.
+ 0. Enable "Static Website Hosting" for the bucket. Set the index
+    document to `index.html` and the error document to `not-found`.
+
+Then, under "Permissions", click "Add bucket policy", and add
+something like the following.
+
+    {
+      "Id": "RacketPackageWebsiteS3Policy",
+      "Version": "2012-10-17",
+      "Statement": [
+        {
+          "Sid": "RacketPackageWebsiteS3PolicyStmt1",
+          "Action": "s3:*",
+          "Effect": "Allow",
+          "Resource": ["arn:aws:s3:::s3.example",
+                       "arn:aws:s3:::s3.example/*"],
+          "Principal": {
+            "AWS": ["<<<ARN OF THE USER TO WHOM ACCESS SHOULD BE GRANTED>>>"]
+          }
+        }
+      ]
+    }
+
+The user will need to be able to read and write objects and set CORS
+policy. (CORS is configured automatically by code in
+`src/static.rkt`.)
+
 ### Supervision
 
 Startable using djb's [daemontools](http://cr.yp.to/daemontools.html);

TODO.md

@@ -1,7 +1,5 @@
 ## Bugs
 
-racket-lib's dependencies aren't strings, and so lead to wrong URLs on its detail page
-
 get-bonus's conflicts path isn't a string, and so leads to a wrong URL
 on its detail page. See http://pkg-build.racket-lang.org/ - this kind
 of indirect report means that one of the dependencies of the package

configs/live.rkt

@@ -1,4 +1,39 @@
 #lang racket/base
 ;; Default configuration; should be suitable for live deployment.
 (require "../src/main.rkt")
-(main)
+(define var (getenv "PKGSERVER_DATADIR"))
+(main (hash 'port 8444
+            'reloadable? #t
+            'var-path var
+            'package-index-url
+              (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")
+            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+            ;; To configure a split, S3-based setup, comment out the following lines:
+            ;;
+            ;; 'static-output-type 'file
+            ;; 'static-content-target-directory (build-path var "public_html/pkg-catalog-static")
+            ;; 'static-urlprefix ""
+            ;; 'dynamic-urlprefix "/catalog"
+            ;;
+            ;; ... and uncomment and adjust these instead:
+            ;;
+
+            'static-output-type 'aws-s3
+            'aws-s3-bucket+path "pkgs.racket-lang.org/"
+            'static-urlprefix "https://pkgs.racket-lang.org"
+            'dynamic-urlprefix "https://pkgd.racket-lang.org/pkgn"
+            'dynamic-static-urlprefix "https://pkgs.racket-lang.org"
+
+            ;; 'static-output-type 'aws-s3
+            ;; 'aws-s3-bucket+path "pkgs.leastfixedpoint.com/"
+            ;; 'static-urlprefix "http://pkgs.leastfixedpoint.com.s3-website-us-east-1.amazonaws.com"
+            ;; 'dynamic-urlprefix "https://localhost:8444"
+
+            ;;
+            ;; Make sure to *include* a slash at the end of
+            ;; aws-s3-bucket+path, and to *exclude* a slash from the
+            ;; end of both static-urlprefix and dynamic-urlprefix.
+            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+            ))

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

@@ -3,12 +3,27 @@
 (require "../src/main.rkt")
 (main (hash 'port 8444
             'reloadable? #t
-            'package-index-url "https://localhost:8444/pkgs-all.json.gz"
+            'package-index-url "file:///home/tonyg/public_html/pkg-index-static/pkgs-all.json.gz"
+            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+            ;; Either:
+            ;;
+            'static-output-type 'file
             'static-content-target-directory (build-path (find-system-path 'home-dir)
                                                          "public_html/pkg-catalog-static")
             'static-urlprefix "https://localhost/~tonyg/pkg-catalog-static"
+            ;;
+            ;; Or:
+            ;;
+            ;; 'static-output-type 'aws-s3
+            ;; 'aws-s3-bucket+path "pkgs.leastfixedpoint.com/"
+            ;; ;; These two should be set to an HTTPS proxy (e.g. nginx) proxying to S3,
+            ;; ;; http://pkgs.leastfixedpoint.com.s3-website-us-east-1.amazonaws.com
+            ;; 'static-urlprefix "https://localhost:8446"
+            ;; 'dynamic-static-urlprefix "https://localhost:8446"
+            ;;
+            ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
             'dynamic-urlprefix "https://localhost:8444"
             'backend-baseurl "https://localhost:8445"
-            'extra-static-content-directories (list (build-path (find-system-path 'home-dir)
+            'pkg-index-generated-directory (build-path (find-system-path 'home-dir)
-                                                                "public_html/pkg-index-static"))
+                                                       "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

run

@@ -12,8 +12,8 @@ if [ ! -f configs/${CONFIG}.rkt ]; then
     exit 1
 fi
 
-PLTSTDERR=info
+PLTSTDERR="info warning@cm warning@compiler/cm warning@module-prefetch warning@setup/parallel-build warning@cm-accomplice warning@online-check-syntax error@racket/contract"
 export PLTSTDERR
 echo '============================================='
 cd src
-exec racket ../configs/${CONFIG}.rkt 2>&1
+exec ${RACKET}racket ../configs/${CONFIG}.rkt 2>&1

src/bootstrap.rkt

@@ -2,6 +2,7 @@
 ;; Utilities for working with Twitter Bootstrap, http://getbootstrap.com/2.3.2/
 
 (provide bootstrap-static-urlprefix
+         bootstrap-dynamic-urlprefix
          bootstrap-project-name
          bootstrap-project-link
          bootstrap-navbar-header
@@ -12,6 +13,7 @@
          bootstrap-page-scripts
          bootstrap-cookies
          bootstrap-inline-js
+         bootstrap-head-extra
 
          bootstrap-response
 	 bootstrap-redirect
@@ -27,6 +29,7 @@
 (require "xexpr-utils.rkt")
 
 (define bootstrap-static-urlprefix (make-parameter ""))
+(define bootstrap-dynamic-urlprefix (make-parameter ""))
 (define bootstrap-project-name (make-parameter "Project"))
 (define bootstrap-project-link (make-parameter "/"))
 (define bootstrap-navbar-header (make-parameter #f))
@@ -37,9 +40,12 @@
 (define bootstrap-page-scripts (make-parameter '()))
 (define bootstrap-cookies (make-parameter '()))
 (define bootstrap-inline-js (make-parameter #f))
+(define bootstrap-head-extra (make-parameter '()))
 
 (define (static str)
   (string-append (bootstrap-static-urlprefix) str))
+(define (dynamic str)
+  (string-append (bootstrap-dynamic-urlprefix) str))
 
 ;; String [#:title-element XExpr] [#:code Integer] [#:message Bytes] [XExpr ...] -> Response
 (define (bootstrap-response title
@@ -63,7 +69,8 @@
 	   (link ((rel "stylesheet") (href ,(static "/jquery-ui.min.css")) (type "text/css")))
            (link ((rel "stylesheet") (href ,(static "/style.css")) (type "text/css")))
 	   ,@(for/list ((sheet (bootstrap-page-stylesheets)))
-	       `(link ((rel "stylesheet") (href ,sheet) (type "text/css")))))
+	       `(link ((rel "stylesheet") (href ,sheet) (type "text/css"))))
+           ,@(bootstrap-head-extra))
      (body ,@(maybe-splice body-class `((class ,body-class)))
       (nav ((class "navbar navbar-inverse navbar-fixed-top") (role "navigation"))
 	   (div ((class "container-fluid"))
@@ -81,11 +88,7 @@
                             ,(bootstrap-project-name))))
 		(div ((id "navbar") (class "collapse navbar-collapse"))
 		     (ul ((class "nav navbar-nav"))
-			 ,@(for/list ((n (bootstrap-navigation)))
+                         ,@(render-nav-items (bootstrap-navigation)))
-			     (match-define (list text url) n)
-			     `(li ,@(maybe-splice (equal? text (bootstrap-active-navigation))
-                                                  `((class "active")))
-				  (a ((href ,url)) ,text))))
                      ,@(bootstrap-navbar-extension)
                      )))
       (div ((class "container"))
@@ -101,6 +104,28 @@
       ,@(for/list ((script (bootstrap-page-scripts)))
           `(script ((type "text/javascript") (src ,script))))))))
 
+(define (render-nav-items items)
+  (for/list ((n items))
+    (match n
+      [(list text (? string? url))
+       `(li ,@(maybe-splice (equal? text (bootstrap-active-navigation))
+                            `((class "active")))
+            (a ((href ,url)) ,text))]
+      ['separator
+       `(li ((role "separator") (class "divider")))]
+      [(list text (? list? subitems))
+       `(li ((class "dropdown"))
+            (a ((href "#")
+                (class "dropdown-toggle")
+                (data-toggle "dropdown")
+                (role "button")
+                (aria-haspopup "true")
+                (aria-expanded "false"))
+               ,text
+               (span ((class "caret"))))
+            (ul ((class "dropdown-menu"))
+                ,@(render-nav-items subitems)))])))
+
 ;; String [#:permanent? Boolean] [#:headers (Listof Header)] -> Response
 (define (bootstrap-redirect url
                             #:permanent? [permanent? #f]
@@ -112,7 +137,7 @@
 
 ;; Request -> Response
 (define (bootstrap-continuation-expiry-handler request)
-  (bootstrap-redirect (url->string (strip-parameters (request-uri request)))))
+  (bootstrap-redirect (dynamic (url->string (strip-parameters (request-uri request))))))
 
 ;; URL -> URL
 (define (strip-parameters u)

src/build-server.rkt

@@ -1,117 +0,0 @@
-#lang racket/base
-
-(provide pkg-build-baseurl)
-
-(require racket/match)
-(require racket/file)
-(require (only-in racket/port copy-port))
-(require net/url)
-(require "config.rkt")
-(require "hash-utils.rkt")
-(require reloadable)
-(require "daemon.rkt")
-(require "rpc.rkt")
-
-(define pkg-build-baseurl
-  (or (@ (config) pkg-build-baseurl)
-      "http://pkg-build.racket-lang.org/"))
-
-(define pkg-build-cache-path
-  (or (@ (config) pkg-build-cache-path)
-      (build-path (var-path) "cache")))
-
-(make-directory* pkg-build-cache-path)
-
-(define pkg-build-cache-refresh-interval
-  (* 1000 (or (@ (config) pkg-build-cache-refresh-interval)
-              3600))) ;; one hour
-
-(define (compute-next-refresh-deadline)
-  (+ (current-inexact-milliseconds) pkg-build-cache-refresh-interval))
-
-(define cached-summary-path (build-path pkg-build-cache-path "summary.rktd"))
-(define cached-etag-path (build-path pkg-build-cache-path "summary.rktd.etag"))
-
-(define (extract-etag hs)
-  (for/or ([h (in-list hs)])
-    (match h
-      [(regexp #rx#"^ETag: (.*?)$" (list _ tag-bytes)) tag-bytes]
-      [_ #f])))
-
-;; Returns #t if the summary file has been updated, or #f if it
-;; remains the same as it was previously.
-(define (refresh-build-server-summary!)
-  (define summary-url (combine-url/relative (string->url pkg-build-baseurl) "summary.rktd"))
-
-  (define HEAD-etag
-    (let-values (((HEAD-status HEAD-headers HEAD-body-input-port)
-                  (http-sendrecv/url summary-url #:method #"HEAD")))
-      (extract-etag HEAD-headers)))
-
-  (define cached-etag (and (file-exists? cached-etag-path) (file->bytes cached-etag-path)))
-
-  (define need-refresh?
-    (or (not HEAD-etag) ;; server didn't supply an ETag
-        (not cached-etag) ;; we don't have a record of an ETag locally
-        (not (equal? HEAD-etag cached-etag)))) ;; the ETag has changed
-
-  (cond
-   [need-refresh?
-    (log-info "Build server summary.rktd ETag has changed. Refreshing.")
-    (define-values (GET-status GET-headers GET-body-input-port)
-      (http-sendrecv/url summary-url #:method #"GET"))
-
-    (define new-file (make-temporary-file "summary-~a.rktd" #f pkg-build-cache-path))
-    (call-with-output-file new-file
-      (lambda (p) (copy-port GET-body-input-port p))
-      #:exists 'replace)
-    (with-output-to-file cached-etag-path
-      (lambda () (write-bytes (extract-etag GET-headers)))
-      #:exists 'replace)
-    (rename-file-or-directory new-file cached-summary-path #t)]
-   [else
-    (log-info "Build server summary.rktd ETag has not changed.")])
-
-  need-refresh?)
-
-(define (load-build-server-summary)
-  (if (file-exists? cached-summary-path)
-      (file->value cached-summary-path)
-      (hash)))
-
-(struct build-server-state (summary-table
-                            next-refresh-deadline
-                            ) #:prefab)
-
-(define (boot-build-server)
-  (refresh-build-server-summary!)
-  (build-server-main (build-server-state (load-build-server-summary)
-                                         (compute-next-refresh-deadline))))
-
-(define (send-change-notifications! old-table new-table)
-  (log-info "HERE ~v ~v" old-table new-table))
-
-(define (build-server-main state)
-  (match-define (build-server-state summary-table next-refresh-deadline) state)
-  (build-server-main
-   (rpc-handler (sync (rpc-request-evt)
-                      (handle-evt (alarm-evt next-refresh-deadline)
-                                  (lambda (_) (list #f 'refresh!))))
-     [('refresh!)
-      (values (void)
-              (if (refresh-build-server-summary!)
-                  (let ((new-summary-table (load-build-server-summary)))
-                    (send-change-notifications! summary-table new-summary-table)
-                    (struct-copy build-server-state state
-                                 [summary-table new-summary-table]
-                                 [next-refresh-deadline (compute-next-refresh-deadline)]))
-                  (struct-copy build-server-state state
-                               [next-refresh-deadline (compute-next-refresh-deadline)])))]
-     )))
-
-(define build-server-thread
-  (make-persistent-state 'build-server-thread
-                         (lambda () (daemon-thread 'build-server
-                                                   (lambda () (boot-build-server))))))
-
-(sleep 5)

src/config.rkt

@@ -14,6 +14,8 @@
 
 (define-runtime-path here ".")
 (define (config-path str)
+  (unless (path-string? str)
+    (error 'config-path "Not given path string: ~e" str))
   (define p (if (relative-path? str)
                 (build-path here str)
                 str))

src/daemon.rkt

@@ -3,7 +3,7 @@
 (provide daemonize-thunk
          daemon-thread)
 
-(require (only-in web-server/private/util exn->string))
+(require (only-in racket/exn exn->string))
 
 (define (daemonize-thunk name boot-thunk)
   (lambda ()

src/entrypoint.rkt

@@ -10,7 +10,7 @@
 (require "signals.rkt")
 (require "daemon.rkt")
 
-(define (start-service* #:port [port 8443]
+(define (start-service* #:port [port 7443]
                         #:ssl? [ssl? #t]
                         request-handler-function
                         on-continuation-expiry
@@ -34,7 +34,7 @@
                      #:ssl-key (and ssl? (build-path (current-directory) "../private-key.pem"))
                      #:servlet-regexp #rx"")))))
 
-(define (start-service #:port [port 8443]
+(define (start-service #:port [port 7443]
                        #:ssl? [ssl? #t]
                        #:reloadable? [reloadable? #t]
                        request-handler-entry-point

src/html-utils.rkt

@@ -9,8 +9,8 @@
 ;; Boolean XExpr ... -> (Listof XExpr)
 ;; Useful for optionally splicing in some contents to a list.
 ;; If the guard is true, returns the contents; otherwise returns the empty list.
-(define (maybe-splice guard . contents)
+(define-syntax-rule (maybe-splice guard contents ...)
-  (if 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.

src/http-utils.rkt

@@ -0,0 +1,160 @@
+#lang racket/base
+;; HTTP utilities
+
+(provide http-redirection-limit
+         http-classify-status-code
+         http-interpret-response
+         http-simple-interpret-response
+         http-follow-redirects
+         http-sendrecv/url
+
+         http/interpret-response
+         http/simple-interpret-response
+         http/follow-redirects)
+
+(require (only-in racket/port port->bytes))
+(require (only-in racket/bytes bytes-join))
+(require racket/match)
+(require net/http-client)
+(require net/head)
+(require (except-in net/url http-sendrecv/url))
+
+;; (Parameterof Number)
+;; Number of redirections to automatically follow when retrieving via GET or HEAD.
+(define http-redirection-limit (make-parameter 20))
+
+;; Number -> Symbol
+;; Returns the broad classification associated with a given HTTP status code.
+(define (http-classify-status-code status-code)
+  (cond
+    [(<= status-code 99) 'unknown]
+    [(<= 100 status-code 199) 'informational]
+    [(<= 200 status-code 299) 'success]
+    [(<= 300 status-code 399) 'redirection]
+    [(<= 400 status-code 499) 'client-error]
+    [(<= 500 status-code 599) 'server-error]
+    [(<= 600 status-code) 'unknown]))
+
+(define (parse-status-line status-line)
+  (match status-line
+    [(regexp #px#"^([^ ]+) ([^ ]+)( (.*))?$" (list _ v c _ r))
+     (values v (string->number (bytes->string/latin-1 c)) (bytes->string/latin-1 r))]
+    [_
+     (values #f #f #f)]))
+
+(define (parse-headers response-headers [downcase-header-names? #t])
+  (for/list [(h (extract-all-fields (bytes-join response-headers #"\r\n")))]
+    (cons (string->symbol ((if downcase-header-names? string-downcase values)
+                           (bytes->string/latin-1 (car h))))
+          (cdr h))))
+
+;; <customizations ...>
+;; -> Bytes (Listof Bytes) InputPort
+;; -> (Values (Option Bytes)
+;;            (Option Number)
+;;            (Option String)
+;;            (Listof (Cons Symbol Bytes))
+;;            (if read-body? Bytes InputPort))
+(define ((http-interpret-response #:downcase-header-names? [downcase-header-names? #t]
+                                  #:read-body? [read-body? #t])
+         status-line response-headers response-body-port)
+  (define-values (http-version status-code reason-phrase) (parse-status-line status-line))
+  (values http-version
+          status-code
+          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)))
+
+(define (http-simple-interpret-response status-line response-headers response-body-port)
+  (define-values (_http-version
+                  status-code
+                  _reason-phrase
+                  headers
+                  body)
+    ((http-interpret-response) status-line response-headers response-body-port))
+  (values (http-classify-status-code status-code)
+          headers
+          body))
+
+(define ((http-follow-redirects method
+                                #:version [version #"1.1"])
+         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))
+   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-syntax-rule (http/interpret-response customization ... req-expr)
+  (call-with-values (lambda () req-expr)
+                    (http-interpret-response customization ...)))
+
+(define-syntax-rule (http/simple-interpret-response req-expr)
+  (call-with-values (lambda () req-expr)
+                    http-simple-interpret-response))
+
+(define-syntax-rule (http/follow-redirects customization ... req-expr)
+  (call-with-values (lambda () req-expr)
+                    (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")))
+  )

src/json-rpc.rkt

@@ -0,0 +1,46 @@
+#lang racket/base
+;; Trivially simple authenticated JSON-over-HTTPS RPC.
+
+(provide simple-json-rpc!)
+
+(require racket/port)
+(require net/url)
+(require net/base64)
+(require json)
+(require "sessions.rkt")
+
+(define (make-basic-auth-credentials-header username password)
+  (define token
+    (base64-encode (string->bytes/utf-8 (string-append username ":" password)) #""))
+  (string-append "Authorization: Basic " (bytes->string/utf-8 token)))
+
+(define (simple-json-rpc! #:sensitive? [sensitive? #f]
+                          #:include-credentials? [include-credentials? #t]
+                          baseurl
+                          site-relative-url
+                          jsexpr-to-send)
+  (define s (current-session))
+  (if sensitive?
+      (log-info "simple-json-rpc: sensitive request ~v" site-relative-url)
+      (log-info "simple-json-rpc: request ~v params ~v~a"
+                site-relative-url
+                jsexpr-to-send
+                (if include-credentials?
+                    (if s
+                        " +creds"
+                        " +creds(missing)")
+                    "")))
+  (define request-urls (format "~a~a" baseurl site-relative-url))
+  (define request-url (string->url request-urls))
+  (define post-data (string->bytes/utf-8 (jsexpr->string jsexpr-to-send)))
+  (define req-headers
+    (if include-credentials?
+        (list (make-basic-auth-credentials-header (session-email s)
+                                                  (session-password s)))
+        '()))
+  (define response-port (post-pure-port request-url post-data req-headers))
+  (define raw-response (port->string response-port))
+  (close-input-port response-port)
+  (define reply (string->jsexpr raw-response))
+  (unless sensitive? (log-info "simple-json-rpc: reply ~v" reply))
+  reply)

src/jsonp-client.rkt

@@ -1,52 +0,0 @@
-#lang racket/base
-
-(provide jsonp-baseurl
-         jsonp-rpc!)
-
-(require racket/match)
-(require racket/format)
-(require racket/port)
-(require net/url)
-(require net/uri-codec)
-(require json)
-(require "sessions.rkt")
-
-(define jsonp-baseurl (make-parameter #f))
-
-(define (jsonp-rpc! #:sensitive? [sensitive? #f]
-                    #:include-credentials? [include-credentials? #t]
-                    site-relative-url
-                    original-parameters)
-  (define s (current-session))
-  (if sensitive?
-      (log-info "jsonp-rpc: sensitive request ~a" site-relative-url)
-      (log-info "jsonp-rpc: request ~a params ~a~a"
-                site-relative-url
-                original-parameters
-                (if include-credentials?
-                    (if s
-                        " +creds"
-                        " +creds(missing)")
-                    "")))
-  (define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds)))))
-  (define callback-label (format "callback~a" stamp))
-  (define extraction-expr (format "^callback~a\\((.*)\\);$" stamp))
-  (let* ((parameters original-parameters)
-         (parameters (if (and include-credentials? s)
-                         (append (list (cons 'email (session-email s))
-                                       (cons 'passwd (session-password s)))
-                                 parameters)
-                         parameters))
-         (parameters (cons (cons 'callback callback-label) parameters)))
-    (define request-url
-      (string->url
-       (format "~a~a?~a"
-               (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set"))
-               site-relative-url
-               (alist->form-urlencoded parameters))))
-    (define-values (body-port response-headers) (get-pure-port/headers request-url))
-    (define raw-response (port->string body-port))
-    (match-define (pregexp extraction-expr (list _ json)) raw-response)
-    (define reply (string->jsexpr json))
-    (unless sensitive? (log-info "jsonp-rpc: reply ~a" reply))
-    reply))

src/main.rkt

@@ -8,10 +8,10 @@
 (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-all! "site.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) 8443))))
+                                                   (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")

src/mock/aws-s3.rkt

@@ -0,0 +1,182 @@
+#lang racket/base
+
+(provide create-bucket
+         delete-bucket
+         ls/proc
+         put/bytes
+         get/bytes
+         delete)
+
+(require file/glob)
+(require file/md5)
+(require net/uri-codec)
+(require racket/date)
+(require racket/dict)
+(require racket/file)
+(require racket/list)
+(require racket/match)
+(require racket/string)
+(require "../config.rkt")
+
+(module+ test (require rackunit))
+
+(define (create-bucket bucket [location #f])
+  (define-values (full-bucket-path path-str) (split-bucket+path/create bucket))
+  (when path-str (error 'create-bucket "Do not include a path within the bucket: ~v" bucket)))
+
+(define (delete-bucket bucket)
+  (define-values (full-bucket-path path-str) (split-bucket+path bucket))
+  (when path-str (error 'delete-bucket "Do not include a path within the bucket: ~v" bucket))
+  (delete-directory/files full-bucket-path #:must-exist? #f))
+
+(define (ls/proc bucket+path proc init [max-each 1000] #:delimiter [delimiter #f])
+  (when delimiter (error 'ls/proc "mock/aws-s3 lacks support for non-#f delimiter"))
+  (define-values (full-bucket-path path-str) (split-bucket+path/create bucket+path))
+  (define all-files (for/list [(p (glob (build-path full-bucket-path "*")))]
+                      (define-values (_dirp f _must-be-dir?) (split-path p))
+                      f))
+  (define matching-files
+    (if path-str
+        (filter (lambda (f) (string-prefix? (unescape-filename f) path-str)) all-files)
+        all-files))
+  (for/fold [(acc init)] [(group (batch matching-files max-each))]
+    (proc init (map (lambda (f) (ListBucketResults-file full-bucket-path f)) group))))
+
+(define (bucket+path->file-path bucket+path)
+  (define-values (full-bucket-path path-str) (split-bucket+path/create bucket+path))
+  (build-path full-bucket-path (escape-filename (or path-str ""))))
+
+(define (put/bytes bucket+path data mime-type [heads '()])
+  (unless (dict-empty? heads)
+    (log-warning "mock put/bytes: ignoring non-empty 'heads' dictionary: ~v" heads))
+  (display-to-file data (bucket+path->file-path bucket+path) #:exists 'replace))
+
+(define (get/bytes bucket+path [heads '()] [range-begin #f] [range-end #f])
+  ;; Signals an error when the file doesn't exist, but not the same
+  ;; error the real S3 package signals.
+  ;;
+  (when (or range-begin range-end)
+    (error 'get/bytes "mock/aws-s3 lacks support for get ranges: ~v/~v" range-begin range-end))
+  (unless (dict-empty? heads)
+    (log-warning "mock get/bytes: ignoring non-empty 'heads' dictionary: ~v" heads))
+  (file->bytes (bucket+path->file-path bucket+path)))
+
+(define (delete bucket+path)
+  (with-handlers [(exn:fail:filesystem? void)]
+    ;; ^ ugh, can't distinguish file-not-found from any other error.
+    (delete-file (bucket+path->file-path bucket+path))))
+
+(module+ test
+  (define B "testbucket.mock.aws-s3")
+  (delete-bucket B)
+  (delete-bucket B) ;; it's supposed to be idempotent
+  (create-bucket B)
+  (create-bucket B) ;; should also be idempotent
+  (check-equal? (ls/proc (string-append B "/") append '()) '())
+  (put/bytes (string-append B "/foo/bar") #"/foo/bar" "text/plain")
+  (put/bytes (string-append B "/bar") #"/bar" "text/plain")
+  (check-equal? (get/bytes (string-append B "/foo/bar")) #"/foo/bar")
+  (check-equal? (get/bytes (string-append B "/bar")) #"/bar")
+  (check-match
+   (ls/proc (string-append B "/") append '())
+   `((Contents ()
+               (Key () "bar")
+               (LastModified () ,_)
+               (ETag () "\"" "6a764eebfa109a9ef76c113f3f608c6b" "\"")
+               (Size () "4")
+               (Owner ()
+                      (ID () "0000000000000000000000000000000000000000000000000000000000000000")
+                      (DisplayName () "mockuser"))
+               (StorageClass () "STANDARD"))
+     (Contents ()
+               (Key () "foo/bar")
+               (LastModified () ,_)
+               (ETag () "\"" "1df481b1ec67d4d8bec721f521d4937d" "\"")
+               (Size () "8")
+               (Owner ()
+                      (ID () "0000000000000000000000000000000000000000000000000000000000000000")
+                      (DisplayName () "mockuser"))
+               (StorageClass () "STANDARD"))))
+  (delete (string-append B "/zot")) ;; idempotent
+  (delete (string-append B "/bar"))
+  (check-match
+   (ls/proc (string-append B "/") append '())
+   `((Contents ()
+               (Key () "foo/bar")
+               (LastModified () ,_)
+               (ETag () "\"" "1df481b1ec67d4d8bec721f521d4937d" "\"")
+               (Size () "8")
+               (Owner ()
+                      (ID () "0000000000000000000000000000000000000000000000000000000000000000")
+                      (DisplayName () "mockuser"))
+               (StorageClass () "STANDARD"))))
+  (delete-bucket B))
+
+(define (batch items batch-size)
+  (if (<= (length items) batch-size)
+      (if (null? items)
+          '()
+          (list items))
+      (let-values (((h t) (split-at items batch-size)))
+        (cons h (batch t batch-size)))))
+
+(module+ test
+  (check-equal? (batch '() 3) '())
+  (check-equal? (batch '(x) 3) '((x)))
+  (check-equal? (batch '(x y z) 3) '((x y z)))
+  (check-equal? (batch '(x y z w) 3) '((x y z) (w)))
+  (check-equal? (batch '(x y z w a b c d) 3) '((x y z) (w a b) (c d)))
+  (check-equal? (batch '(x y z w a b c d e) 3) '((x y z) (w a b) (c d e))))
+
+(define (ListBucketResults-file full-bucket-path f)
+  (define path (build-path full-bucket-path f))
+  (define checksum (md5 (file->bytes path)))
+  (define mtime (file-or-directory-modify-seconds path))
+  `(Contents ()
+             (Key () ,(unescape-filename f))
+             (LastModified () ,(parameterize ((date-display-format 'iso-8601))
+                                 (string-append (date->string (seconds->date mtime #f) #t)
+                                                ".000Z")))
+             (ETag () "\"" ,(bytes->string/utf-8 checksum) "\"")
+             (Size () ,(number->string (file-size path)))
+             (Owner ()
+                    (ID () "0000000000000000000000000000000000000000000000000000000000000000")
+                    (DisplayName () "mockuser"))
+             (StorageClass () "STANDARD")))
+
+(define (escape-filename f)
+  (unless (string? f) (error 'escape-filename "Expects a string: ~v" f))
+  (string->path (string-append "f-" (uri-encode f))))
+
+(define (unescape-filename f)
+  (unless (path? f) (error 'escape-filename "Expects a path: ~v" f))
+  (match (path->string f)
+    [(regexp #px"f-(.*)" (list _ s)) (uri-decode s)]
+    [_ (error 'unescape-filename "Invalid filename: ~v" f)]))
+
+(module+ test
+  (check-equal? (escape-filename "") (string->path "f-"))
+  (check-equal? (escape-filename "abc") (string->path "f-abc"))
+  (check-equal? (escape-filename "abc/def") (string->path "f-abc%2Fdef"))
+  (check-equal? (escape-filename "abc%def") (string->path "f-abc%25def"))
+  (check-equal? (unescape-filename (string->path "f-")) "")
+  (check-equal? (unescape-filename (string->path "f-abc")) "abc")
+  (check-equal? (unescape-filename (string->path "f-abc%2Fdef")) "abc/def")
+  (check-equal? (unescape-filename (string->path "f-abc%25def")) "abc%def"))
+
+(define (split-bucket+path bucket+path)
+  (define elements0 (explode-path bucket+path))
+  (when (null? elements0) (error 'split-bucket+path/create "No bucket supplied"))
+  (define elements (if (equal? (string->path "/") (car elements0))
+                       (cdr elements0)
+                       elements0))
+  (match-define (cons bucket-path path-element-paths) elements)
+  (define full-bucket-path (build-path (var-path) "mock/aws-s3" bucket-path))
+  (values full-bucket-path
+          (and (pair? path-element-paths)
+               (path->string (apply build-path path-element-paths)))))
+
+(define (split-bucket+path/create bucket+path)
+  (define-values (full-bucket-path path-str) (split-bucket+path bucket+path))
+  (make-directory* full-bucket-path)
+  (values full-bucket-path path-str))

src/package-catalog/NOTES.md

@@ -1,355 +0,0 @@
-# New design
-
-Packages have *authoritative* (human-managed) and *computed* keys in
-the database. Then, separately, a static-rendered form of the package
-description hashtable is computed from the database record.
-
-Package ownership is determined by the presence or absence of an email
-address in the package's `authors` list.
-
-Authoritative keys:
-
- - `name`, string
- - `source`, quasi-URL
- - `description`, string
- - `tags`, list of strings
- - `authors`, list of strings (email addresses)
-     - NB. existing code treats `author` as authoritative, with
-       `authors` computed
-	 - If an email address is present in this list, then the
-	   corresponding user may edit/delete the package, including
-	   changing ownership of it.
- - `versions`
-     - hash table mapping version name string (NOT `'default`!) to
-       hash table containing a `source` key mapping to a quasi-URL
-     - note that no default entry is to be present in this table:
-       instead, it's computed (for the benefit of 5.3.6 and older) as
-       part of the computation and static-rendering step.
- - `ring`, number; 0, 1, or 2. Updateable by catalog admin only
- - `last-edit`
-
-Computed keys:
-
- - `author`, string, space-joined `authors`
- - `last-updated`
- - `last-checked`
- - `versions`
-     - each version gets its checksum computed, and placed in a
-       `checksum` key alongside its `source` key.
- - `checksum-error`
-     - `#f` if no error; otherwise, a string. In the existing code,
-	   the first checksum-computation to yield an error is stored
-	   here, and the remainder of the computations are abandoned. In
-	   the new code, this should store a record of all the failed
-	   computations.
- - `checksum`
-     - checksum for the top-level (default) source
- - `conflicts`
- - `modules`
- - `dependencies`
-
-In the rendered form of a package record, the default source and
-checksum and the versions table are arranged differently. If a version
-named `"5.3.6"` exists, its source (and checksum) are used at
-top-level; and either way, the default source and checksum are copied
-into a version named `'default`. In addition, each version in the
-`versions` table (including `'default`) has a `source_url` field added
-to it, with an HTTP(S) URL for humans to visit heuristically derived
-from the `source` quasi-URL.
-
-The rendered form also has the following additional top-level keys:
-
- - `build`, a hash-table:
-	 - currently includes:
-	    - `success-log`
-	    - `failure-log`
-		- `dep-failure-log`
-		- `conflicts-log`, either `#f`, a build-host-relative URL
-          string pointing at the conflicts log, or `(list/c "indirect"
-          string?)`, which again seems to point at some kind of log
-          but flagged somehow? Ah, this kind of indirect report means
-          that one of the dependencies of the package has a conflict.
-	    - `docs`, a list of
-		   - `(list/c (or/c "main" "extract" "salvage" string?
-             string?)`, where the last string is the URL-fragment
-             relative to the build host where the rendered
-             documentation is stored and the penultimate string is the
-             name of this chunk of documentation.
-		   - `(list/c "none" string?)`, where the last string is the
-             name of the chunk of documentation, but no rendered form
-             is available.
-	 - should also include:
-	    - `test-success-log`
-		- `test-failure-log`
-		- `min-failure-log` - records problems due to missing
-          environmental dependencies. See
-          http://pkg-build.racket-lang.org/
- - `search-terms`, a hash-table where each present key has `#t` as its
-   value. Each key is a symbol. Keys that may be present:
-     - one per tag in the package's `tags` list (as symbols)
-	 - `ring:N` where N corresponds to the package's ring
-	 - `author:X` where X is drawn from the package's `authors` list
-	 - `:no-tag:` if `tags` is empty
-	 - `:error:` if `checksum-error` is non-false
-	 - `:no-desc:` if `description` is the empty string
-	 - `:conflicts:` if `conflicts` is not the empty list
-	 - `:build-success:` if the success-log is non-false
-	 - `:build-fail:` if the failure-log is non-false
-	 - `:build-dep-fail:` if the dep-failure-log is non-false
-	 - `:build-conflicts:` if the conflicts-log is non-false
-	 - `:docs:` if some docs exist and not all of them are `doc/none` instances
-	 - `:docs-error:` if some docs exist but none of them is a `doc/main` instance
-
-# JSON variations on various records
-
- - Racket lists, numbers and booleans map to JSON lists, numbers and booleans
- - Racket strings and symbols map to JSON strings
- - Racket keywords map to a JSON hash with key "kw" and value the
-   result of `keyword->string` on the keyword
- - Racket hash tables map to JSON hashes; keys may be either strings or symbols.
-
-# Users
-
-User records are currently just a file containing only their bcrypted
-passwords. They should probably also have an `administrator?` flag
-associated with them.
-
-# Notes on existing package catalog code
-
-## Existing API
-
-The JSONP requests are all GET requests. Clients include a spurious
-unique parameter to avoid cache problems.
-
- - `/jsonp/authenticate` - registration/validation/login
-     - `email`
-	 - `passwd`
-	 - `code` - optional; used only when email not registered or
-       password incorrect.
-
- - `/jsonp/update` - causes a refresh of all packages editable by the current user
-
- - `/jsonp/package/del` - delete a package, if current user is an author
-     - `pkg`
-
- - `/jsonp/package/modify` - create or update (including renaming) a package
-     - `pkg` - old/existing package name; empty to create a package
-	 - `name` - new/updated name
-	 - `description`
-	 - `source`
-
- - `/jsonp/package/version/add` - add a non-default version to a package
-     - `pkg`
-	 - `version`
-	 - `source`
-
- - `/jsonp/package/version/del` - remove a non-default version from a package
-     - `pkg`
-	 - `version`
-
- - `/jsonp/package/tag/add` - add a tag to a package
-     - `pkg`
-	 - `tag`
-
- - `/jsonp/package/tag/del` - remove a tag from a package
-     - `pkg`
-	 - `tag`
-
- - `/jsonp/package/author/add` - add an author to a package
-     - `pkg`
-	 - `author`
-
- - `/jsonp/package/author/del` - remove an author from a package
-     - `pkg`
-	 - `author`
-
- - `/jsonp/package/curate` - change the ring of a package. Only
-   accessible to site administrators.
-     - `pkg`
-	 - `ring` - string form of new ring number; e.g. `"2"`.
-
- - `/jsonp/notice` - retrieves the current notice text
-
-The following request is not JSONP, and requires that the method be
-POST, not GET:
-
- - `/api/upload` - accessible only to site administrators. Uploads
-   multiple raw package descriptions at once.
-    - POST data is read as Racket data. It is to be a `(list/c string?
-      string? (hash/c string? package/c))`, where `package/c` is a
-      hashtable containing a bunch of keys to be merged with any
-      existing keys in the package database.
-
-## Package details
-
-Each package is given:
-
- - `checksum`
- - `checksum-error`
-
-The static-rendered version adds:
-
- - `default` version info, with
-    - `source` from the main table
-	- `checksum` from the main table
-	- `source_url` computed from the adjacent source field
- - `authors` list, presumably split from `author` field?
- - `build` table
- - `search-terms` table
-
-From the raw DB:
-
-	#hasheq((name . "ansi")
-			(source . "github://github.com/tonyg/racket-ansi/master")
-			(last-updated . 1420421711)
-			(last-edit . 1418835706)
-			(last-checked . 1421174660)
-			(versions . #hash())
-			(tags . ("terminal"))
-			(checksum-error . #f)
-			(ring . 1)
-			(checksum . "0f9cc06dffa81100df9617ba9deeb46382013e90")
-			(author . "tonygarnockjones@gmail.com")
-			(conflicts . ())
-			(description . "ANSI and VT10x escape sequences for Racket.")
-			(modules . ((lib "ansi/ansi.rkt")
-						(lib "ansi/test-modes.rkt")
-						(lib "ansi/test-raw.rkt")
-						(lib "ansi/test-ansi.rkt")
-						(lib "ansi/lcd-terminal.rkt")
-						(lib "ansi/private/install.rkt")
-						(lib "ansi/main.rkt")))
-			(dependencies . ("base" "dynext-lib" "rackunit-lib")))
-
-From the static-rendered version:
-
-	#hasheq((name . "ansi")
-			(source . "github://github.com/tonyg/racket-ansi/master")
-			(last-updated . 1420421711)
-			(last-edit . 1418835706)
-			(last-checked . 1421174660)
-			(versions
-			 . #hash((default
-					   . #hasheq((source . "github://github.com/tonyg/racket-ansi/master")
-								 (checksum . "0f9cc06dffa81100df9617ba9deeb46382013e90")
-								 (source_url . "http://github.com/tonyg/racket-ansi/tree/master")))))
-			(tags . ("terminal"))
-			(checksum-error . #f)
-			(ring . 1)
-			(checksum . "0f9cc06dffa81100df9617ba9deeb46382013e90")
-			(author . "tonygarnockjones@gmail.com")
-			(conflicts . ())
-			(description . "ANSI and VT10x escape sequences for Racket.")
-			(modules . ((lib "ansi/ansi.rkt")
-						(lib "ansi/test-modes.rkt")
-						(lib "ansi/test-raw.rkt")
-						(lib "ansi/test-ansi.rkt")
-						(lib "ansi/lcd-terminal.rkt")
-						(lib "ansi/private/install.rkt")
-						(lib "ansi/main.rkt")))
-			(dependencies . ("base" "dynext-lib" "rackunit-lib"))
-			(authors . ("tonygarnockjones@gmail.com"))
-			(build
-			 . #hash((docs . ())
-					 (success-log . "server/built/install/ansi.txt")
-					 (failure-log . #f)
-					 (dep-failure-log . #f)
-					 (conflicts-log . #f)))
-			(search-terms
-			 . #hasheq((:build-success: . #t)
-					   (terminal . #t)
-					   (ring:1 . #t)
-					   (author:tonygarnockjones@gmail.com . #t))))
-
-
-A richer raw DB record:
-
-    #hash((name . "racket-lib")
-		  (source . "git://github.com/plt/racket/?path=pkgs/racket-lib")
-		  (author . "eli@racket-lang.org jay@racket-lang.org matthias@racket-lang.org mflatt@racket-lang.org robby@racket-lang.org ryanc@racket-lang.org samth@racket-lang.org")
-		  (last-updated . 1420948817)
-		  (last-edit . 1418046514)
-		  (last-checked . 1421095037)
-		  (versions . #hash(("5.3.5" . #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip") (checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
-			                ("5.3.4" . #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip") (checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
-							("5.3.6" . #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip") (checksum . "9f098dddde7f217879070816090c1e8e74d49432")))))
-		  (tags . ("main-distribution"))
-		  (checksum-error . #f)
-		  (ring . 0)
-		  (checksum . "486debd70483427f0a90b53cb9c52cf51e899a37")
-		  (description . "Combines platform-specific native libraries that are useful for base Racket")
-		  (modules . ())
-		  (dependencies . (("racket-win32-i386-2" #:platform "win32\\i386") ("racket-win32-x86_64-2" #:platform "win32\\x86_64") ("racket-x86_64-linux-natipkg-2" #:platform "x86_64-linux-natipkg") ("db-ppc-macosx" #:platform "ppc-macosx") ("db-win32-i386" #:platform "win32\\i386") ("db-win32-x86_64" #:platform "win32\\x86_64") ("db-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg") ("com-win32-i386" #:platform "win32\\i386") ("com-win32-x86_64" #:platform "win32\\x86_64")))
-		  (conflicts . ()))
-
-A richer static-rendered description:
-
-    #hash((name . "racket-lib")
-		  (source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
-		  (author . "eli@racket-lang.org jay@racket-lang.org matthias@racket-lang.org mflatt@racket-lang.org robby@racket-lang.org ryanc@racket-lang.org samth@racket-lang.org")
-		  (last-updated . 1421178060)
-		  (last-checked . 1421178060)
-		  (last-edit . 1418046514)
-		  (versions
-		   . #hash((default
-			        . #hasheq((source . "git://github.com/plt/racket/?path=pkgs/racket-lib")
-						      (checksum . "9f3c82c30ad1741d35c11ea3e1bb510119e7f476")
-							  (source_url . "git://github.com/plt/racket/?path=pkgs/racket-lib")))
-		           ("5.3.5"
-			        . #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
-						    (checksum . "9f098dddde7f217879070816090c1e8e74d49432")
-							(source_url . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")))
-	               ("5.3.4"
-				    . #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
-					        (checksum . "9f098dddde7f217879070816090c1e8e74d49432")
-							(source_url . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")))
-	               ("5.3.6"
-				    . #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
-					        (checksum . "9f098dddde7f217879070816090c1e8e74d49432")
-							(source_url . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")))))
-	      (tags . ("main-distribution"))
-		  (checksum-error . #f)
-		  (checksum . "9f098dddde7f217879070816090c1e8e74d49432")
-		  (ring . 0)
-		  (description . "Combines platform-specific native libraries that are useful for base Racket")
-		  (modules . ())
-		  (dependencies . (("racket-win32-i386-2" #:platform "win32\\i386")
-			               ("racket-win32-x86_64-2" #:platform "win32\\x86_64")
-						   ("racket-x86_64-linux-natipkg-2" #:platform "x86_64-linux-natipkg")
-						   ("db-ppc-macosx" #:platform "ppc-macosx")
-						   ("db-win32-i386" #:platform "win32\\i386")
-						   ("db-win32-x86_64" #:platform "win32\\x86_64")
-						   ("db-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg")
-						   ("com-win32-i386" #:platform "win32\\i386")
-						   ("com-win32-x86_64" #:platform "win32\\x86_64")))
-	      (conflicts . ())
-		  (authors . ("eli@racket-lang.org" "jay@racket-lang.org" "matthias@racket-lang.org" "mflatt@racket-lang.org" "robby@racket-lang.org" "ryanc@racket-lang.org" "samth@racket-lang.org"))
-		  (build . #hash((docs . ())
-		                 (success-log . #f)
-						 (failure-log . #f)
-						 (dep-failure-log . #f)
-						 (conflicts-log . #f)))
-	      (search-terms . #hasheq((author:mflatt@racket-lang.org . #t)
-			                      (author:eli@racket-lang.org . #t)
-								  (main-distribution . #t)
-								  (ring:0 . #t)
-								  (author:robby@racket-lang.org . #t)
-								  (author:samth@racket-lang.org . #t)
-								  (author:ryanc@racket-lang.org . #t)
-								  (author:jay@racket-lang.org . #t)
-								  (author:matthias@racket-lang.org . #t))))
-
-## Summary.rktd from the build server
-
-Sometimes only the `docs` key is present.
-
-    ("rmacs" . #hash((author . "tonygarnockjones@gmail.com")
-                     (docs . ())
-                     (success-log . "server/built/install/rmacs.txt")
-                     (failure-log . #f)
-                     (dep-failure-log . #f)
-                     (test-success-log . #f)
-                     (test-failure-log . "server/built/test-fail/rmacs.txt")
-                     (min-failure-log . #f)
-                     (conflicts-log . #f)))
-

src/package-catalog/api.rkt

@@ -1,2 +0,0 @@
-#lang racket/base
-

src/package-catalog/db.rkt

@@ -1,52 +0,0 @@
-#lang racket/base
-
-(provide make-db
-         db?
-         db-has-key?
-         db-ref
-         db-set!
-         db-remove!
-         db-keys)
-
-(require racket/file)
-(require file/sha1)
-
-(struct db (name path serializer deserializer) #:transparent)
-
-(define (make-db name path serializer deserializer)
-  (make-directory* path)
-  (db name path serializer deserializer))
-
-(define (check-key what db key)
-  (unless (string? key)
-    (error what "Invalid key for db ~a: ~v" (db-name db) key)))
-
-;; We avoid potential filesystem subdirectory escape attacks by
-;; encoding key paths into hex. Special characters in keys are thus
-;; permitted and rendered harmless.
-(define (key->path what db key)
-  (check-key what db key)
-  (build-path (db-path db) (bytes->hex-string (string->bytes/utf-8 key))))
-
-(define (db-has-key? db key)
-  (file-exists? (key->path 'db-has-key? db key)))
-
-(define (db-ref db key default)
-  (define p (key->path 'db-ref db key))
-  (cond
-    [(file-exists? p) ((db-deserializer db) (file->value p))]
-    [(procedure? default) (default)]
-    [else default]))
-
-(define (db-set! db key value)
-  (define p (key->path 'db-set! db key))
-  (write-to-file ((db-serializer db) value) p #:exists 'replace))
-
-(define (db-remove! db key)
-  (define p (key->path 'db-remove! db key))
-  (when (file-exists? p)
-    (delete-file p)))
-
-(define (db-keys db)
-  (map (lambda (p) (bytes->string/utf-8 (hex-string->bytes (path->string p))))
-       (directory-list (db-path db))))

src/package-catalog/main.rkt

@@ -1,7 +0,0 @@
-#lang racket/base
-
-(provide (all-from-out "structs.rkt")
-         (all-from-out "source.rkt"))
-
-(require "structs.rkt")
-(require "source.rkt")

src/package-catalog/source.rkt

@@ -1,182 +0,0 @@
-#lang racket/base
-
-(provide (struct-out url-source)
-         (struct-out git-source)
-         package-source?
-         string->package-source
-         package-source->string
-         github-source?
-         github-user+repo)
-
-(require racket/match)
-(require net/url)
-(require pkg/name)
-(require pkg/private/repo-path)
-(require (only-in racket/string string-join))
-
-(struct url-source (url ;; String
-                    )
-        #:prefab)
-(struct git-source (host ;; String
-                    port ;; Nat or #f
-                    repo ;; String (e.g. for github.com, "/user/repo")
-                    branch ;; String
-                    path ;; Relative URL String
-                    )
-        #:prefab)
-
-(define (package-source? x)
-  (or (url-source? x)
-      (git-source? x)))
-
-(define (string->package-source str)
-  (define u (string->url str))
-  (define-values (_name type) (package-source->name+type str #f))
-  (cond
-   [(memq type '(git github))
-    (define-values (_type host port repo branch path)
-      (if (equal? "github" (url-scheme u))
-          (match (split-github-url u)
-            [(list* user repo branch path)
-             (values 'github "github.com" #f (string-append user "/" repo) branch path)]
-            [(list user repo)
-             (values 'github "github.com" #f (string-append user "/" repo) "master" '())]
-            [_ (error 'string->package-source "Invalid github url: ~v" str)])
-          (split-git-url u)))
-    ;; TODO: clean this up in repo-path.rkt
-    (git-source host
-                port
-                repo
-                branch
-                (string-join path "/"))]
-   ;; [(and (member (url-scheme u) '("http" "https"))
-   ;;       (equal? (url-host u) "github.com"))
-   ;;  ;; ... parse the path, etc., and turn it into a git-source ...
-   ;;  ]
-   [else
-    (url-source (url->string u))]))
-
-(define (package-source->string s)
-  (match s
-    [(url-source u) u]
-    [(git-source host port repo branch path)
-     (url->string (url "git"
-                       #f
-                       host
-                       port
-                       #t
-                       (url-path (path->url repo))
-                       (if (string=? path "")
-                           '()
-                           (list (cons 'path path)))
-                       branch))]))
-
-(define (github-source? s)
-  (unless (package-source? s) (error 'github-source? "Expected package-source: ~v" s))
-  (match s
-    [(git-source "github.com" #f (regexp "^([^/]+)/([^/]+)/*$") _ _) #t]
-    [_ #f]))
-
-(define (github-user+repo s)
-  (unless (github-source? s) (error 'github-user+repo "Expected github package-source: ~v" s))
-  (match (regexp-match "^([^/]+)/([^/]+)/*$" (git-source-repo s))
-    [(list _ user repo) (values user repo)]
-    [#f (error 'github-user+repo "Invalid github repo path: ~v" (git-source-repo s))]))
-
-(module+ test
-  (require rackunit)
-
-  (check-equal? (string->package-source "https://github.com/user/repo")
-                (url-source "https://github.com/user/repo"))
-  (check-equal? (string->package-source "http://example.com/some/path/to/package.zip")
-                (url-source "http://example.com/some/path/to/package.zip"))
-
-  (check-equal? (string->package-source "git://github.com/user/repo")
-                (git-source "github.com" #f "user/repo" "master" ""))
-  (check-equal? (string->package-source "git://github.com/user/repo#master")
-                (git-source "github.com" #f "user/repo" "master" ""))
-  (check-equal? (string->package-source "git://github.com/user/repo?path=/subdir1/subdir2#master")
-                (git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
-  (check-equal? (string->package-source "git://github.com/user/repo?path=subdir1/subdir2#master")
-                (git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
-  (check-equal? (string->package-source "git://github.com/user/repo?path=%2fsubdir1%2fsubdir2#master")
-                (git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
-  (check-equal? (string->package-source "git://github.com/user/repo?path=subdir1%2fsubdir2#master")
-                (git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
-  (check-equal? (string->package-source "git://github.com/user/repo#otherbranch")
-                (git-source "github.com" #f "user/repo" "otherbranch" ""))
-  (check-equal? (string->package-source "git://github.com/user/repo?path=/subdir1/subdir2#otherbranch")
-                (git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
-  (check-equal? (string->package-source "git://github.com/user/repo?path=subdir1/subdir2#otherbranch")
-                (git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
-  (check-equal? (string->package-source "git://github.com/user/repo?path=%2fsubdir1%2fsubdir2#otherbranch")
-                (git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
-  (check-equal? (string->package-source "git://github.com/user/repo?path=subdir1%2fsubdir2#otherbranch")
-                (git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
-
-  (check-exn #px"Invalid github url"
-             (lambda () (string->package-source "github://github.com/user/")))
-
-  (check-equal? (string->package-source "github://github.com/user/repo")
-                (git-source "github.com" #f "user/repo" "master" ""))
-  (check-equal? (string->package-source "github://github.com/user/repo/")
-                (git-source "github.com" #f "user/repo" "master" ""))
-  (check-equal? (string->package-source "github://github.com/user/repo/master")
-                (git-source "github.com" #f "user/repo" "master" ""))
-  (check-equal? (string->package-source "github://github.com/user/repo/master/")
-                (git-source "github.com" #f "user/repo" "master" ""))
-  (check-equal? (string->package-source "github://github.com/user/repo/master/subdir1/subdir2")
-                (git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
-  (check-equal? (string->package-source "github://github.com/user/repo/otherbranch")
-                (git-source "github.com" #f "user/repo" "otherbranch" ""))
-  (check-equal? (string->package-source "github://github.com/user/repo/otherbranch/")
-                (git-source "github.com" #f "user/repo" "otherbranch" ""))
-  (check-equal? (string->package-source "github://github.com/user/repo/otherbranch/subdir1/subdir2")
-                (git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
-
-  (check-equal? (package-source->string
-                 (git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
-                "git://github.com/user/repo?path=subdir1%2Fsubdir2#master")
-  (check-equal? (package-source->string
-                 (git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
-                "git://github.com/user/repo?path=subdir1%2Fsubdir2#otherbranch")
-
-  (define (roundtrip str)
-    (check-equal? (package-source->string (string->package-source str)) str))
-
-  (roundtrip "https://github.com/user/repo")
-  (roundtrip "http://example.com/some/path/to/package.zip")
-  (roundtrip "git://github.com/user/repo#master")
-  (roundtrip "git://github.com/user/repo#otherbranch")
-
-  (check-equal? (github-source? (string->package-source "github://github.com/user/repo")) #t)
-  (check-equal? (github-source? (string->package-source "github://github.com/user/repo/master")) #t)
-  (check-equal? (github-source? (string->package-source "github://github.com/user/repo/master/subdir")) #t)
-
-  (check-equal? (github-source? (string->package-source "git://github.com/user/repo")) #t)
-  (check-equal? (github-source? (string->package-source "git://github.com/user/repo#master")) #t)
-  (check-equal? (github-source? (string->package-source "git://github.com/user/repo?path=subdir#master")) #t)
-
-  (check-equal? (github-source? (string->package-source "git://github.com/user/repo/more")) #f)
-  (check-equal? (github-source? (string->package-source "git://github.com/user/repo/more#master")) #f)
-  (check-equal? (github-source? (string->package-source "git://github.com/user/repo/more?path=subdir#master")) #f)
-
-  (check-equal? (github-source? (string->package-source "git://github.com/user")) #f)
-  (check-equal? (github-source? (string->package-source "git://github.com/user#master")) #f)
-  (check-equal? (github-source? (string->package-source "git://github.com/user?path=subdir#master")) #f)
-
-  (check-equal? (github-source? (string->package-source "git://example.com/user/repo")) #f)
-  (check-equal? (github-source? (string->package-source "git://example.com/user/repo#master")) #f)
-  (check-equal? (github-source? (string->package-source "git://example.com/user/repo?path=subdir#master")) #f)
-
-  (define (extract-user+repo str)
-    (define-values (user repo) (github-user+repo (string->package-source str)))
-    (list user repo))
-
-  (check-equal? (extract-user+repo "github://github.com/user/repo") (list "user" "repo"))
-  (check-equal? (extract-user+repo "github://github.com/user/repo/master") (list "user" "repo"))
-  (check-equal? (extract-user+repo "github://github.com/user/repo/master/subdir") (list "user" "repo"))
-  (check-equal? (extract-user+repo "git://github.com/user/repo") (list "user" "repo"))
-  (check-equal? (extract-user+repo "git://github.com/user/repo#master") (list "user" "repo"))
-  (check-equal? (extract-user+repo "git://github.com/user/repo?path=subdir#master") (list "user" "repo"))
-  )

src/package-catalog/structs.rkt

@@ -1,269 +0,0 @@
-#lang racket/base
-
-(provide (struct-out package)
-         package-author
-         serialize-package
-         deserialize-package
-
-         (struct-out computed-info)
-         serialize-computed-info
-         deserialize-computed-info
-
-         (struct-out github-info)
-         serialize-github-info
-         deserialize-github-info)
-
-(require racket/set)
-(require racket/match)
-(require (only-in racket/string string-split string-join))
-(require "source.rkt")
-
-;; A Time here is milliseconds-since-epoch - e.g. a result from
-;; (current-inexact-milliseconds).
-
-(define package-format-version 0) ;; IMPORTANT - UPDATE THIS AND CHANGE SERIALIZATION
-                                  ;; WHENEVER THE STRUCT DEFINITION FOR package CHANGES
-(struct package (name ;; String
-                 source ;; PackageSource
-                 description ;; String
-                 tags ;; (Listof String)
-                 authors ;; (Listof String)
-                 versions ;; (HashTable String PackageSource)
-                 ring ;; Nat
-                 last-edit ;; Time
-                 )
-        #:prefab)
-
-(define (package-author p)
-  (string-join (package-authors p) " "))
-
-(define computed-info-format-version 0) ;; IMPORTANT - UPDATE THIS AND CHANGE SERIALIZATION
-                                        ;; WHENEVER THE STRUCT DEFINITION FOR computed-info CHANGES
-(struct computed-info (package-name ;; String
-                       last-updated ;; Time, most recent change to package source
-                       last-checked ;; Time, when package source was most recently checked
-                       checksums ;; (HashTable String String), including "default" key
-                       checksum-errors ;; (HashTable String String), including "default" key
-                       github-info ;; GithubInfo or #f
-                       declared-conflicts ;; (Setof String), package names
-                       modules ;; (Listof ModulePath)
-                       dependencies ;; (Listof String), package names
-                       )
-        #:prefab)
-
-(define github-info-format-version 0) ;; IMPORTANT - UPDATE THIS AND CHANGE SERIALIZATION
-                                      ;; WHENEVER THE STRUCT DEFINITION FOR github-info CHANGES
-(struct github-info (readme-exists? ;; Boolean
-                     )
-        #:prefab)
-
-;;---------------------------------------------------------------------------
-;; This is the kind of stupid repetitive code our struct system should
-;; allow us to automate.
-
-(define (serialize-package p)
-  (match-define (package name source description tags authors versions ring last-edit) p)
-  (list 'package package-format-version
-        (hash 'name name
-              'source (package-source->string source)
-              'description description
-              'tags tags
-              'authors authors
-              'versions (for/hash [((version source) (in-hash versions))]
-                          (values version (package-source->string source)))
-              'ring ring
-              'last-edit last-edit)))
-
-(define (deserialize-package p)
-  (match p
-    [(? hash?)
-     (package (hash-ref p 'name)
-              (string->package-source (hash-ref p 'source))
-              (hash-ref p 'description "")
-              (hash-ref p 'tags '())
-              (string-split (hash-ref p 'author ""))
-              (for/hash [((version fields) (in-hash (hash-ref p 'versions (hash))))]
-                (values version (string->package-source (hash-ref fields 'source))))
-              (hash-ref p 'ring 2)
-              (hash-ref p 'last-edit 0))]
-    [(list 'package 0
-           (hash-table ['name (? string? name)]
-                       ['source (? string? source0)]
-                       ['description (? string? description)]
-                       ['tags (and (list (? string?) ...) tags)]
-                       ['authors (and (list (? string?) ...) authors)]
-                       ['versions versions0]
-                       ['ring (? number? ring)]
-                       ['last-edit (? number? last-edit)]))
-     (define source (string->package-source source0))
-     (define versions (for/hash [((version source) (in-hash versions0))]
-                        (values version (string->package-source source))))
-     (package name source description tags authors versions ring last-edit)]
-    [_
-     (error 'deserialize-package "Unrecognized serialized package: ~v" p)]))
-
-(define (serialize-computed-info ci)
-  (match-define (computed-info package-name
-                               last-updated
-                               last-checked
-                               checksums
-                               checksum-errors
-                               github-info
-                               declared-conflicts
-                               modules
-                               dependencies)
-                ci)
-  (list 'computed-info computed-info-format-version
-        (hash 'package-name package-name
-              'last-updated last-updated
-              'last-checked last-checked
-              'checksums checksums
-              'checksum-errors checksum-errors
-              'github-info (and github-info (serialize-github-info github-info))
-              'declared-conflicts declared-conflicts
-              'modules modules
-              'dependencies dependencies)))
-
-(define (deserialize-computed-info ci)
-  (match ci
-    [(? hash?)
-     (computed-info (hash-ref ci 'name)
-                    (hash-ref ci 'last-updated 0)
-                    (hash-ref ci 'last-checked 0)
-                    (let ((cs (for/hash [((v fs) (in-hash (hash-ref ci 'versions (hash))))
-                                         #:when (hash-has-key? fs 'checksum)]
-                                (values v (hash-ref fs 'checksum)))))
-                      (if (hash-has-key? ci 'checksum)
-                          (hash-set cs "default" (hash-ref ci 'checksum))
-                          cs))
-                    (let ((err (hash-ref ci 'checksum-error #f)))
-                      (if err
-                          (hash "default" err)
-                          (hash)))
-                    #f
-                    (list->set (hash-ref ci 'conflicts '()))
-                    (hash-ref ci 'modules '())
-                    (hash-ref ci 'dependencies '()))]
-    [(list 'computed-info 0
-           (hash-table ['package-name (? string? package-name)]
-                       ['last-updated (? number? last-updated)]
-                       ['last-checked (? number? last-checked)]
-                       ['checksums checksums]
-                       ['checksum-errors checksum-errors]
-                       ['github-info github-info0]
-                       ['declared-conflicts declared-conflicts]
-                       ['modules (and (list (? module-path?) ...) modules)]
-                       ['dependencies (and (list (? string?) ...) dependencies)]))
-     (define github-info (and github-info0 (deserialize-github-info github-info0)))
-     (computed-info package-name
-                    last-updated
-                    last-checked
-                    checksums
-                    checksum-errors
-                    github-info
-                    declared-conflicts
-                    modules
-                    dependencies)]
-    [_
-     (error 'deserialize-computed-info "Unrecognized serialized computed-info: ~v" ci)]))
-
-(define (serialize-github-info gi)
-  (match-define (github-info readme-exists?) gi)
-  (list 'github-info github-info-format-version
-        (hash 'readme-exists? readme-exists?)))
-
-(define (deserialize-github-info gi)
-  (match gi
-    [(list 'github-info 0
-           (hash-table ['readme-exists? readme-exists?]))
-     (github-info readme-exists?)]
-    [_
-     (error 'deserialize-github-info "Unrecognized serialized github-info: ~v" gi)]))
-
-;;---------------------------------------------------------------------------
-
-(module+ test
-  (require rackunit)
-
-  (define empty-zip "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
-  (define empty-zip-checksum "9f098dddde7f217879070816090c1e8e74d49432")
-
-  (define xrepl-lib-hash
-    #hash((name . "xrepl-lib")
-          (source . "git://github.com/racket/xrepl/?path=xrepl-lib")
-          (author . "eli@racket-lang.org")
-          (last-updated . 1417912075)
-          (last-edit . 1417659583)
-          (last-checked . 1421095102)
-          (versions
-           . #hash(("5.3.5"
-                    . #hash((source
-                             . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
-                            (checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
-                   ("5.3.4"
-                    . #hash((source
-                             . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
-                            (checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
-                   ("5.3.6"
-                    . #hash((source
-                             . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
-                            (checksum . "9f098dddde7f217879070816090c1e8e74d49432")))))
-          (tags . ("main-distribution"))
-          (checksum-error . #f)
-          (ring . 0)
-          (checksum . "c88f8430b054d8a207a95acb0d1de0efece33510")
-          (description . "implementation (no documentation) part of \"xrepl\"")
-          (modules . ((lib "xrepl/saved-values.rkt")
-                      (lib "xrepl/xrepl.rkt")
-                      (lib "xrepl/main.rkt")))
-          (dependencies . ("base" "readline-lib" "scribble-text-lib"))
-          (conflicts . ())))
-
-  (define xrepl-lib (package "xrepl-lib"
-                             (git-source "github.com"
-                                         #f
-                                         "racket/xrepl"
-                                         "master"
-                                         "xrepl-lib")
-                             "implementation (no documentation) part of \"xrepl\""
-                             '("main-distribution")
-                             '("eli@racket-lang.org")
-                             (hash "5.3.4" (url-source empty-zip)
-                                   "5.3.5" (url-source empty-zip)
-                                   "5.3.6" (url-source empty-zip))
-                             0
-                             1417659583))
-
-  (define xrepl-lib-info (computed-info "xrepl-lib"
-                                        1417912075
-                                        1421095102
-                                        (hash "5.3.4" empty-zip-checksum
-                                              "5.3.5" empty-zip-checksum
-                                              "5.3.6" empty-zip-checksum
-                                              "default" "c88f8430b054d8a207a95acb0d1de0efece33510")
-                                        (hash)
-                                        #f
-                                        (set)
-                                        (list '(lib "xrepl/saved-values.rkt")
-                                              '(lib "xrepl/xrepl.rkt")
-                                              '(lib "xrepl/main.rkt"))
-                                        (list "base" "readline-lib" "scribble-text-lib")))
-
-  (check-equal? (deserialize-package xrepl-lib-hash) xrepl-lib)
-  (check-equal? (serialize-package xrepl-lib)
-                (list 'package package-format-version
-                      (hash 'name "xrepl-lib"
-                            'source "git://github.com/racket/xrepl?path=xrepl-lib#master"
-                            'tags '("main-distribution")
-                            'description "implementation (no documentation) part of \"xrepl\""
-                            'last-edit 1417659583
-                            'versions (hash "5.3.4" empty-zip
-                                            "5.3.5" empty-zip
-                                            "5.3.6" empty-zip)
-                            'ring 0
-                            'authors '("eli@racket-lang.org"))))
-  (check-equal? (deserialize-package (serialize-package xrepl-lib)) xrepl-lib)
-
-  (check-equal? (deserialize-computed-info xrepl-lib-hash) xrepl-lib-info)
-  (check-equal? (deserialize-computed-info (serialize-computed-info xrepl-lib-info)) xrepl-lib-info)
-  )

src/package-source.rkt

@@ -0,0 +1,160 @@
+#lang racket/base
+;; Package Source URLs: their various kinds
+
+;; Here we're only interested in remote URLs -- http, https, git and
+;; github. Local file and directory package sources are not to be
+;; accepted.
+
+(provide parse-package-source
+         parsed-package-source-human-url
+         parsed-package-source-human-tree-url
+         unparse-package-source
+         package-source->human-tree-url
+         (struct-out parsed-package-source)
+         (struct-out simple-url-source)
+         (struct-out git-source))
+
+(require racket/match)
+(require (only-in racket/string string-join string-split))
+(require net/url)
+(require pkg/private/repo-path)
+(require pkg/name)
+
+;; A ParsedPackageSource is one of
+;; -- (simple-url-source    String (Option String) (Option Symbol))
+;; -- (git-source           String (Option String) Symbol Symbol String (Option Number) String String String)
+(struct parsed-package-source (url-string inferred-name type) #:prefab)
+(struct simple-url-source parsed-package-source () #:prefab)
+(struct git-source parsed-package-source (transport host port repo commit path) #:prefab)
+
+;; String -> (Values (Option ParsedPackageSource) (Listof String))
+;; The second result is a list of complaints about the passed-in package source URL string.
+(define (parse-package-source p)
+  (define complaints '())
+  (define (complain message) (set! complaints (append complaints (list message))))
+
+  (define-values (name type)
+    (with-handlers ([void (lambda (e) (values #f #f))])
+      (package-source->name+type p #f
+                                 #:complain (lambda (_p message) (complain message))
+                                 #:must-infer-name? #t)))
+
+  (define parsed-source
+    (match type
+      [#f
+       (complain "couldn't guess package source type")
+       (simple-url-source p name type)]
+
+      ;; ['name] -- only ever returned if it was passed in as second arg to package-source->name+type
+      ;; ['clone] -- only returned if passed in, like 'name
+      ;; ['link] -- only returned if #:link-dirs? given, except if it's a file:// url with a type query parameter of link
+      ;; ['static-link] -- only returned if it's a file:// url with a type query parameter of static-link
+
+      [(or 'file 'dir)
+       (complain "local file or directory package source types are not permitted")
+       #f]
+
+      [(or 'git 'github)
+       (with-handlers ([void (lambda (e) (simple-url-source p name type))])
+         (define u (string->url p))
+         (define-values (transport host port repo commit path) (split-git-or-hub-url u #:type type))
+         (git-source p name type
+                     (if (eq? type 'github) 'git transport)
+                     host
+                     port
+                     repo
+                     commit
+                     (string-join path "/")))]
+
+      [(or 'file-url 'dir-url)
+       (with-handlers ([void (lambda (e) (simple-url-source p name type))])
+         (define u (string->url p)) ;; just to check it *can* be parsed as a URL
+         (simple-url-source p name type))]))
+
+  (values parsed-source complaints))
+
+(define (parsed-package-source-human-url s)
+  (match s
+    [(git-source u _ type _ host port repo _ _)
+     (real-git-url (string->url u) host port repo #:type type)]
+    [(simple-url-source u _ _)
+     u]))
+
+(define (parsed-package-source-human-tree-url s)
+  (match s
+    [(git-source _ _ _ _ "github.com" _ repo commit path)
+     (url->string
+      (url "https"
+           #f
+           "github.com"
+           #f
+           #t
+           (append (->url-path (regexp-replace #rx"[.]git$" repo ""))
+                   (list (path/param "tree" '())
+                         (path/param commit '()))
+                   (->url-path path))
+           '()
+           #f))]
+    [_ (parsed-package-source-human-url s)]))
+
+(define (unparse-package-source s)
+  (match s
+    [(git-source _ _ _ transport host port repo commit path)
+     (url->string
+      (url (symbol->string transport)
+           #f
+           host
+           port
+           #t
+           (->url-path repo)
+           (match path ["" '()] [_ (list (cons 'path path))])
+           (match commit [#f #f] ["master" #f] [_ commit])))]
+    [(simple-url-source u _ _)
+     u]))
+
+(define (->url-path str)
+  (map (lambda (s) (path/param s '())) (string-split str "/")))
+
+(define (package-source->human-tree-url source)
+  (define-values (parsed complaints) (parse-package-source source))
+  (if parsed (parsed-package-source-human-tree-url parsed) source))
+
+(module+ test
+  (define test-data
+    (list
+     "http://github.com/test/repo.git"
+     "https://github.com/test/repo.git"
+     "http://leastfixedpoint.com:55555/foo/bar.git?path=zot/quux/baz#release"
+     "git://leastfixedpoint.com:55555/foo/bar.git?path=zot/quux/baz#release"
+     "github://github.com/foo/bar/master"
+     "github://github.com/foo/bar.git/master"
+     "github://github.com/foo/bar.git/release/zot/quux/baz"
+     "github://github.com/foo/bar/release/zot/quux/baz"
+     "github://github.com/tonyg/racket-ansi.git/master"
+     "github://github.com/tonyg/racket-ansi/master"
+     ))
+
+  (require rackunit)
+  (require racket/set)
+
+  (define seen-types
+    (for/set ((p test-data))
+      (define-values (name type) (package-source->name+type p #f))
+      type))
+
+  (define expected-types
+    (set 'git 'github 'file-url 'dir-url))
+
+  (check-equal? (set) (set-subtract seen-types expected-types))
+  (check-equal? (set) (set-subtract expected-types seen-types))
+
+  (for ((p test-data))
+    (define-values (parsed-source complaints) (parse-package-source p))
+    (printf "~v:\n - ~v\n - ~v\n - ~v\n"
+            p
+            parsed-source
+            complaints
+            (unparse-package-source parsed-source))
+    (void)
+    )
+  )

src/packages.rkt

@@ -53,14 +53,20 @@
 (define (fetch-remote-packages)
   (log-info "Fetching package list from ~a" package-index-url)
   (define result
-    (with-handlers ((exn:fail? (lambda (e) #f)))
+    (with-handlers ([exn:fail?
-      (define response-bytes (port->bytes (get-pure-port (string->url package-index-url))))
+                     (lambda (e)
+                       ((error-display-handler) (exn-message e) e)
+                       #f)])
+      (define response-port
+        (get-pure-port (string->url package-index-url)))
+      (define response-bytes (port->bytes response-port))
+      (close-input-port response-port)
       (define decompressed (gunzip/bytes response-bytes))
       (define decoded (bytes->jsexpr decompressed))
       decoded))
   (if (hash? result)
       (log-info "Fetched package list containing ~a packages." (hash-count result))
-      (log-info "Fetched bogus package list"))
+      (log-info "Fetched bogus package list: ~e" result))
   result)
 
 (define (tombstone? pkg)
@@ -121,13 +127,17 @@
                [all-tags
                 (for/fold ((ts (set)))
                           ((pkg (in-hash-values (package-manager-state-local-packages state))))
+                  (if (tombstone? pkg)
+                      ts
                       (set-union ts (list->set
                                      (map symbol->string
-                                      (hash-keys (or (@ pkg search-terms) (hash)))))))]
+                                          (hash-keys (or (@ pkg search-terms) (hash))))))))]
                [all-formal-tags
                 (for/fold ((ts (set)))
                           ((pkg (in-hash-values (package-manager-state-local-packages state))))
-                  (set-union ts (list->set (or (@ pkg tags) '()))))]))
+                  (if (tombstone? pkg)
+                      ts
+                      (set-union ts (list->set (or (@ pkg tags) '())))))]))
 
 (define (replace-package completion-ch old-pkg new-pkg state)
   (define local-packages (package-manager-state-local-packages state))
@@ -197,7 +207,7 @@
      [('package-detail name)
       (values (lookup-package name local-packages) state)]
      [('package-batch-detail names)
-      (values (for/list ((name names)) (lookup-package name local-packages)) state)]
+      (values (filter values (for/list ((name names)) (lookup-package name local-packages))) state)]
      [('external-information name)
       (values (hash-ref external-information name (lambda () (hash))) state)]
      [('set-external-information! name info)
@@ -249,7 +259,7 @@
 (define (next-fetch-deadline) (manager-rpc 'next-fetch-deadline))
 
 (define (sort-package-names names)
-  (sort names (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
+  (sort names (lambda (a b) (string-ci<? (symbol->string a) (symbol->string b)))))
 
 (define (sorted-package-names)
   (sort-package-names (all-package-names)))
@@ -271,7 +281,11 @@
 
 (define ((package-text-matches? pkg) re)
   (and (not (tombstone? pkg))
-       (regexp-match? re (@ pkg _SEARCHABLE-TEXT_))))
+       (regexp-match? re (or (@ pkg _SEARCHABLE-TEXT_)
+                             ;; Packages lacking the _SEARCHABLE-TEXT_ key are _LOCALLY_MODIFIED_.
+                             ;; Synthesise searchable text here; a better (?) alternative would be
+                             ;; to do this at package save time, but this will do for now.
+                             (pkg->searchable-text pkg)))))
 
 (define (package-search text tags)
   (define res (map (lambda (r) (regexp (regexp-quote r #f))) (string-split text)))

src/rpc.rkt

@@ -1,11 +1,15 @@
 #lang racket/base
 
-(provide rpc-request-evt
+(provide (struct-out exn:fail:rpc)
+         rpc-request-evt
          rpc-handler
          rpc-call
          rpc-cast!)
 
 (require racket/match)
+(require racket/exn)
+
+(struct exn:fail:rpc exn:fail (inner-exn) #:transparent)
 
 (define (rpc-request-evt)
   (handle-evt (thread-receive-evt)
@@ -15,16 +19,30 @@
   (match ch-and-req
     [(cons ch request)
      (define-values (reply-value new-state)
+       (with-handlers [(exn:fail? (lambda (e)
+                                    (channel-put ch e)
+                                    (raise e)))]
          (match request
            [(list argpat ...) body ...]
-         ...))
+           ...)))
      (when ch (channel-put ch reply-value))
      new-state]))
 
 (define (rpc-call thread . request)
   (define ch (make-channel))
   (thread-send thread (cons ch request))
-  (channel-get ch))
+  (define result
+    (sync (handle-evt thread
+                      (lambda (_)
+                        (raise (exn:fail:rpc "Server thread terminated unexpectedly"
+                                             (current-continuation-marks)
+                                             #f))))
+          ch))
+  (when (exn? result)
+    (raise (exn:fail:rpc (format "RPC exception:\n~a" (exn->string result))
+                         (current-continuation-marks)
+                         result)))
+  result)
 
 (define (rpc-cast! thread . request)
   (thread-send thread (cons #f request)))

src/sessions.rkt

@@ -20,7 +20,7 @@
          (* 7 24 60 60)) ;; one week in seconds
      1000)) ;; convert to milliseconds
 
-(struct session (key expiry email password) #:prefab)
+(struct session (key expiry email password curator? superuser?) #:prefab)
 
 (define sessions (make-persistent-state 'session-store (lambda () (make-hash))))
 
@@ -36,7 +36,7 @@
     (when (and s (<= (session-expiry s) now))
       (hash-remove! ss session-key))))
 
-(define (create-session! email password)
+(define (create-session! email password #:curator? [curator? #f] #:superuser? [superuser? #f])
   (expire-sessions!)
   (define session-key (bytes->string/utf-8 (random-bytes/base64 32)))
   (hash-set! (sessions)
@@ -44,7 +44,9 @@
              (session session-key
                       (+ (current-inexact-milliseconds) session-lifetime)
                       email
-                      password))
+                      password
+                      curator?
+                      superuser?))
   session-key)
 
 (define (destroy-session! session-key)

src/signals.rkt

@@ -4,14 +4,20 @@
 (provide poll-signal
 	 start-restart-signal-watcher)
 
+(require (only-in racket/file file->string))
 (require reloadable)
 (require "daemon.rkt")
 
 (define (poll-signal signal-file-name message handler)
   (when (file-exists? signal-file-name)
-    (log-info message)
+    (define contents (file->string signal-file-name))
+    (if (string=? contents "")
+        (log-info "~a" message)
+        (log-info "~a: ~a" message contents))
     (delete-file signal-file-name)
-    (handler)))
+    (if (procedure-arity-includes? handler 1)
+        (handler contents)
+        (handler))))
 
 (define (start-restart-signal-watcher)
   (daemon-thread
@@ -33,11 +39,17 @@
                     reload!)
        (poll-signal "../signals/.fetchindex"
                     "Index refresh signal received"
+                    (lambda ()
                       (reloadable-entry-point->procedure
-                     (lookup-reloadable-entry-point 'refresh-packages! "packages.rkt")))
+                       (lookup-reloadable-entry-point 'refresh-packages! "packages.rkt"))))
        (poll-signal "../signals/.rerender"
                     "Static rerender request received"
-                    (reloadable-entry-point->procedure
+                    (lambda (request-body)
-                     (lookup-reloadable-entry-point 'rerender-all! "site.rkt")))
+                      (define items-to-rerender (read (open-input-string request-body)))
+                      ((reloadable-entry-point->procedure
+                        (lookup-reloadable-entry-point 'rerender! "site.rkt"))
+                       (if (eof-object? items-to-rerender)
+                           #f
+                           items-to-rerender))))
        (sleep 0.5)
        (loop)))))

src/static.rkt

@@ -1,39 +1,78 @@
 #lang racket/base
 
-(provide static-generated-directory
+(provide rendering-static-page?
-         rendering-static-page?
          static-render!
-         finish-static-update!
+         static-put-file!
+         static-delete-file!
+         static-finish-update!
          extra-files-paths)
 
+(require racket/match)
 (require racket/system)
+(require racket/path)
+(require racket/port)
 (require racket/promise)
 (require racket/file)
 (require web-server/private/servlet)
 (require web-server/http/request-structs)
 (require web-server/http/response-structs)
+(require file/md5)
+(require xml)
+(require xml/path)
 (require net/url)
+(require aws/s3)
+(require reloadable)
 (require "config.rkt")
+(require "daemon.rkt")
+(require "rpc.rkt")
 (require "hash-utils.rkt")
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Config
+
+(define static-output-type
+  ;; Either 'aws-s3 or 'file
+  (or (@ (config) static-output-type)
+      'file))
+
+(define aws-s3-bucket+path
+  ;; Must end in "/"
+  (@ (config) aws-s3-bucket+path))
+
 (define static-generated-directory
+  ;; Relevant to static-output-type 'file only
   (config-path (or (@ (config) static-generated-directory)
                    (build-path (var-path) "generated-htdocs"))))
 
 (define static-content-target-directory
+  ;; Relevant to static-output-type 'file only
   (let ((p (@ (config) static-content-target-directory)))
     (and p (config-path p))))
 
-(define static-content-update-hook (@ (config) static-content-update-hook))
+(define pkg-index-generated-directory
+  (config-path (or (@ (config) pkg-index-generated-directory)
+                   (error 'pkg-index-generated-directory "Not specified"))))
 
-(define extra-static-content-directories
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  (map config-path
+;; Static rendering daemon -- Interface
-       (or (@ (config) extra-static-content-directories)
-           '())))
 
 (define rendering-static-page? (make-parameter #f))
 
+(define (assert-absolute! what absolute-path)
+  (when (not (eqv? (string-ref absolute-path 0) #\/))
+    (error what "Path must start with /; got ~v" absolute-path)))
+
+(define (static-put-file! absolute-path content-bytes mime-type)
+  (assert-absolute! 'static-put-file! absolute-path)
+  (renderer-rpc 'put-file! absolute-path content-bytes mime-type))
+
+(define (static-delete-file! absolute-path)
+  (assert-absolute! 'static-delete-file! absolute-path)
+  (renderer-rpc 'delete-file! absolute-path))
+
 (define (static-render! #:filename [base-filename #f]
+                        #:ignore-response-code? [ignore-response-code? #f]
+                        #:mime-type mime-type
                         named-url handler . named-url-args)
   (define request-url (apply named-url handler named-url-args))
   (log-info "Rendering static version of ~a~a"
@@ -58,22 +97,51 @@
                             "127.0.0.1")
                    named-url-args))
           servlet-prompt)))))
-  (define filename (format "~a~a" static-generated-directory (or base-filename request-url)))
+  (define absolute-path (or base-filename request-url))
+  (assert-absolute! 'static-render! absolute-path)
+  (define content-bytes (call-with-output-bytes (response-output response)))
   (cond
-   [(<= 200 (response-code response) 299) ;; "OKish" range
+   [(or (<= 200 (response-code response) 299) ;; "OKish" range
-    (make-parent-directory* filename)
+        ignore-response-code?)
-    (call-with-output-file filename
+    (static-put-file! absolute-path content-bytes mime-type)]
-      (response-output response)
-      #:exists 'replace)]
    [(= (response-code response) 404) ;; Not found -> delete the file
-    (when (file-exists? filename)
+    (static-delete-file! absolute-path)]
-      (delete-file filename))]
    [else
     (log-warning "Unexpected response code ~v when static-rendering ~v"
                  (response-code response)
                  (cons handler named-url-args))]))
 
-(define (finish-static-update!)
+(define (static-finish-update!)
+  (renderer-rpc 'finish-update!))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Static rendering daemon -- Implementation
+
+(define (static-renderer-main)
+  (match static-output-type
+    ['file (static-renderer-file)]
+    ['aws-s3 (static-renderer-aws-s3 #f)])
+  (static-renderer-main))
+
+;;---------------------------------------- 'file
+
+(define (static-renderer-file)
+  (rpc-handler (sync (rpc-request-evt))
+    [('reload!)
+     (values (void) (void))]
+    [('put-file! absolute-path content-bytes mime-type)
+     (define filename (format "~a~a" static-generated-directory absolute-path))
+     (make-parent-directory* filename)
+     (call-with-output-file filename
+       (lambda (p) (write-bytes content-bytes p))
+       #:exists 'replace)
+     (values (void) (void))]
+    [('delete-file! absolute-path)
+     (define filename (format "~a~a" static-generated-directory absolute-path))
+     (when (file-exists? filename)
+       (delete-file filename))
+     (values (void) (void))]
+    [('finish-update!)
      (when static-content-target-directory
        (make-directory* static-content-target-directory)
        (define command
@@ -82,15 +150,156 @@
                        "--delete"
                        (path->string (build-path static-generated-directory "."))
                        (path->string (build-path (config-path "../static") ".")))
-              (for/list [(dir extra-static-content-directories)]
+                 (list (path->string (build-path pkg-index-generated-directory ".")))
-                (path->string (build-path dir ".")))
                  (list (path->string (build-path static-content-target-directory ".")))))
        (log-info "Executing rsync to replicate static content; argv: ~v" command)
        (apply system* command))
-  (when static-content-update-hook
+     (values (void) (void))]))
-    (system static-content-update-hook)))
+
+;;---------------------------------------- 'aws-s3
+
+(define (initial-aws-s3-index)
+  (for/hash [(entry (ls/proc aws-s3-bucket+path append '()))]
+    (match-define (pregexp "^\"(.*)\"$" (list _ file-md5-str))
+      (apply string-append (se-path*/list '(ETag) entry)))
+    (values (se-path* '(Key) entry)
+            (string->bytes/utf-8 file-md5-str))))
+
+(define (absolute-path->relative-path absolute-path)
+  (assert-absolute! 'absolute-path->relative-path absolute-path)
+  (substring absolute-path 1))
+
+(define put-bytes-sema (make-semaphore 10))
+(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)))))
+
+(define (aws-put-file! index absolute-path content-bytes mime-type [headers '()])
+  (define relative-path (absolute-path->relative-path absolute-path))
+  (define new-md5 (md5 content-bytes))
+  (if (equal? new-md5 (hash-ref index relative-path #f))
+      (begin
+        ;; (log-info "Not uploading ~a to S3, since MD5 has not changed" relative-path)
+        (void))
+      (begin
+        (log-info "Uploading ~a to S3; new MD5 = ~a" relative-path new-md5)
+        (put/bytes^ (string-append aws-s3-bucket+path relative-path)
+                    content-bytes
+                    mime-type
+                    (cons (cons 'x-amz-acl "public-read")
+                          headers))))
+  (hash-set index relative-path new-md5))
+
+(define (aws-delete-file! index absolute-path)
+  (define relative-path (absolute-path->relative-path absolute-path))
+  (log-info "Deleting ~a from S3" relative-path)
+  (delete (string-append aws-s3-bucket+path relative-path))
+  (hash-remove index relative-path))
+
+(define (extension-map p)
+  (match (filename-extension p)
+    [#"html" "text/html"]
+    [#"css" "text/css"]
+    [#"js" "application/javascript"]
+    [#"json" "application/json"]
+    [#"png" "image/png"]
+    [#"svg" "image/svg"]
+    [#f "application/octet-stream"]
+    [other ;; (log-info "Unknown extension in extension-map: ~a" other)
+           "application/octet-stream"]))
+
+(define (upload-directory! index source-directory0 target-absolute-path-prefix)
+  (define source-directory (simple-form-path source-directory0))
+  (for/fold [(index index)]
+            [(filepath (find-files file-exists? source-directory))]
+    (define absolute-path
+      (path->string (build-path target-absolute-path-prefix
+                                (find-relative-path source-directory filepath))))
+    ;; https://github.com/tonyg/racket-pkg-website/issues/28
+    ;; TOCTTOU: we checked that `file-exists?` above, but that may have changed since!
+    (define contents
+      (with-handlers [(exn:fail:filesystem?
+                       ;; ^ It would be nice to be able to be more precise here, e.g.
+                       ;; file-not-found, but `file->bytes` delegates to `file-size` which
+                       ;; only raises `exn:fail:filesystem` when a problem occurs.
+                       (lambda (e)
+                         (log-warning "Transient (?) problem reading ~v: ~v"
+                                      filepath
+                                      (exn-message e))
+                         #f))]
+        (file->bytes filepath)))
+    (if contents
+        (aws-put-file! index absolute-path contents (extension-map filepath))
+        (aws-delete-file! index absolute-path))))
+
+(define (configure-s3-cors!)
+  (log-info "Configuring S3 CORS headers:\n~a"
+            (put/bytes (string-append aws-s3-bucket+path "?cors")
+                       (string->bytes/utf-8 (xexpr->string
+                                             `(CORSConfiguration
+                                               (CORSRule (AllowedOrigin "*")
+                                                         (AllowedMethod "GET")
+                                                         (AllowedHeader "*")))))
+                       "application/xml"
+                       '())))
+
+(define (static-renderer-aws-s3 index)
+  (s3-region "us-west-2")
+  (when (not index) (configure-s3-cors!))
+  (let ((index (or index (initial-aws-s3-index))))
+    (match
+        (rpc-handler (sync (rpc-request-evt))
+          [('reload!)
+           (values (void) 'reload!)]
+          [('put-file! absolute-path content-bytes mime-type)
+           (values (void) (aws-put-file! index absolute-path content-bytes mime-type))]
+          [('delete-file! absolute-path)
+           (values (void) (aws-delete-file! index absolute-path))]
+          [('finish-update!)
+           (let* ((index (upload-directory! index (build-path (config-path "../static") ".") "/"))
+                  (index (upload-directory! index
+                                            (build-path pkg-index-generated-directory "pkg")
+                                            "/pkg/")))
+             (values (void)
+                     (for/fold [(index index)]
+                               [(leaf (in-list `(("atom.xml" "application/atom+xml")
+                                                 ("pkgs" "application/octet-stream")
+                                                 ("pkgs-all" "application/octet-stream")
+                                                 ("pkgs-all.json.gz" "application/json"
+                                                  (Content-Encoding . "gzip"))
+                                                 ("pkgs.json" "application/json"))))]
+                       (match-define (list* filename mime-type headers) leaf)
+                       (aws-put-file! index
+                                      (path->string (build-path "/" filename))
+                                      (file->bytes
+                                       (build-path pkg-index-generated-directory filename))
+                                      mime-type
+                                      headers))))])
+      ['reload! (void)] ;; effectively restarts daemon
+      [next-index (static-renderer-aws-s3 next-index)])))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Static rendering daemon -- Startup
+
+(define static-renderer-thread
+  (make-persistent-state 'static-renderer-thread
+                         (lambda () (daemon-thread 'static-renderer
+                                                   (lambda () (static-renderer-main))))))
+
+(define (renderer-rpc . request) (apply rpc-call (static-renderer-thread) request))
+
+(renderer-rpc 'reload!)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Interface to web-server static file serving
 
 (define (extra-files-paths)
-  (list* static-generated-directory
+  (list static-generated-directory
         (config-path "../static")
-         extra-static-content-directories))
+        pkg-index-generated-directory))

static/editpackage.js

@@ -18,34 +18,30 @@ function preenSourceType(e) {
     }
     return control(e, n).val();
   }
-  function showhide(s, gh, gu, gp, gb) {
+  function showhide(s, gt, gh, gr, gc, gp) {
     return [showhide1("simple_url", s),
-	    showhide1("g_host", gh),
+	    showhide1("g_transport", gt),
-	    showhide1("g_user", gu),
+	    showhide1("g_host_port", gh),
-	    showhide1("g_project", gp),
+	    showhide1("g_repo", gr),
-	    showhide1("g_branch", gb)];
+	    showhide1("g_commit", gc),
+	    showhide1("g_path", gp)];
   }
   var pieces;
   var previewUrl;
   var previewGroup = control(e, "urlpreview__group");
   var previewInput = control(e, "urlpreview");
   switch (e.value) {
-    case "github":
-      previewGroup.show();
-      pieces = showhide(false, false, true, true, true);
-      previewUrl = "github://github.com/" + pieces[2] + "/" + pieces[3] +
-                   (pieces[4] ? "/" + pieces[4] : "");
-      break;
     case "git":
       previewGroup.show();
-      pieces = showhide(false, true, true, true, true);
+      pieces = showhide(false, true, true, true, true, true);
-      previewUrl = "git://" + pieces[1] + "/" + pieces[2] + "/" + pieces[3] +
+      previewUrl = pieces[1] + "://" + pieces[2] + "/" + pieces[3] +
-                   (pieces[4] ? "/" + pieces[4] : "");
+        (pieces[5] ? "?path=" + pieces[5] : "") +
+        (pieces[4] && (pieces[4] !== 'master') ? '#' + pieces[4] : "");
       break;
     case "simple":
     default:
       previewGroup.hide();
-      pieces = showhide(true, false, false, false, false);
+      pieces = showhide(true, false, false, false, false, false);
       previewUrl = pieces[0];
       break;
   }
@@ -74,7 +70,7 @@ $(document).ready(function () {
   $(".package-version-source-type").each(function (index, e) {
     var preenE = function () { preenSourceType(e); };
     $(e).change(preenE);
-    var names = ['simple_url', 'g_host', 'g_user', 'g_project', 'g_branch'];
+    var names = ['simple_url', 'g_transport', 'g_host_port', 'g_repo', 'g_commit', 'g_path'];
     for (var i = 0; i < names.length; i++) {
       control(e, names[i]).change(preenE).keyup(preenE);
     }

static/index.js

@@ -0,0 +1,13 @@
+"use strict";
+
+$(document).ready(function () {
+  // "Cool URLs Don't Break" - catch uses of fragment-based links to
+  // specific packages, and effectively redirect to the new-style
+  // specific package URL.
+  //
+  var oldstyle_link = document.location.hash.match(/#\[(.*)\]$/);
+  if (oldstyle_link) {
+    var linked_package = oldstyle_link[1];
+    document.location = document.location.pathname + 'package/' + linked_package;
+  }
+});

static/searchbox.js

@@ -1,6 +1,5 @@
 $(document).ready(function () {
-  $("#q").focus();
+  PkgSite.staticJSON("search-completions", function (searchCompletions) {
-  PkgSite.getJSON("search-completions", function (searchCompletions) {
     searchCompletions.sort();
     PkgSite.multiTermComplete(PkgSite.preventTabMovingDuringSelection($("#q")), searchCompletions);
   });

static/site.js

@@ -25,14 +25,20 @@ PkgSite = (function () {
     });
   }
 
-  function getJSON(relative_url, k) {
+  function dynamicJSON(relative_url, k) {
     return $.getJSON(PkgSiteDynamicBaseUrl + '/json/' + relative_url, k);
   }
 
+  function staticJSON(relative_url, k) {
+    return $.getJSON((IsStaticPage ? PkgSiteStaticBaseUrl : PkgSiteDynamicBaseUrl)
+		     + '/json/' + relative_url, k);
+  }
+
   return {
     multiTermComplete: multiTermComplete,
     preventTabMovingDuringSelection: preventTabMovingDuringSelection,
-    getJSON: getJSON
+    dynamicJSON: dynamicJSON,
+    staticJSON: staticJSON
   };
 })();
 
@@ -40,12 +46,13 @@ $(document).ready(function () {
   $("table.sortable").tablesorter();
 
   if ($("#tags").length) {
-    PkgSite.getJSON((document.body.className === "package-form")
+    PkgSite.dynamicJSON((document.body.className === "package-form")
 			? "formal-tags"
 			: "tag-search-completions",
 			function (completions) {
 			  completions.sort();
-		      PkgSite.multiTermComplete(PkgSite.preventTabMovingDuringSelection($("#tags")),
+			  PkgSite.multiTermComplete(
+			    PkgSite.preventTabMovingDuringSelection($("#tags")),
 			    completions);
 			});
   }

static/style.css

@@ -11,7 +11,7 @@ body {
     -webkit-font-smoothing: antialiased;
 }
 
-.navbar { background: black; }
+.navbar { background: white; }
 
 /*---------------------------------------------------------------------------*/
 /* Make the navbar the same height as the main racket page's navbar */
@@ -20,6 +20,10 @@ body {
     line-height: 60px;
     height: 60px;
     padding-top: 0;
+    color: #444 !important; /* override bootstrap.css */
+}
+.navbar-nav > .active > a {
+    color: white !important; /* override bootstrap.css */
 }
 .navbar-btn {
     margin-top: 13px;
@@ -139,3 +143,8 @@ th.headerSortDown::after { content: " ▲"; }
 }
 .registration-step h1 { margin: 0.5em; }
 .registration-step p { font-size: 140%; }
+
+.ring-change-link {
+    display: inline-block;
+    padding: 0 0.15em;
+}

static/todos.js

@@ -0,0 +1,51 @@
+$(function() {
+  "use strict";
+
+  function applyFilter() {
+    $("table.packages > tbody > tr").each(function() {
+      var row = this;
+      if (Number.parseInt($(row).data("todokey"), 10) === 0) {
+        row.style.display = "none";
+      }
+    });
+    $("table.packages").trigger("sorton", [[[4, 1]]]);
+  }
+
+  function removeFilter() {
+    $("table.packages > tbody > tr").each(function() {
+      var row = this;
+      if (Number.parseInt($(row).data("todokey"), 10) === 0) {
+        row.style.display = "";
+      }
+    });
+    $("table.packages").trigger("sorton", [[[1, 0]]]);
+  }
+
+  var todoTotal = $("table.packages").data("todokey");
+
+  if (todoTotal > 0) {
+    $("#todo-msg").show();
+    $("#todo-msg").html(
+      todoTotal + " todos. " +
+      "<a style='cursor:pointer' id='filter-pkgs'> Click here to see them.</a>"
+    );
+
+    var filterIsApplied = false;
+
+    $("#filter-pkgs").click(function() {
+      var filterLink = $(this);
+      if (!filterIsApplied) {
+        applyFilter();
+        filterLink.text("Click to see all packages.");
+        filterIsApplied = true;
+      } else {
+        removeFilter();
+        filterLink.text("Click here to see them.");
+        filterIsApplied = false;
+      }
+    });
+  } else {
+    $("#todo-msg").hide();
+  }
+
+}); /* document.ready */