From 50721103d76aa8076ec512b05c2b8802a8ffc6cc Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 15 Jul 2016 20:04:17 -0400 Subject: [PATCH] Make it live --- configs/pkgd.rkt | 13 ++++++++++ run | 2 +- src/bootstrap.rkt | 6 ++++- src/jsonp-client.rkt | 38 +++++++++++++++++++---------- src/packages.rkt | 10 +++++--- src/site.rkt | 58 ++++++++++++++++++++++++++------------------ src/static.rkt | 17 ++++++++++--- 7 files changed, 99 insertions(+), 45 deletions(-) create mode 100644 configs/pkgd.rkt diff --git a/configs/pkgd.rkt b/configs/pkgd.rkt new file mode 100644 index 0000000..eb13aa6 --- /dev/null +++ b/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/" + )) diff --git a/run b/run index 7bd7b84..4014891 100755 --- a/run +++ b/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 diff --git a/src/bootstrap.rkt b/src/bootstrap.rkt index 2218928..fe5506b 100644 --- a/src/bootstrap.rkt +++ b/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) diff --git a/src/jsonp-client.rkt b/src/jsonp-client.rkt index cede244..c6333be 100644 --- a/src/jsonp-client.rkt +++ b/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" - baseurl - site-relative-url - (alist->form-urlencoded parameters)))) + (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) - (session-password s)))) + req-headers) '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) - (session-password s)))))) + req-headers))) (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: request ~a params ~a~a" + (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? @@ -79,10 +85,16 @@ " +creds" " +creds(missing)") ""))) - (define baseurl (or (jsonp-baseurl) (error 'simple-json-rpc! "jsonp-baseurl is not set"))) - (define request-url (string->url (format "~a~a" baseurl site-relative-url))) + (define baseurl + (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) diff --git a/src/packages.rkt b/src/packages.rkt index 624747b..3737a5e 100644 --- a/src/packages.rkt +++ b/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))) - (define response-bytes (port->bytes (get-pure-port (string->url package-index-url)))) + (with-handlers ([exn:fail? + (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) diff --git a/src/site.rkt b/src/site.rkt index 20b2836..fae0478 100644 --- a/src/site.rkt +++ b/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) - ;; " Download") - ;; "http://download.racket-lang.org/") + ("About Package Builds" "https://pkg-build.racket-lang.org/about.html") + ("Documentation" "https://docs.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 - #:include-credentials? #f - "/api/authenticate" - (hash 'email email - 'passwd password - 'code code))) + (jsonp-rpc! #:sensitive? #t + #:include-credentials? #f + "/jsonp/authenticate" + `((email . ,email) + (passwd . ,password) + (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") + "."))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/static.rkt b/src/static.rkt index bcfe7c9..56ea8e8 100644 --- a/src/static.rkt +++ b/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) - content-bytes - mime-type - headers))) + (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 (extension-map p)