suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make it live

Browse Source
This commit is contained in:
Jay McCarthy 2016-07-15 20:04:17 -04:00
parent 594b1b25dc
commit 50721103d7
7 changed files with 99 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
configs/pkgd.rkt Normal file
View File

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

2
run
View File

@ -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

6
src/bootstrap.rkt
View File

@ -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)

38
src/jsonp-client.rkt
View File

@ -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)

10
src/packages.rkt
View File

@ -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)

58
src/site.rkt
View File

@ -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")
".")))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

17
src/static.rkt
View File

@ -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)