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

Compare commits

base: suzanne.soy:docs-from-metapackage
Branches Tags
suzanne.soy:master
suzanne.soy:docs-from-metapackage
suzanne.soy:missing-dep-readme
suzanne.soy:catalog
..
compare: suzanne.soy:master
Branches Tags
suzanne.soy:docs-from-metapackage
suzanne.soy:missing-dep-readme
suzanne.soy:master
suzanne.soy:catalog

No commits in common. "docs-from-metapackage" and "master" have entirely different histories.
docs-from- ... master

25 changed files with 342 additions and 793 deletions
Show Stats Expand all files Collapse all files

9
README.md
View File

@ -4,9 +4,7 @@
You will need to install the following Racket packages:
raco pkg install --skip-installed \
https://github.com/racket/infrastructure-userdb.git#main \
reloadable
raco pkg install reloadable
## Configuration
@ -52,11 +50,6 @@ Keys useful for deployment:
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.
- *user-directory*: directory containing the user database; should be
the same as `pkg-index` uses.
- *email-sender-address*: string; defaults to `pkgs@racket-lang.org`.
Used as the "from" address when sending authentication emails on
behalf of the server.
Keys useful for development:

2
configs/live.rkt
View File

@ -9,8 +9,6 @@
(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")
'user-directory (build-path var "pkg-index/users.new")
'email-sender-address "The Racket Package Server <pkgs@racket-lang.org>"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To configure a split, S3-based setup, comment out the following lines:
;;

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

17
configs/tonyg.rkt
View File

@ -1,17 +1,9 @@
#lang racket/base
;; Configuration for tonyg's development setup.
(require "../src/main.rkt")
(define pkg-index-generated-directory
(build-path (find-system-path 'home-dir) "src/pkg-index/official/static-gen"))
(main (hash 'port 8444
'ssl? #f
'reloadable? #t
'package-index-url (format "file://~a/pkgs-all.json.gz" pkg-index-generated-directory)
'user-directory (build-path (find-system-path 'home-dir)
"src/pkg-index/official/root/users.new")
'email-sender-address "tonyg@racket-lang.org"
'package-index-url "file:///home/tonyg/public_html/pkg-index-static/pkgs-all.json.gz"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Either:
;;
@ -30,7 +22,8 @@
;; 'dynamic-static-urlprefix "https://localhost:8446"
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
'dynamic-urlprefix "http://localhost:8444"
'backend-baseurl "http://localhost:8445"
'pkg-index-generated-directory pkg-index-generated-directory
'dynamic-urlprefix "https://localhost:8444"
'backend-baseurl "https://localhost:8445"
'pkg-index-generated-directory (build-path (find-system-path 'home-dir)
"public_html/pkg-index-static")
))

30
configs/tonyg/nginx.locals3proxy.conf Normal file
View File

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

2
configs/tonyg/run-s3-proxy.sh Executable file
View File

@ -0,0 +1,2 @@
#!/bin/sh
exec nginx -p . -c nginx.locals3proxy.conf

39
on-ping-service-failure.sh
View File

@ -1,39 +0,0 @@
#!/bin/bash
#
# I am potentially invoked when ping-service.sh (which see) fails to
# contact the racket-pkg-website service.
#
# Request a dump of running threads:
dumprequestfile=$HOME/racket-pkg-website/signals/.dumpinfo
touch $dumprequestfile
# Wait a few seconds for the dump to complete:
sleep 10
# Tar up the most recent few hours' worth of logs:
logarchive=$HOME/ping-failure-logs-$(date +%Y%m%d%H%M%S).tar.gz
(
cd $HOME/service/racket-pkg-website/log/main/; \
ls -tr | tail -n 10 | xargs tar -zcf $logarchive \
)
# Restart the service using daemontools.
if [ -f $dumprequestfile ]
then
# If the `.dumpinfo` signal is still there after our sleep, then
# the process is so far off the rails we shouldn't bother waiting
# for it, so kill it hard.
echo "Killing service hard and restarting it."
svc -dku $HOME/service/racket-pkg-website
else
# Otherwise, it's at least partially awake, so try asking it
# nicely.
echo "Politely requesting service termination before restart."
svc -du $HOME/service/racket-pkg-website
fi
# Finally, complain out loud. We expect to be running in some kind of
# cron-ish context, so the output we produce here will likely find its
# way into an email to a responsible party.
echo "racket-pkg-website on-ping-service-failure.sh invoked. logarchive=$logarchive"

32
ping-service.sh
View File

@ -1,32 +0,0 @@
#!/bin/bash
#
# I am a script, intended to run from `cron`, which pings a
# configurable URL, and if no suitable response is forthcoming,
# performs a configurable command.
#
# For example, to monitor racket-pkg-website, try
#
# ./ping-service.sh https://localhost:8444/ping $HOME/racket-pkg-website/on-ping-service-failure.sh
if [ "$#" != "2" ]
then
echo 'Usage: ping-service.sh <url> <command>'
echo 'Note that <command> has to be a single string.'
exit 1
fi
url="$1"
failurecommand="$2"
# curl flags:
# -f == fail, interrogate the HTTP response status code
# -s == silent, don't print a progress meter or any other cruft
# -k == Ignore certificates, where url is an HTTPS URL
#
if curl -f -s -k --max-time 10 "$url" > /dev/null
then
# Do nothing -- the retrieval was successful
true
else
exec sh -c "$failurecommand"
fi

17
run
View File

@ -12,22 +12,7 @@ if [ ! -f configs/${CONFIG}.rkt ]; then
exit 1
fi
PLTSTDERR="
info
warning@GC
warning@cm
warning@compiler/cm
warning@module-prefetch
warning@setup/parallel-build
warning@cm-accomplice
warning@online-check-syntax
error@racket/contract
error@collapsible-cache-fail
error@collapsible-contract-arrow-wrapper-arity
error@collapsible-contract-bailout
error@collapsible-merging
error@collapsible-value-bailout
"
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

5
src/bootstrap.rkt
View File

