Notes on the existing pkg-index, and thoughts on a revised design

src/build-server.rkt

@@ -0,0 +1,117 @@
+#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/package-catalog/NOTES.md

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

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

src/package-catalog/db.rkt

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

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

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

@@ -0,0 +1,269 @@
+#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/site.rkt

@@ -18,6 +18,7 @@
 (require "gravatar.rkt")
 (require "bootstrap.rkt")
 (require "html-utils.rkt")
+(require "build-server.rkt")
 (require "packages.rkt")
 (require "sessions.rkt")
 (require "jsonp-client.rkt")
@@ -59,10 +60,6 @@
   (or (@ (config) recent-seconds)
       (* 2 24 60 60))) ;; two days
 
-(define pkg-build-baseurl
-  (or (@ (config) pkg-build-baseurl)
-      "http://pkg-build.racket-lang.org/"))
-
 (struct draft-package (old-name name description authors tags versions) #:prefab)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;