Make it live

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/"
+            ))

run

@@ -16,4 +16,4 @@ PLTSTDERR=info
 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
@@ -27,6 +28,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))
@@ -40,6 +42,8 @@
 
 (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
@@ -112,7 +116,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/jsonp-client.rkt

@@ -44,20 +44,26 @@
   (define extraction-expr (format "^callback~a\\((.*)\\);$" stamp))
   (define parameters (cons (cons 'callback callback-label) original-parameters))
   (define baseurl (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set")))
-  (define request-url (string->url (format "~a~a?~a"
+  (define request-url
+    (string->url
+     (format "~a~a?~a"
              baseurl
              site-relative-url
              (alist->form-urlencoded parameters))))
+  (define req-headers
+    (if include-credentials?
+        (list
+         (make-basic-auth-credentials-header (session-email s)
+                                             (session-password s)))
+        null))
   (define-values (body-port response-headers)
     (if post-data
         (values (post-pure-port request-url
                                 post-data
-                                (list (make-basic-auth-credentials-header (session-email s)
+                                req-headers)
-                                                                          (session-password s))))
                 'unknown-response-headers-because-post-pure-port-doesnt-return-them)
         (get-pure-port/headers request-url
-                               (list (make-basic-auth-credentials-header (session-email s)
+                               req-headers)))
-                                                                         (session-password s))))))
   (define raw-response (port->string body-port))
   (match-define (pregexp extraction-expr (list _ json)) raw-response)
   (define reply (string->jsexpr json))
@@ -70,8 +76,8 @@
                           jsexpr-to-send)
   (define s (current-session))
   (if sensitive?
-      (log-info "simple-json-rpc: sensitive request ~a" site-relative-url)
+      (log-info "simple-json-rpc: sensitive request ~v" site-relative-url)
-      (log-info "simple-json-rpc: request ~a params ~a~a"
+      (log-info "simple-json-rpc: request ~v params ~v~a"
                 site-relative-url
                 jsexpr-to-send
                 (if include-credentials?
@@ -79,10 +85,16 @@
                         " +creds"
                         " +creds(missing)")
                     "")))
-  (define baseurl (or (jsonp-baseurl) (error 'simple-json-rpc! "jsonp-baseurl is not set")))
+  (define baseurl
-  (define request-url (string->url (format "~a~a" baseurl site-relative-url)))
+    (or (jsonp-baseurl) (error 'simple-json-rpc! "jsonp-baseurl is not set")))
+  (define request-urls (format "~a~a" baseurl site-relative-url))
+  (unless sensitive? (log-info "simple-json-rpc: urls: ~v" request-urls))
+  (define request-url (string->url request-urls))
+  (unless sensitive? (log-info "simple-json-rpc: url: ~v" request-url))
   (define post-data (string->bytes/utf-8 (jsexpr->string jsexpr-to-send)))
+  (unless sensitive? (log-info "simple-json-rpc: post-data: ~v" post-data))
   (define raw-response (port->string (post-pure-port request-url post-data)))
+  (unless sensitive? (log-info "simple-json-rpc: raw ~v" raw-response))
   (define reply (string->jsexpr raw-response))
-  (unless sensitive? (log-info "simple-json-rpc: reply ~a" reply))
+  (unless sensitive? (log-info "simple-json-rpc: reply ~v" reply))
   reply)

src/packages.rkt

@@ -53,14 +53,18 @@
 (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-bytes
+        (port->bytes (get-pure-port (string->url package-index-url))))
       (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)

src/site.rkt

@@ -37,6 +37,10 @@
   (or (@ (config) dynamic-urlprefix)
       ""))
 
+(define dynamic-static-urlprefix
+  (or (@ (config) dynamic-static-urlprefix)
+      ""))
+
 (define disable-cache?
   (or (@ (config) disable-cache?)
       #f))
@@ -89,7 +93,8 @@
    ))
 
 (define (on-continuation-expiry request)
-  (bootstrap-continuation-expiry-handler request))
+  (with-site-config
+    (bootstrap-continuation-expiry-handler request)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -111,7 +116,7 @@
 (define (static-resource-url suffix)
   (if (rendering-static-page?)
       (string-append static-urlprefix suffix)
-      suffix))
+      (string-append dynamic-static-urlprefix suffix)))
 
 (define-syntax-rule (authentication-wrap #:request request body ...)
   (authentication-wrap* #f request (lambda () body ...)))
@@ -123,11 +128,18 @@
   (parameterize ((bootstrap-navbar-header (navbar-header))
                  (bootstrap-navigation `((,nav-index ,(main-page-url))
                                          (,nav-search ,(named-url search-page))
-                                         ;; ((div ,(glyphicon 'download-alt)
+                                         ("About Package Builds" "https://pkg-build.racket-lang.org/about.html")
-                                         ;;       " Download")
+                                         ("Documentation" "https://docs.racket-lang.org/")
-                                         ;;  "http://download.racket-lang.org/")
+                                         ((div ,(glyphicon 'download-alt)
+                                               " Download Racket")
+                                          "http://download.racket-lang.org/")
                                          ))
-                 (bootstrap-static-urlprefix (if (rendering-static-page?) static-urlprefix ""))
+                 (bootstrap-static-urlprefix
+                  (if (rendering-static-page?)
+                      static-urlprefix
+                      dynamic-static-urlprefix))
+                 (bootstrap-dynamic-urlprefix
+                  dynamic-urlprefix)
                  (bootstrap-inline-js
                   (string-append (format "PkgSiteDynamicBaseUrl = '~a';" dynamic-urlprefix)
                                  (format "PkgSiteStaticBaseUrl = '~a';" static-urlprefix)
@@ -325,12 +337,12 @@
                             ,(form-group 4 5 (primary-button "Log in"))))))))
 
 (define (authenticate-with-server! email password code)
-  (simple-json-rpc! #:sensitive? #t
+  (jsonp-rpc! #:sensitive? #t
               #:include-credentials? #f
-                    "/api/authenticate"
+              "/jsonp/authenticate"
-                    (hash 'email email
+              `((email . ,email)
-                          'passwd password
+                (passwd . ,password)
-                          'code code)))
+                (code . ,code))))
 
 (define (authentication-success->curator? success)
   (match success
@@ -343,7 +355,7 @@
           (equal? (string-trim password) ""))
       (login-form "Please enter your email address and password.")
       (match (authenticate-with-server! email password "")
-        ["wrong-code"
+        [(or "wrong-code" (? eof-object?))
          (login-form "Something went awry; please try again.")]
         [(or "emailed" #f)
          (summarise-code-emailing "Incorrect password, or nonexistent user." email)]
@@ -418,6 +430,8 @@
     (retry "Please enter a password.")]
    [else
     (match (authenticate-with-server! email password code)
+      [(? eof-object?)
+       (retry "Something went awry. Please try again.")]
       ["wrong-code"
        (retry "The code you entered was incorrect. Please try again.")]
       [(or "emailed" #f)
@@ -631,18 +645,10 @@
            #:title-element ""
            #:body-class "main-page"
            `(div ((class "jumbotron"))
-                 (h1 "BETA Racket Package Server")
+                 (h1 "Racket Packages")
                  (p "These are the packages in the official "
                     (a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
                        "package catalog") ".")
-                 (p "This is a temporary database instance! While the information "
-                    "in the database is copied from the main Racket catalog, changes "
-                    "will NOT be propagated back to the main Racket catalog.")
-                 (p "Questions? Comments? Bugs? Email "
-                    (a ((href "mailto:tonyg@ccs.neu.edu")) "tonyg@ccs.neu.edu")
-                    " or twitter "
-                    (a ((href "https://twitter.com/leastfixedpoint")) "@leastfixedpoint")
-                    ".")
                  (p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
                        (kbd "raco pkg install " (var "package-name")))
                     " installs a package.")
@@ -660,7 +666,13 @@
            `(div
              (p ((class "package-count"))
                 ,(format "~a packages" (length package-name-list)))
-             ,(package-summary-table package-name-list)))))))
+             ,(package-summary-table package-name-list))
+           `(div ((class "jumbotron"))
+                 (p "Questions? Comments? Bugs? Email "
+                    (a ((href "mailto:tonyg@ccs.neu.edu")) "tonyg@ccs.neu.edu")
+                    " or "
+                    (a ((href "mailto:jay.mccarthy@gmail.com")) "jay.mccarthy@gmail.com")
+                    ".")))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

src/static.rkt

@@ -168,6 +168,14 @@
   (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
+   (λ ()
+     (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))
@@ -177,10 +185,11 @@
         (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)
+        (put/bytes^ (string-append aws-s3-bucket+path relative-path)
                     content-bytes
                     mime-type
-                   headers)))
+                    (cons (cons 'x-amz-acl "public-read")
+                          headers))))
   (hash-set index relative-path new-md5))
 
 (define (extension-map p)