@ -53,7 +53,6 @@
#:code [code 200]
#:message [message #"Okay"]
#:body-class [body-class #f]
#:description [description #f]
.
body-contents)
(response/xexpr
@ -66,10 +65,6 @@
(meta ((http-equiv "X-UA-Compatible") (content "IE=edge")))
(meta ((name "viewport") (content "width=device-width, initial-scale=1")))
(title ,title)
,@(if (non-empty-string? description)
`((meta ((name "description")
(content ,description))))
'())
(link ((rel "stylesheet") (href ,(static "/bootstrap/css/bootstrap.min.css")) (type "text/css")))
(link ((rel "stylesheet") (href ,(static "/jquery-ui.min.css")) (type "text/css")))
(link ((rel "stylesheet") (href ,(static "/style.css")) (type "text/css")))

48
src/challenge.rkt
View File

@ -1,48 +0,0 @@
#lang racket/base
(provide (struct-out challenge)
generate-challenge
challenge-passed?)
(require racket/pretty)
(struct challenge (expr question answer) #:transparent)
(define (random-element lst)
(list-ref lst (random (length lst))))
(define (generate-expr)
(if (>= (random) 0.5)
`(,(random-element '(car cadr caddr))
(map (lambda (v) (+ ,(random 4) (* v ,(random 4))))
(list ,(random 4) ,(random 4) ,(random 4))))
(let ()
(define (random-op) (random-element '(+ * -)))
(define (e fuel)
(if (zero? fuel)
(random 10)
(cons (random-op)
(for/list [(i (in-range (+ 1 (random 2))))]
(e (- fuel 1))))))
(e 2))))
(define (generate-challenge)
(define expr (generate-expr))
(challenge expr
`(div
(p (b "What is the result of evaluating:"))
(pre (code ,(pretty-format expr 40 #:mode 'write))))
(eval expr (make-base-namespace))))
(define (safe-string->value str)
(parameterize (;; Hmm, this is a big list. Did I miss any important ones?
(read-accept-box #f)
(read-accept-compiled #f)
(read-accept-graph #f)
(read-accept-reader #f)
(read-accept-lang #f))
(read (open-input-string str))))
(define (challenge-passed? challenge response-str)
(define response (safe-string->value response-str))
(equal? response (challenge-answer challenge)))

28
src/daemon.rkt
View File

@ -6,21 +6,19 @@
(require (only-in racket/exn exn->string))
(define (daemonize-thunk name boot-thunk)
(procedure-rename
(lambda ()
(let reboot ()
;; We would catch exn:fail? here, but exn:pretty in the web
;; server is a subtype of exn, not of exn:fail, and that causes
;; spurious permanent daemon exits.
(with-handlers* ((exn? (lambda (e)
(log-error "*** DAEMON CRASHED: ~a ***\n~a"
name
(exn->string e))
(sleep 5)
(reboot))))
(define result (boot-thunk))
(log-warning "Daemon thread ~a exited normally (returning ~v)" name result))))
(string->symbol (format "~v" name))))
(lambda ()
(let reboot ()
;; We would catch exn:fail? here, but exn:pretty in the web
;; server is a subtype of exn, not of exn:fail, and that causes
;; spurious permanent daemon exits.
(with-handlers* ((exn? (lambda (e)
(log-error "*** DAEMON CRASHED: ~a ***\n~a"
name
(exn->string e))
(sleep 5)
(reboot))))
(define result (boot-thunk))
(log-warning "Daemon thread ~a exited normally (returning ~v)" name result)))))
(define (daemon-thread name boot-thunk)
(thread (daemonize-thunk name boot-thunk)))

36
src/debug.rkt
View File

@ -1,36 +0,0 @@
#lang racket/base
;; Code for debugging a live server.
(provide debug-information-dump!)
(require "main.rkt")
(require racket/exn)
(require racket/tcp)
(require (only-in racket/string string-join))
(define (format-path path)
(string-join (map number->string (reverse path)) "."))
(define (enumerate-custodian-managed-items cust super path)
(for [(index (in-naturals))
(item (custodian-managed-list cust super))]
(eprintf "\nItem ~a.\n~v\n" (format-path (cons index path)) item)
(cond
[(thread? item)
(eprintf "~a" (exn->string (exn "Stack snapshot:" (continuation-marks item))))]
[(tcp-port? item)
(eprintf "TCP port: (addresses ~v)\n"
(call-with-values (lambda () (tcp-addresses item #t)) list))]
[(custodian? item)
(enumerate-custodian-managed-items item cust (cons index path))]
[else (void)])))
(define (debug-information-dump!)
(eprintf "===========================================================================\n")
(eprintf "======================================================================\n")
(eprintf "=================================================================")
(collect-garbage)
(enumerate-custodian-managed-items (current-custodian) (outermost-custodian) '())
(eprintf "=================================================================\n")
(eprintf "======================================================================\n")
(eprintf "===========================================================================\n"))

45
src/html-utils.rkt
View File

@ -1,13 +1,10 @@
#lang racket/base
;; A utilities module :-/
(provide maybe-splice
define-form-bindings/xform
define-form-bindings
define-form-bindings/trim)
(require web-server/servlet)
(require (only-in racket/string string-trim))
(provide maybe-splice
define-form-bindings)
;; Boolean XExpr ... -> (Listof XExpr)
;; Useful for optionally splicing in some contents to a list.
@ -15,28 +12,22 @@
(define-syntax-rule (maybe-splice guard contents ...)
(if guard (list contents ...) '()))
(define-syntax define-form-bindings*
(syntax-rules ()
[(_ bs xform ())
(begin)]
[(_ bs xform ([name fieldname defaultval] rest ...))
(begin (define name (if (exists-binding? 'fieldname bs)
(xform (extract-binding/single 'fieldname bs))
defaultval))
(define-form-bindings* bs xform (rest ...)))]
[(_ bs xform ([name defaultval] rest ...))
(define-form-bindings* bs xform ([name name defaultval] rest ...))]
[(_ bs xform (name rest ...))
(define-form-bindings* bs xform ([name #f] rest ...))]))
;; Extracts named single-valued bindings from the given request.
;; If a given binding is missing, the extracted value will be #f.
(define-syntax-rule (define-form-bindings/xform req xform (specs ...))
(begin (define bs (request-bindings req))
(define-form-bindings* bs xform (specs ...))))
(define-syntax-rule (define-form-bindings req (specs ...))
(define-form-bindings/xform req values (specs ...)))
(begin (define bs (request-bindings req))
(define-form-bindings* bs (specs ...))))
(define-syntax-rule (define-form-bindings/trim req (specs ...))
(define-form-bindings/xform req string-trim (specs ...)))
(define-syntax define-form-bindings*
(syntax-rules ()
[(_ bs ())
(begin)]
[(_ bs ([name fieldname defaultval] rest ...))
(begin (define name (if (exists-binding? 'fieldname bs)
(extract-binding/single 'fieldname bs)
defaultval))
(define-form-bindings* bs (rest ...)))]
[(_ bs ([name defaultval] rest ...))
(define-form-bindings* bs ([name name defaultval] rest ...))]
[(_ bs (name rest ...))
(define-form-bindings* bs ([name #f] rest ...))]))

106
src/http-utils.rkt
View File

@ -6,7 +6,7 @@
http-interpret-response
http-simple-interpret-response
http-follow-redirects
custom-http-sendrecv/url
http-sendrecv/url
http/interpret-response
http/simple-interpret-response
@ -17,7 +17,7 @@
(require racket/match)
(require net/http-client)
(require net/head)
(require net/url)
(require (except-in net/url http-sendrecv/url))
;; (Parameterof Number)
;; Number of redirections to automatically follow when retrieving via GET or HEAD.
@ -64,9 +64,9 @@
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)))
(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
@ -79,39 +79,64 @@
headers
body))
(define ((check-response method remaining-redirect-count)
(define ((http-follow-redirects method
#:version [version #"1.1"])
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 () (custom-http-sendrecv/url location
#:method method))
(check-response method (- remaining-redirect-count 1)))])
(values status-line response-headers response-body-port)))
(define ((http-follow-redirects method)
status-line
response-headers
response-body-port)
((check-response method (http-redirection-limit))
(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))
(define (custom-http-sendrecv/url u #:method method)
(http-sendrecv/url u #:method method))
;; 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)
@ -126,15 +151,10 @@
(http-follow-redirects customization ...)))
(module+ test
(define parent-cust (current-custodian))
(define this-cust (make-custodian))
(parameterize ([current-custodian this-cust])
(for ([i (in-range 100)])
(http/simple-interpret-response
(http/follow-redirects
#"HEAD"
(custom-http-sendrecv/url (string->url "http://google.com/")
#:method #"HEAD")))))
(require racket/pretty)
(pretty-print
(custodian-managed-list this-cust parent-cust)))
(require rackunit)
(http/simple-interpret-response
(http/follow-redirects
#"HEAD"
(http-sendrecv/url (string->url "http://google.com/") #:method #"HEAD")))
)

21
src/main-inner.rkt
View File

@ -1,21 +0,0 @@
#lang racket/base
;; Inner startup module - required after establishment of server-wide custodian.
(provide main)
(require reloadable)
(require "entrypoint.rkt")
(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! "site.rkt"))
(void (make-reloadable-entry-point 'debug-information-dump! "debug.rkt"))
(start-service #:port (hash-ref config 'port (lambda ()
(let ((port-str (getenv "SITE_PORT")))
(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")
(make-reloadable-entry-point 'on-continuation-expiry "site.rkt")
(make-reloadable-entry-point 'extra-files-paths "static.rkt")))

21
src/main.rkt
View File

@ -1,12 +1,19 @@
#lang racket/base
;; Outer startup module - delegates to main-inner.rkt after installing a custodian
(provide main
outermost-custodian)
(provide main)
(define *outermost-custodian* (current-custodian))
(define (outermost-custodian) *outermost-custodian*)
(require reloadable)
(require "entrypoint.rkt")
(define (main [config (hash)])
(parameterize ((current-custodian (make-custodian (outermost-custodian))))
((dynamic-require "main-inner.rkt" 'main) config)))
(make-persistent-state '*config* (lambda () config))
(void (make-reloadable-entry-point 'refresh-packages! "packages.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) 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")
(make-reloadable-entry-point 'on-continuation-expiry "site.rkt")
(make-reloadable-entry-point 'extra-files-paths "static.rkt")))

59
src/packages.rkt
View File

@ -34,7 +34,7 @@
(define package-index-url
(or (@ (config) package-index-url)
"https://pkgs.racket-lang.org/pkgs-all.json.gz"))
"http://pkgs.racket-lang.org/pkgs-all.json.gz"))
(define package-fetch-interval
(* (or (@ (config) package-fetch-interval)
@ -73,12 +73,9 @@
(eq? pkg 'tombstone))
(define (asynchronously-fetch-remote-packages state)
(thread
(procedure-rename
(lambda ()
(define raw-remote-packages (fetch-remote-packages))
(manager-rpc 'refresh-packages! raw-remote-packages))
(string->symbol (format "~v" (list 'asynchronously-fetch-remote-packages (current-inexact-milliseconds))))))
(thread (lambda ()
(define raw-remote-packages (fetch-remote-packages))
(manager-rpc 'refresh-packages! raw-remote-packages)))
(struct-copy package-manager-state state
[next-fetch-deadline (+ (current-inexact-milliseconds) package-fetch-interval)]))
@ -290,55 +287,19 @@
;; to do this at package save time, but this will do for now.
(pkg->searchable-text pkg)))))
;; sort-package-names/priority :: (listof string?) (listof (cons/c symbol? package?)) -> (listof symbol?)
;; Rank packages by favoring those whose name prefixes or contains search strings
;; and whose description contains search strings
(define (sort-package-names/priority text-list packages)
;; A key is a pair of a priority and a package name
;; where higher priority means it's more relevant to the search text
;; Note that the tombstone packages are filtered already,
;; so it's safe to use (@ pkg ...)
(define (package-pair->key package-pair)
(define pkg (cdr package-pair))
(define pkg-name (@ pkg name))
(define pkg-desc (@ pkg description))
(define priority
(for/sum ([text (in-list text-list)])
(cond
;; NOTE: no need to check for string=? (the exact match)
;; because it will also be a prefix, and will be
;; weighted more due to its lexicographic order.
[(string-prefix? pkg-name text) 100]
[(string-contains? pkg-name text) 10]
[(and pkg-desc (string-contains? pkg-desc text)) 1]
[else 0])))
(cons priority pkg-name))
(define (key< a b)
(cond
[(= (car a) (car b)) (string-ci<? (cdr a) (cdr b))]
[else (> (car a) (car b))]))
(define sorted (sort packages key< #:key package-pair->key #:cache-keys? #t))
(map car sorted))
(define (package-search text tags)
(define text-list (remove-duplicates (string-split text)))
(define res (map (lambda (r) (regexp (regexp-quote r #f))) text-list))
(define res (map (lambda (r) (regexp (regexp-quote r #f))) (string-split text)))
(define packages (manager-rpc 'packages))
(sort-package-names/priority
text-list
(filter (lambda (package-pair)
(define pkg (cdr package-pair))
(sort-package-names
(filter (lambda (package-name)
(define pkg (hash-ref packages package-name))
(andmap (package-text-matches? pkg) res))
(hash->list
(hash-keys
(for/fold ((ps packages)) ((tag-spec tags))
(match-define (list tag-name include?) tag-spec)
(for/hash (((package-name pkg) (in-hash ps))
#:when (and (not (tombstone? pkg))
((if include? values not)
(@ref (@ pkg search-terms) tag-name))))
((if include? values not) (@ref (@ pkg search-terms) tag-name))))
(values package-name pkg)))))))
(define (packages-jsexpr)

5
src/signals.rkt
View File

@ -51,10 +51,5 @@
(if (eof-object? items-to-rerender)
#f
items-to-rerender))))
(poll-signal "../signals/.dumpinfo"
"Debug information dump request received"
(lambda ()
((reloadable-entry-point->procedure
(lookup-reloadable-entry-point 'debug-information-dump! "debug.rkt")))))
(sleep 0.5)
(loop)))))

473
src/site.rkt
View File

@ -10,13 +10,13 @@
(require racket/match)
(require racket/format)
(require racket/date)
(require (only-in racket/string string-join string-split))
(require racket/string)
(require racket/port)
(require (only-in racket/list filter-map drop-right))
(require (only-in racket/exn exn->string))
(require net/url)
(require (except-in net/url http-sendrecv/url))
(require net/uri-codec)
(require web-server/servlet)
(require (except-in web-server/servlet http-sendrecv/url))
(require json)
(require "gravatar.rkt")
(require "bootstrap.rkt")
@ -31,8 +31,6 @@
(require "static.rkt")
(require "package-source.rkt")
(require "http-utils.rkt")
(require "challenge.rkt")
(require "users.rkt")
(define static-urlprefix
(or (@ (config) static-urlprefix)
@ -54,7 +52,7 @@
(define nav-search "Search")
(define (navbar-header)
`(a ((href "https://www.racket-lang.org/"))
`(a ((href "http://www.racket-lang.org/"))
(img ((src ,(static-resource-url "/logo-and-text.png"))
(height "60")
(alt "Racket Package Index")))))
@ -64,7 +62,7 @@
"https://pkgd.racket-lang.org"))
(define default-empty-parsed-package-source
(git-source "https://github.com/" #f 'git 'git "github.com" #f "" "" ""))
(git-source "git://github.com/" #f 'git 'git "github.com" #f "" "" ""))
(define COOKIE "pltsession")
@ -74,7 +72,7 @@
(define pkg-build-baseurl
(or (@ (config) pkg-build-baseurl)
"https://pkg-build.racket-lang.org/"))
"http://pkg-build.racket-lang.org/"))
(struct draft-package (old-name name description authors tags versions) #:prefab)
@ -97,8 +95,6 @@
[("json" "tag-search-completions") json-tag-search-completions]
[("json" "formal-tags") json-formal-tags]
[("pkgs-all.json") pkgs-all-json]
[("ping") ping-page]
[("bulk-operation") #:method "post" bulk-operation-page]
))
(define (on-continuation-expiry request)
@ -146,11 +142,11 @@
(,nav-search ,(named-url search-page))
("About"
(("The Racket Package System"
"https://docs.racket-lang.org/pkg/getting-started.html")
"http://docs.racket-lang.org/pkg/getting-started.html")
("Package Builds" "https://pkg-build.racket-lang.org/about.html")))
((div ,(glyphicon 'download-alt)
" Download Racket")
"https://download.racket-lang.org/")
"http://download.racket-lang.org/")
))
(bootstrap-static-urlprefix
(if (rendering-static-page?)
@ -247,23 +243,17 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ((generic-input type #:extra-classes [extra-classes1 '()])
name
[initial-value ""]
#:id [id name]
#:extra-classes [extra-classes2 '()]
#:placeholder [placeholder #f])
`(input ((class ,(string-join (cons "form-control" (append extra-classes1 extra-classes2)) " "))
(define ((generic-input type) name [initial-value ""] #:placeholder [placeholder #f])
`(input ((class "form-control")
(type ,type)
(name ,name)
,@(maybe-splice id `(id ,id))
(id ,name)
,@(maybe-splice placeholder `(placeholder ,placeholder))
(value ,initial-value))))
(define email-input (generic-input "email"))
(define password-input (generic-input "password"))
(define text-input (generic-input "text"))
(define checkbox-input (generic-input "checkbox"))
(define (label for . content)
`(label ((class "control-label") ,@(maybe-splice for `(for ,for)))
@ -344,7 +334,7 @@
(role "form"))
,(form-group 2 2 (label "email" "Email address")
0 5 (email-input "email"))
,(form-group 2 2 (label "password" "Password")
,(form-group 2 2 (label "password" "Password:")
0 5 (password-input "password"))
,(form-group 4 5
`(a ((href ,(embed-url (lambda (req) (register-form)))))
@ -359,39 +349,45 @@
(p ,error-message))))
,(form-group 4 5 (primary-button "Log in"))))))))
(define (create-session-after-authentication-success! email password)
(define user-facts
(simple-json-rpc! #:sensitive? #t
#:include-credentials? #f
backend-baseurl
"/api/authenticate"
(hash 'email email
'passwd password)))
(when (not (hash? user-facts)) ;; Uh-oh. Something went wrong
(error 'create-session-after-authentication-success! "Cannot retrieve user-facts for ~v" email))
(define (authenticate-with-server! email password code)
(simple-json-rpc! #:sensitive? #t
#:include-credentials? #f
backend-baseurl
"/api/authenticate"
(hash 'email email
'passwd password
'code code)))
(define (create-session-from-authentication-success! email password success)
;; An "authentication success" is either #t, signalling a new user,
;; or a hash-table with interesting facts in it.
(define user-facts (cond [(eq? success #t) (hasheq)]
[(hash? success) success]
[else (log-warning "Bad auth success for user ~v: ~v" email success)
(hasheq)]))
(create-session! email password
#:curator? (if (hash-ref user-facts 'curation #f) #t #f)
#:superuser? (if (hash-ref user-facts 'superuser #f) #t #f)))
(define (process-login-credentials request)
(define-form-bindings/trim request (email password))
(cond [(or (equal? email "") (equal? password ""))
(login-form "Please enter your email address and password.")]
[(not (login-password-correct? email password))
(login-form "Incorrect password, or nonexistent user.")]
[else
(create-session-after-authentication-success! email password)]))
(define-form-bindings request (email password))
(if (or (equal? (string-trim email) "")
(equal? (string-trim password) ""))
(login-form "Please enter your email address and password.")
(match (authenticate-with-server! email password "")
[(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)]
[success
(create-session-from-authentication-success! email password success)])))
(define (register-form #:email [email ""]
#:email_for_code [email_for_code ""]
#:code [code ""]
#:step1a-error-message [step1a-error-message #f]
#:step1b-error-message [step1b-error-message #f]
#:step2-error-message [step2-error-message #f])
#:error-message [error-message #f])
(with-site-config
(send/suspend/dispatch/dynamic
(lambda (embed-url)
(define challenge (generate-challenge))
(bootstrap-response "Register/Reset Account"
#:title-element ""
`(div ((class "registration-step-container"))
@ -408,32 +404,10 @@
(p "Enter your email address below, and we'll send you one.")
(form ((class "form-horizontal")
(method "post")
(action ,(embed-url (check-challenge challenge)))
(action ,(embed-url notify-of-emailing))
(role "form"))
,(form-group 1 3 (label "email" "Email address")
0 5 (email-input "email_for_code" email_for_code))
,@(maybe-splice
step1a-error-message
(form-group 4 5
`(div ((class "alert alert-danger"))
(p ,step1a-error-message))))
,(form-group 1 3 (label "antispam" "Anti-spam")
0 5 `(div ((class "form-control-static"))
(p "Please help us defend our "
"infrastructure from spammers "
"by answering the following question.")
,@(maybe-splice
step1b-error-message
`(div ((class "alert alert-danger"))
(p ,step1b-error-message)))
,(challenge-question challenge)
,(form-group
0 2 `(p ((class "form-control-static"))
(b "Answer:"))
0 10 (text-input "question_answer"))
,(text-input "body"
#:extra-classes
'("not-shown-to-humans"))))
0 5 (email-input "email_for_code"))
,(form-group 4 5 (primary-button "Email me a code"))))
`(div
@ -452,76 +426,57 @@
,(form-group 1 3 (label "password" "Confirm password")
0 5 (password-input "confirm_password"))
,@(maybe-splice
step2-error-message
error-message
(form-group 4 5
`(div ((class "alert alert-danger"))
(p ,step2-error-message))))
(p ,error-message))))
,(form-group 4 5 (primary-button "Continue")))))))))
(define (apply-account-code request)
(define-form-bindings/trim request (email code password confirm_password))
(define-form-bindings request (email code password confirm_password))
(define (retry msg)
(register-form #:email email
#:code code
#:step2-error-message msg))
#:error-message msg))
(cond
[(equal? email "")
(retry "Please enter your email address.")]
[(equal? code "")
(retry "Please enter the code you received in your email.")]
[(not (equal? password confirm_password))
(retry "Please make sure the two password fields match.")]
[(equal? password "")
(retry "Please enter a password.")]
[(not (registration-code-correct? email code))
(retry "The code you entered was incorrect. Please try again.")]
[else
(register-or-update-user! email password)
(create-session-after-authentication-success! email password)]))
[(equal? (string-trim email) "")
(retry "Please enter your email address.")]
[(equal? (string-trim code) "")
(retry "Please enter the code you received in your email.")]
[(not (equal? password confirm_password))
(retry "Please make sure the two password fields match.")]
[(equal? (string-trim password) "")
(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)
(retry "Something went awry; you have been emailed another code. Please check your email.")]
[success
;; The email and password combo we have been given is good to go.
;; Set a cookie and consider ourselves logged in.
(create-session-from-authentication-success! email password success)])]))
(define ((check-challenge challenge) request)
(define-form-bindings/trim request (email_for_code question_answer))
(define (retry msg-a msg-b)
(register-form #:email_for_code email_for_code
#:step1a-error-message msg-a
#:step1b-error-message msg-b))
(cond
[(equal? email_for_code "")
(log-info "REGISTRATION/RESET EMAIL: address missing")
(retry "Please enter your email address."
"Don't forget to answer the new question!")]
[(equal? question_answer "")
(log-info "REGISTRATION/RESET EMAIL: no challenge answer provided")
(retry #f
"Please answer the anti-spam question. (It changes each time!)")]
[(not (challenge-passed? challenge question_answer))
(log-info "REGISTRATION/RESET EMAIL: challenge answer incorrect")
(log-info " ✗ email: ~v" email_for_code)
(log-info " ✗ challenge expr: ~a" (challenge-expr challenge))
(log-info " ✗ expected answer: ~v" (~a (challenge-answer challenge)))
(log-info " ✗ provided answer: ~v" question_answer)
(log-info " ✗ HTTP request details: ~v" request)
(retry #f
"Unfortunately, that was not the correct answer. Please try this new question.")]
[else
(log-info "REGISTRATION/RESET EMAIL: sent")
(log-info " ✓ email: ~v" email_for_code)
(log-info " ✓ challenge expr: ~a" (challenge-expr challenge))
(log-info " ✓ expected answer: ~v" (~a (challenge-answer challenge)))
(log-info " ✓ provided answer: ~v" question_answer)
(log-info " ✓ HTTP request details: ~v" request)
(send-registration-or-reset-email! email_for_code)
(with-site-config
(send/suspend/dispatch/dynamic
(lambda (embed-url)
(bootstrap-response "Account registration/reset code emailed"
`(p
"We've emailed an account registration/reset code to "
(code ,email_for_code) ". Please check your email and then click "
"the button to continue:")
`(a ((class "btn btn-primary")
(href ,(embed-url (lambda (req) (register-form)))))
"Enter your code")))))]))
(define (notify-of-emailing request)
(define-form-bindings request (email_for_code))
(authenticate-with-server! email_for_code "" "") ;; TODO check result?
(summarise-code-emailing "Account registration/reset code emailed" email_for_code))
(define (summarise-code-emailing reason email)
(with-site-config
(send/suspend/dispatch/dynamic
(lambda (embed-url)
(bootstrap-response reason
`(p
"We've emailed an account registration/reset code to "
(code ,email) ". Please check your email and then click "
"the button to continue:")
`(a ((class "btn btn-primary")
(href ,(embed-url (lambda (req) (register-form)))))
"Enter your code"))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -597,28 +552,6 @@
(string-append (date->string (seconds->date utc #f) #t) " (UTC)")
"N/A"))
(define (get-implied-docs pkg #:metapackage-implies-index [implies-index #hash()])
;; "foo" is a metapackage for e.g. "foo-lib" or "foo-tests" if foo-lib has a tag
;; "foo", and "foo" implies "foo-lib".
(define metapackage-names
(for*/list ([tag-which-could-be-a-pkg-name (package-tags pkg)]
[tag-implies (in-value (hash-ref implies-index tag-which-could-be-a-pkg-name (λ () #f)))]
#:when tag-implies
#:when (set-member? tag-implies (package-name pkg)))
(string->symbol tag-which-could-be-a-pkg-name)))
(define docs-from-metapackages
(append-map (λ (pkg) (append (package-docs pkg)
;; a metapackage won't have itself a metapackage, so we
;; pass an empty hash to prevent further metapackage lookup.
(get-implied-docs pkg #:metapackage-implies-index #hash())))
(package-batch-detail metapackage-names)))
(define implied-names (map string->symbol (package-implies pkg)))
(define docs-from-implied-pkgs (append-map package-docs (package-batch-detail implied-names)))
(append docs-from-metapackages
docs-from-implied-pkgs))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Package hashtable getters.
;; TODO factor this stuff out into a proper data structure
@ -649,7 +582,6 @@
(define (package-last-updated pkg) (or (@ pkg last-updated) 0))
(define (package-last-checked pkg) (or (@ pkg last-checked) 0))
(define (package-last-edit pkg) (or (@ pkg last-edit) 0))
(define (package-date-added pkg) (or (@ pkg date-added) 0))
(define (package-authors pkg) (or (@ pkg authors) '()))
(define (package-description pkg) (or (@ pkg description) ""))
(define (package-tags pkg) (or (@ pkg tags) '()))
@ -663,66 +595,44 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (package-summary-table package-names)
(define bulk-operations-enabled? (current-user-curator?))
(define column-count (+ 4 (if bulk-operations-enabled? 1 0)))
(define-values (pkg-rows num-todos)
(build-pkg-rows/num-todos bulk-operations-enabled? package-names))
`(form ((role "form")
(action ,(named-url bulk-operation-page))
(method "post"))
(table
((class "packages sortable") (data-todokey ,(number->string num-todos)))
(thead
,@(maybe-splice
bulk-operations-enabled?
`(tr
(td ((colspan ,(~a column-count)))
(div ((class "input-group"))
(select ((class "form-control") (id "bulk-action") (name "bulk-action"))
(option ((value "")) "--- Select a bulk action to perform ---")
(option ((value "make-ring-0")) "Set selected packages to ring 0")
(option ((value "make-ring-1")) "Set selected packages to ring 1")
(option ((value "make-ring-2")) "Set selected packages to ring 2")
)
(span ((class "input-group-btn"))
(button ((class "btn btn-default") (type "submit"))
"Go!")))
(div ((class "input-group"))
(button ((class "btn")
(type "button")
(onclick "toggleBulkOperationSelections()"))
"Select all/none")))))
(tr
(th 'nbsp)
,@(maybe-splice bulk-operations-enabled? `(th 'nbsp))
(th "Package")
(th "Description")
(th "Build")
(th ((style "display: none")) 'nbsp))) ;; todokey
(tbody
,@(maybe-splice (null? package-names)
`(tr (td ((colspan ,(~a column-count)))
(div ((class "alert alert-info"))
"No packages found."))))
,@pkg-rows))))
(build-pkg-rows/num-todos package-names))
`(table
((class "packages sortable") (data-todokey ,(number->string num-todos)))
(thead
(tr
(th 'nbsp)
(th "Package")
(th "Description")
(th "Build")
(th ((style "display: none")) 'nbsp))) ;; todokey
(tbody
,@(maybe-splice (null? package-names)
`(tr (td ((colspan "4"))
(div ((class "alert alert-info"))
"No packages found."))))
,@pkg-rows)))
(define (build-pkg-rows/num-todos bulk-operations-enabled? package-names)
(define (get-implied-docs pkg)
(let* ([implied-names (package-implies pkg)]
[implied-pkgs (package-batch-detail implied-names)])
(map package-docs implied-pkgs)))
(define (build-pkg-rows/num-todos package-names)
;; Builds the list of rows in the package table as an x-exp.
;; Also returns the total number of non-zero todo keys,
;; representing packages with outstanding build errors or
;; failing tests, or which are missing docs or tags.
(define now (/ (current-inexact-milliseconds) 1000))
(define pkgs-details (package-batch-detail package-names))
(define implies-index
(for/hash ([pkg pkgs-details])
(values (package-name pkg)
(list->set (package-implies pkg)))))
(define-values (pkg-rows num-todos)
(for/fold ([pkg-rows null] [num-todos 0])
([pkg pkgs-details])
(define pkg-docs (remove-duplicates
(append (package-docs pkg)
(get-implied-docs pkg #:metapackage-implies-index implies-index))))
([pkg (package-batch-detail package-names)])
(define pkg-docs
(let ([implied-docs (get-implied-docs)]
[pkg-docs (package-docs pkg)])
(if (null? pkg-docs)
implied-docs
(list* pkg-docs implied-docs))))
(define has-docs? (pair? pkg-docs))
(define has-readme? (pair? (package-readme-url pkg)))
(define has-tags? (pair? (package-tags pkg)))
@ -747,13 +657,6 @@
(label-p (if (< todokey 5)
"label-warning"
"label-danger") "Todo")))
,@(maybe-splice
bulk-operations-enabled?
`(td (p "Ring " ,(~a (package-ring pkg)))
,(checkbox-input "selected-packages"
(package-name pkg)
#:id #f
#:extra-classes `("selected-packages"))))
(td (h2 ,(package-link (package-name pkg)))
,(authors-list (package-authors pkg)))
(td (p ,(if (string=? "" (package-description pkg))
@ -795,18 +698,15 @@
(define dep-failure-log-url (package-build-dep-failure-log pkg))
(define test-failure-log-url (package-build-test-failure-log pkg))
(define test-success-log-url (package-build-test-success-log pkg))
(define conflicts-log-url (package-build-conflicts-log pkg))
(define td-class (cond [(or failure-log-url conflicts-log-url) "build_red"]
(define td-class (cond [failure-log-url "build_red"]
[(not success-log-url) ""]
[(or dep-failure-log-url test-failure-log-url) "build_yellow"]
[else "build_green"]))
`(td ((class ,td-class))
,@(for/list [(e (list (if failure-log-url
(list failure-log-url "" "fails")
(list success-log-url "" "succeeds"))
(list conflicts-log-url "; has " "conflicts")
,@(for/list [(e (list (list failure-log-url "" "fails")
(list success-log-url "" "succeeds")
(list dep-failure-log-url "; has " "dependency problems")
(list test-failure-log-url "; has " "failing tests")))]
(match-define (list u p l) e)
@ -819,7 +719,7 @@
(parameterize ((bootstrap-active-navigation nav-index)
(bootstrap-page-scripts (list (static-resource-url "/searchbox.js")
(static-resource-url "/index.js")
(static-resource-url "/package-list.js"))))
(static-resource-url "/todos.js"))))
(define package-name-list (package-search "" '((main-distribution #f)
(main-tests #f)
(deprecated #f))))
@ -833,9 +733,9 @@
`(div ((class "jumbotron"))
(h1 "Racket Packages")
(p "These are the packages in the official "
(a ((href "https://docs.racket-lang.org/pkg/getting-started.html"))
(a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
"package catalog") ".")
(p (a ((href "https://docs.racket-lang.org/pkg/cmdline.html"))
(p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
(kbd "raco pkg install " (var "package-name")))
" installs a package.")
(p "You can "
@ -905,17 +805,10 @@
`(ul (li (a ((href ,(main-page-url)))
"Return to the package index"))))))
(define (current-user-superuser?)
(and (current-session)
(session-superuser? (current-session))))
(define (current-user-curator?)
(and (current-session)
(session-curator? (current-session))))
(define (current-user-may-edit? pkg)
(or (member (current-email) (package-authors pkg))
(current-user-superuser?)))
(and (current-session)
(session-superuser? (current-session)))))
(define (package-page request package-name-str)
(define package-name (string->symbol package-name-str))
@ -938,7 +831,6 @@
(let ((default-version (package-default-version pkg)))
(bootstrap-response (~a package-name)
#:title-element ""
#:description (package-description pkg)
`(div ((class "jumbotron"))
(h1 ,(~a package-name))
(p ,(package-description pkg))
@ -1043,7 +935,9 @@
(tr (th "Ring")
(td ,(~a (or (package-ring pkg) "N/A"))
,@(maybe-splice
(and (package-ring pkg) (current-user-curator?))
(and (package-ring pkg)
(current-session)
(session-curator? (current-session)))
" "
(ring-change-link pkg (- (package-ring pkg) 1) 'blacktriangledown)
(ring-change-link pkg (+ (package-ring pkg) 1) 'blacktriangle))))
@ -1094,7 +988,7 @@
(values k v))))
(maybe-splice
(not (hash-empty? vs))
`(tr (th (a ([href "https://docs.racket-lang.org/pkg/getting-started.html#%28part._.Version_.Exceptions%29"]) "Version Exceptions"))
`(tr (th "Versions")
(td (table ((class "package-versions"))
(tr (th "Version")
(th "Source")
@ -1111,8 +1005,6 @@
(td ,(utc->string (package-last-checked pkg))))
(tr (th "Last edited")
(td ,(utc->string (package-last-edit pkg))))
(tr (th "Date added")
(td ,(utc->string (package-date-added pkg))))
(tr (th "Modules")
(td (ul ((class "module-list"))
,@(for/list ((mod (package-modules pkg)))
@ -1236,7 +1128,18 @@
,(textfield "g_host_port" "Host" g-host+port)
,(textfield "g_repo" "Repository" g-repo "user/repo")
,(textfield "g_commit" "Branch or commit" g-commit "master")
,(textfield "g_path" "Path within repository" g-path))))))
,(textfield "g_path" "Path within repository" g-path)
,(row #:id (group-name "g_transport")
0 3
(label (control-name "g_transport") "Transport")
0 9
`(select ((id ,(control-name "g_transport"))
(name ,(control-name "g_transport")))
,@(for/list [(t (list "git" "https" "http"))]
`(option ((value ,t)
,@(maybe-splice (equal? t g-transport)
'(selected "selected")))
,t)))))))))
(tr (td ((colspan "2"))
(div ((class "form-inline"))
@ -1333,7 +1236,7 @@
(define ((update-draft draft0) request)
(define draft (read-draft-form draft0 (request-bindings request)))
(define-form-bindings/trim request (action new_version))
(define-form-bindings request (action new_version))
(match action
["save_changes"
(if (save-draft! draft)
@ -1345,7 +1248,7 @@
draft))]
["add_version"
(cond
[(equal? new_version "")
[(equal? (string-trim new_version) "")
(package-form "Please enter a version number to add." draft)]
[(assoc new_version (draft-package-versions draft))
(package-form (format "Could not add version ~a, as it already exists." new_version)
@ -1369,10 +1272,12 @@
(g (string->symbol (format "version__~a__~a" version name)) d))
(define type (vg 'type "simple"))
(define simple_url (vg 'simple_url ""))
(define g_transport (vg 'g_transport ""))
(define g_host_port (vg 'g_host_port ""))
(define g_repo0 (vg 'g_repo ""))
(define g_repo (cond
[(regexp-match #rx"[.]git$" g_repo0) g_repo0]
[(equal? g_transport "git") g_repo0]
[else (string-append g_repo0 ".git")]))
(define g_commit0 (vg 'g_commit ""))
(define g_path (vg 'g_path ""))
@ -1386,7 +1291,7 @@
(match type
["simple" simple_url]
["git" (unparse-package-source (git-source "" #f #f
'https
(string->symbol g_transport)
g_host
g_port
g_repo
@ -1506,35 +1411,27 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (update-package-ring-page request package-name-str proposed-new-ring)
(define new-ring (clamp-ring proposed-new-ring))
(authentication-wrap/require-login
#:request request
(update-package-rings! (list package-name-str) proposed-new-ring)
(when (session-curator? (current-session))
(when (simple-json-rpc! backend-baseurl
"/api/package/curate"
(hash 'pkg package-name-str
'ring new-ring))
(define old-pkg (package-detail (string->symbol package-name-str)))
(let* ((new-pkg (hash-set old-pkg 'ring new-ring))
(completion-ch (make-channel)))
(replace-package! completion-ch old-pkg new-pkg)
(channel-get completion-ch))))
(bootstrap-redirect (view-package-url package-name-str))))
(define (update-package-rings! package-name-strings proposed-new-ring)
(if (not (current-user-curator?))
#f
(let ((new-ring (clamp-ring proposed-new-ring)))
(if (not (simple-json-rpc! backend-baseurl
"/api/package/curate"
(hash 'package-names package-name-strings
'ring new-ring)))
#f
(begin
(for [(package-name-str (in-list package-name-strings))]
(define old-pkg (package-detail (string->symbol package-name-str)))
(define new-pkg (hash-set old-pkg 'ring new-ring))
(let ((completion-ch (make-channel)))
(replace-package! completion-ch old-pkg new-pkg)
(channel-get completion-ch)))
#t)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (search-page request)
(parameterize ((bootstrap-active-navigation nav-search)
(bootstrap-page-scripts (list (static-resource-url "/searchbox.js")
(static-resource-url "/package-list.js"))))
(static-resource-url "/todos.js"))))
(authentication-wrap
#:request request
(define-form-bindings request ([search-text q ""]
@ -1555,16 +1452,16 @@
0 10(text-input "tags" tags-input
#:placeholder
"tag1 tag2 tag3 ..."))
,(form-group 2 10 (primary-button (glyphicon 'search) " Search")))
`(div ((class "search-results"))
,@(maybe-splice
(or (pair? tags) (not (equal? search-text "")))
(let ((package-name-list (package-search search-text tags)))
`(div
(p ((class "package-count"))
,(format "~a packages found" (length package-name-list)))
(p ((class "package-count") (id "todo-msg")) "")
,(package-summary-table package-name-list)))))))))
,(form-group 2 10 (primary-button (glyphicon 'search) " Search"))
(div ((class "search-results"))
,@(maybe-splice
(or (pair? tags) (not (equal? search-text "")))
(let ((package-name-list (package-search search-text tags)))
`(div
(p ((class "package-count"))
,(format "~a packages found" (length package-name-list)))
(p ((class "package-count") (id "todo-msg")) "")
,(package-summary-table package-name-list))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1589,46 +1486,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ping-page request)
(response/full 200 #"Alive" (current-seconds) #"text/plain" '() '()))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (bulk-operation-page request)
(authentication-wrap/require-login
#:request request
(cond
[(not (or (current-user-curator?) (current-user-superuser?)))
(bootstrap-redirect (main-page-url))]
[else
(define bindings (request-bindings request))
(define action (extract-binding/single 'bulk-action bindings))
(define package-names (extract-bindings 'selected-packages bindings))
(cond
[(equal? action "")
(bootstrap-response "No action selected.")]
[else
(send/suspend/dynamic
(lambda (k-url)
(bootstrap-response "Confirm bulk operation"
`(div ((class "confirm-bulk-operation"))
(h2 "You are about to " (code ,action) " the following packages:")
(ul ,@(map (lambda (p) `(li ,p))
package-names))
(p "This cannot be undone.")
(form ((action ,k-url) (method "post"))
(button ((class "btn btn-default") (type "submit"))
"Confirm bulk operation"))))))
(match action
["make-ring-0" (update-package-rings! package-names 0)]
["make-ring-1" (update-package-rings! package-names 1)]
["make-ring-2" (update-package-rings! package-names 2)]
[_ (error 'bulk-operation-page "No such action: ~a" action)])
(bootstrap-response "Bulk operation complete."
`(a ((href ,(main-page-url))) "Return to main index page."))])])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO: fold the collection of this information into the package
;; database itself.
(define (update-external-package-information! package-name)
@ -1675,7 +1532,7 @@
(match/values (http/simple-interpret-response
(http/follow-redirects
#"HEAD"
(custom-http-sendrecv/url readme-u #:method #"HEAD")))
(http-sendrecv/url readme-u #:method #"HEAD")))
[('success _headers _body) (url->string readme-u)]
[(_ _ _) #f])))
@ -1689,7 +1546,7 @@
(match/values (http/simple-interpret-response
(http/follow-redirects
#"GET"
(custom-http-sendrecv/url u #:method #"GET")))
(http-sendrecv/url u #:method #"GET")))
[('success _headers body)
(and (regexp-match? #px"(?i:id=.readme.)" body)
(string-append (url->string u) "#readme"))]

14
src/static.rkt
View File

@ -173,14 +173,12 @@
(define (put/bytes^ p cb mt h)
(semaphore-wait put-bytes-sema)
(thread
(procedure-rename
(lambda ()
(with-handlers ((values (lambda (e)
(semaphore-post put-bytes-sema)
(raise e))))
(put/bytes p cb mt h)
(semaphore-post put-bytes-sema)))
(string->symbol (format "~v" (list 'put/bytes^ p))))))
(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))

84
src/users.rkt
View File

@ -1,84 +0,0 @@
#lang racket/base
;; User management - userdb, plus registration and emailing
(provide login-password-correct?
send-registration-or-reset-email!
registration-code-correct?
register-or-update-user!)
(require net/sendmail)
(require reloadable)
(require infrastructure-userdb)
(require "config.rkt")
(require "hash-utils.rkt")
(define-logger racket-pkg-website/users)
(define userdb (userdb-config (@ (config) user-directory)
#t ;; writeable!
))
(define *codes*
(make-persistent-state '*codes* (lambda () (make-registration-state))))
(define (login-password-correct? email given-password)
(log-racket-pkg-website/users-info "Checking password for ~v" email)
(user-password-correct? (lookup-user userdb email) given-password))
(define (send-registration-or-reset-email! email)
(if (user-exists? userdb email)
(send-password-reset-email! email)
(send-account-registration-email! email)))
(define (sender-address)
(or (@ (config) email-sender-address)
"pkgs@racket-lang.org"))
(log-racket-pkg-website/users-info "Will use sender address ~v" (sender-address))
(define (send-password-reset-email! email)
(log-racket-pkg-website/users-info "Sending password reset email to ~v" email)
(send-mail-message
(sender-address)
"Account password reset for Racket Package Catalog"
(list email)
'()
'()
(list
"Someone tried to login with your email address for an account on the Racket Package Catalog, but failed."
"If this was you, please use this code to reset your password:"
""
(generate-registration-code! (*codes*) email)
""
"This code will expire, so if it is not available, you'll have to try again.")))
(define (send-account-registration-email! email)
(log-racket-pkg-website/users-info "Sending account registration email to ~v" email)
(send-mail-message
(sender-address)
"Account confirmation for Racket Package Catalog"
(list email)
'()
'()
(list
"Someone tried to register your email address for an account on the Racket Package Catalog."
"If you want to proceed, use this code:"
""
(generate-registration-code! (*codes*) email)
""
"This code will expire, so if it is not available, you'll have to try to register again.")))
(define (registration-code-correct? email given-code)
(log-racket-pkg-website/users-info "Checking registration code for ~v" email)
(check-registration-code (*codes*)
email
given-code
(lambda () #t)
(lambda () #f)))
(define (register-or-update-user! email password)
(log-racket-pkg-website/users-info "Updating user record ~v" email)
(save-user! userdb
(user-password-set (or (lookup-user userdb email)
(make-user email password))
password)))

2
static/editpackage.js
View File

@ -34,7 +34,7 @@ function preenSourceType(e) {
case "git":
previewGroup.show();
pieces = showhide(false, true, true, true, true, true);
previewUrl = "https" + "://" + pieces[2] + "/" + pieces[3] +
previewUrl = pieces[1] + "://" + pieces[2] + "/" + pieces[3] +
(pieces[5] ? "?path=" + pieces[5] : "") +
(pieces[4] && (pieces[4] !== 'master') ? '#' + pieces[4] : "");
break;

18
static/style.css
View File

@ -83,10 +83,6 @@ input#new_version {
width: 6em;
}
.not-shown-to-humans {
display: none;
}
.confirm-package-deletion {
background-color: red;
padding: 2em;
@ -102,20 +98,6 @@ input#new_version {
margin: 0;
}
.confirm-bulk-operation {
background-color: #ffdddd;
padding: 2em;
display: block;
border: solid black 1rem;
font-size: 120%;
}
.confirm-bulk-operation h2 {
margin: 0;
}
.confirm-bulk-operation ul {
margin: 2em;
}
.package-count {
font-size: 120%;
}

9
static/package-list.js → static/todos.js
View File

@ -1,12 +1,3 @@
// Functions related to package listings as produced by `package-summary-table` in site.rkt
function toggleBulkOperationSelections() {
var checkboxes = Array.from(document.querySelectorAll("input.selected-packages"));
var anySelected = checkboxes.some(function (n) { return n.checked; });
var newState = anySelected ? false : true;
checkboxes.forEach(function (n) { n.checked = newState; });
}
$(function() {
"use strict";