Compare commits
5 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
3dd7313886 | ||
|
|
b84f1bc054 | ||
|
|
be6987c1eb | ||
|
|
b7bccd00a6 | ||
|
|
d50341d4ae |
62
README.md
62
README.md
|
|
@ -23,33 +23,26 @@ a hashtable to `main`.
|
||||||
Keys useful for deployment:
|
Keys useful for deployment:
|
||||||
|
|
||||||
- *port*: number; default the value of the `SITE_PORT` environment
|
- *port*: number; default the value of the `SITE_PORT` environment
|
||||||
variable, if defined; otherwise, 7443.
|
variable, if defined; otherwise, 8443.
|
||||||
- *ssl?*: boolean; default `#t`.
|
- *ssl?*: boolean; default `#t`.
|
||||||
- *reloadable?*: boolean; `#t` if the `SITE_RELOADABLE` environment
|
- *reloadable?*: boolean; `#t` if the `SITE_RELOADABLE` environment
|
||||||
variable is defined; otherwise, `#f`.
|
variable is defined; otherwise, `#f`.
|
||||||
- *recent-seconds*: number, in seconds; default 172800. Packages
|
- *recent-seconds*: number, in seconds; default 172800. Packages
|
||||||
modified fewer than this many seconds ago are considered "recent",
|
modified fewer than this many seconds ago are considered "recent",
|
||||||
and displayed as such in the UI.
|
and displayed as such in the UI.
|
||||||
- *static-output-type*: either `'aws-s3` or `'file`.
|
- *static-content-target-directory*: either `#f` or a string denoting
|
||||||
- When `'file`,
|
a path to a folder to which the static content of the site will be
|
||||||
- *static-content-target-directory*: either `#f` or a string
|
copied.
|
||||||
denoting a path to a folder to which the static content of
|
- *static-content-update-hook*: either `#f`, or a string containing a
|
||||||
the site will be copied.
|
shell command to invoke every time files are updated in
|
||||||
- When `'aws-s3`,
|
*static-content-target-directory*.
|
||||||
- *aws-s3-bucket+path*: a string naming an S3 bucket and path.
|
|
||||||
Must end with a forward slash, ".../". AWS access keys are
|
|
||||||
loaded per the documentation for the `aws` module; usually
|
|
||||||
from a file `~/.aws-keys`.
|
|
||||||
- *dynamic-urlprefix*: string; absolute or relative URL, prepended to
|
- *dynamic-urlprefix*: string; absolute or relative URL, prepended to
|
||||||
URLs targetting dynamic content on the site.
|
URLs targetting dynamic content on the site.
|
||||||
- *static-urlprefix*: string; absolute or relative URL, prepended to
|
- *static-urlprefix*: string; absolute or relative URL, prepended to
|
||||||
relative URLs referring to static HTML files placed in
|
relative URLs referring to static HTML files placed in
|
||||||
`static-generated-directory`.
|
`static-generated-directory`.
|
||||||
- *pkg-index-generated-directory*: a string pointing to where the
|
- *extra-static-content-directories*: list of strings; defaults to
|
||||||
`pkg-index` package places its redered files, to be served
|
the empty list.
|
||||||
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.
|
|
||||||
|
|
||||||
Keys useful for development:
|
Keys useful for development:
|
||||||
|
|
||||||
|
|
@ -123,43 +116,6 @@ To enable replication, set configuration variable
|
||||||
set `static-content-update-hook` to a string containing a shell
|
set `static-content-update-hook` to a string containing a shell
|
||||||
command to execute every time the static content is updated.
|
command to execute every time the static content is updated.
|
||||||
|
|
||||||
#### S3 Content
|
|
||||||
|
|
||||||
To set up an S3 bucket---let's call it `s3.example`---for use with
|
|
||||||
this site, follow these steps:
|
|
||||||
|
|
||||||
0. Create the bucket ("`s3.example`")
|
|
||||||
0. Optionally add a CNAME record to DNS mapping `s3.example` to
|
|
||||||
`s3.example.s3-website-us-east-1.amazonaws.com`. If you do, static
|
|
||||||
resources will be available at `http://s3.example/`; if not, at
|
|
||||||
the longer URL.
|
|
||||||
0. Enable "Static Website Hosting" for the bucket. Set the index
|
|
||||||
document to `index.html` and the error document to `not-found`.
|
|
||||||
|
|
||||||
Then, under "Permissions", click "Add bucket policy", and add
|
|
||||||
something like the following.
|
|
||||||
|
|
||||||
{
|
|
||||||
"Id": "RacketPackageWebsiteS3Policy",
|
|
||||||
"Version": "2012-10-17",
|
|
||||||
"Statement": [
|
|
||||||
{
|
|
||||||
"Sid": "RacketPackageWebsiteS3PolicyStmt1",
|
|
||||||
"Action": "s3:*",
|
|
||||||
"Effect": "Allow",
|
|
||||||
"Resource": ["arn:aws:s3:::s3.example",
|
|
||||||
"arn:aws:s3:::s3.example/*"],
|
|
||||||
"Principal": {
|
|
||||||
"AWS": ["<<<ARN OF THE USER TO WHOM ACCESS SHOULD BE GRANTED>>>"]
|
|
||||||
}
|
|
||||||
}
|
|
||||||
]
|
|
||||||
}
|
|
||||||
|
|
||||||
The user will need to be able to read and write objects and set CORS
|
|
||||||
policy. (CORS is configured automatically by code in
|
|
||||||
`src/static.rkt`.)
|
|
||||||
|
|
||||||
### Supervision
|
### Supervision
|
||||||
|
|
||||||
Startable using djb's [daemontools](http://cr.yp.to/daemontools.html);
|
Startable using djb's [daemontools](http://cr.yp.to/daemontools.html);
|
||||||
|
|
|
||||||
2
TODO.md
2
TODO.md
|
|
@ -1,5 +1,7 @@
|
||||||
## Bugs
|
## Bugs
|
||||||
|
|
||||||
|
racket-lib's dependencies aren't strings, and so lead to wrong URLs on its detail page
|
||||||
|
|
||||||
get-bonus's conflicts path isn't a string, and so leads to a wrong URL
|
get-bonus's conflicts path isn't a string, and so leads to a wrong URL
|
||||||
on its detail page. See http://pkg-build.racket-lang.org/ - this kind
|
on its detail page. See http://pkg-build.racket-lang.org/ - this kind
|
||||||
of indirect report means that one of the dependencies of the package
|
of indirect report means that one of the dependencies of the package
|
||||||
|
|
|
||||||
|
|
@ -1,39 +1,4 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
;; Default configuration; should be suitable for live deployment.
|
;; Default configuration; should be suitable for live deployment.
|
||||||
(require "../src/main.rkt")
|
(require "../src/main.rkt")
|
||||||
(define var (getenv "PKGSERVER_DATADIR"))
|
(main)
|
||||||
(main (hash 'port 8444
|
|
||||||
'reloadable? #t
|
|
||||||
'var-path var
|
|
||||||
'package-index-url
|
|
||||||
(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")
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; To configure a split, S3-based setup, comment out the following lines:
|
|
||||||
;;
|
|
||||||
;; 'static-output-type 'file
|
|
||||||
;; 'static-content-target-directory (build-path var "public_html/pkg-catalog-static")
|
|
||||||
;; 'static-urlprefix ""
|
|
||||||
;; 'dynamic-urlprefix "/catalog"
|
|
||||||
;;
|
|
||||||
;; ... and uncomment and adjust these instead:
|
|
||||||
;;
|
|
||||||
|
|
||||||
'static-output-type 'aws-s3
|
|
||||||
'aws-s3-bucket+path "pkgs.racket-lang.org/"
|
|
||||||
'static-urlprefix "https://pkgs.racket-lang.org"
|
|
||||||
'dynamic-urlprefix "https://pkgd.racket-lang.org/pkgn"
|
|
||||||
'dynamic-static-urlprefix "https://pkgs.racket-lang.org"
|
|
||||||
|
|
||||||
;; 'static-output-type 'aws-s3
|
|
||||||
;; 'aws-s3-bucket+path "pkgs.leastfixedpoint.com/"
|
|
||||||
;; 'static-urlprefix "http://pkgs.leastfixedpoint.com.s3-website-us-east-1.amazonaws.com"
|
|
||||||
;; 'dynamic-urlprefix "https://localhost:8444"
|
|
||||||
|
|
||||||
;;
|
|
||||||
;; Make sure to *include* a slash at the end of
|
|
||||||
;; aws-s3-bucket+path, and to *exclude* a slash from the
|
|
||||||
;; end of both static-urlprefix and dynamic-urlprefix.
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
))
|
|
||||||
|
|
|
||||||
|
|
@ -1,13 +0,0 @@
|
||||||
#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/"
|
|
||||||
))
|
|
||||||
|
|
@ -3,27 +3,12 @@
|
||||||
(require "../src/main.rkt")
|
(require "../src/main.rkt")
|
||||||
(main (hash 'port 8444
|
(main (hash 'port 8444
|
||||||
'reloadable? #t
|
'reloadable? #t
|
||||||
'package-index-url "file:///home/tonyg/public_html/pkg-index-static/pkgs-all.json.gz"
|
'package-index-url "https://localhost:8444/pkgs-all.json.gz"
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Either:
|
|
||||||
;;
|
|
||||||
'static-output-type 'file
|
|
||||||
'static-content-target-directory (build-path (find-system-path 'home-dir)
|
'static-content-target-directory (build-path (find-system-path 'home-dir)
|
||||||
"public_html/pkg-catalog-static")
|
"public_html/pkg-catalog-static")
|
||||||
'static-urlprefix "https://localhost/~tonyg/pkg-catalog-static"
|
'static-urlprefix "https://localhost/~tonyg/pkg-catalog-static"
|
||||||
;;
|
|
||||||
;; Or:
|
|
||||||
;;
|
|
||||||
;; 'static-output-type 'aws-s3
|
|
||||||
;; 'aws-s3-bucket+path "pkgs.leastfixedpoint.com/"
|
|
||||||
;; ;; These two should be set to an HTTPS proxy (e.g. nginx) proxying to S3,
|
|
||||||
;; ;; http://pkgs.leastfixedpoint.com.s3-website-us-east-1.amazonaws.com
|
|
||||||
;; 'static-urlprefix "https://localhost:8446"
|
|
||||||
;; 'dynamic-static-urlprefix "https://localhost:8446"
|
|
||||||
;;
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
'dynamic-urlprefix "https://localhost:8444"
|
'dynamic-urlprefix "https://localhost:8444"
|
||||||
'backend-baseurl "https://localhost:8445"
|
'backend-baseurl "https://localhost:8445"
|
||||||
'pkg-index-generated-directory (build-path (find-system-path 'home-dir)
|
'extra-static-content-directories (list (build-path (find-system-path 'home-dir)
|
||||||
"public_html/pkg-index-static")
|
"public_html/pkg-index-static"))
|
||||||
))
|
))
|
||||||
|
|
|
||||||
|
|
@ -1,30 +0,0 @@
|
||||||
# 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;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
@ -1,2 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
exec nginx -p . -c nginx.locals3proxy.conf
|
|
||||||
4
run
4
run
|
|
@ -12,8 +12,8 @@ if [ ! -f configs/${CONFIG}.rkt ]; then
|
||||||
exit 1
|
exit 1
|
||||||
fi
|
fi
|
||||||
|
|
||||||
PLTSTDERR="info warning@cm warning@compiler/cm warning@module-prefetch warning@setup/parallel-build warning@cm-accomplice warning@online-check-syntax error@racket/contract"
|
PLTSTDERR=info
|
||||||
export PLTSTDERR
|
export PLTSTDERR
|
||||||
echo '============================================='
|
echo '============================================='
|
||||||
cd src
|
cd src
|
||||||
exec ${RACKET}racket ../configs/${CONFIG}.rkt 2>&1
|
exec racket ../configs/${CONFIG}.rkt 2>&1
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,6 @@
|
||||||
;; Utilities for working with Twitter Bootstrap, http://getbootstrap.com/2.3.2/
|
;; Utilities for working with Twitter Bootstrap, http://getbootstrap.com/2.3.2/
|
||||||
|
|
||||||
(provide bootstrap-static-urlprefix
|
(provide bootstrap-static-urlprefix
|
||||||
bootstrap-dynamic-urlprefix
|
|
||||||
bootstrap-project-name
|
bootstrap-project-name
|
||||||
bootstrap-project-link
|
bootstrap-project-link
|
||||||
bootstrap-navbar-header
|
bootstrap-navbar-header
|
||||||
|
|
@ -13,7 +12,6 @@
|
||||||
bootstrap-page-scripts
|
bootstrap-page-scripts
|
||||||
bootstrap-cookies
|
bootstrap-cookies
|
||||||
bootstrap-inline-js
|
bootstrap-inline-js
|
||||||
bootstrap-head-extra
|
|
||||||
|
|
||||||
bootstrap-response
|
bootstrap-response
|
||||||
bootstrap-redirect
|
bootstrap-redirect
|
||||||
|
|
@ -29,7 +27,6 @@
|
||||||
(require "xexpr-utils.rkt")
|
(require "xexpr-utils.rkt")
|
||||||
|
|
||||||
(define bootstrap-static-urlprefix (make-parameter ""))
|
(define bootstrap-static-urlprefix (make-parameter ""))
|
||||||
(define bootstrap-dynamic-urlprefix (make-parameter ""))
|
|
||||||
(define bootstrap-project-name (make-parameter "Project"))
|
(define bootstrap-project-name (make-parameter "Project"))
|
||||||
(define bootstrap-project-link (make-parameter "/"))
|
(define bootstrap-project-link (make-parameter "/"))
|
||||||
(define bootstrap-navbar-header (make-parameter #f))
|
(define bootstrap-navbar-header (make-parameter #f))
|
||||||
|
|
@ -40,12 +37,9 @@
|
||||||
(define bootstrap-page-scripts (make-parameter '()))
|
(define bootstrap-page-scripts (make-parameter '()))
|
||||||
(define bootstrap-cookies (make-parameter '()))
|
(define bootstrap-cookies (make-parameter '()))
|
||||||
(define bootstrap-inline-js (make-parameter #f))
|
(define bootstrap-inline-js (make-parameter #f))
|
||||||
(define bootstrap-head-extra (make-parameter '()))
|
|
||||||
|
|
||||||
(define (static str)
|
(define (static str)
|
||||||
(string-append (bootstrap-static-urlprefix) 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
|
;; String [#:title-element XExpr] [#:code Integer] [#:message Bytes] [XExpr ...] -> Response
|
||||||
(define (bootstrap-response title
|
(define (bootstrap-response title
|
||||||
|
|
@ -69,8 +63,7 @@
|
||||||
(link ((rel "stylesheet") (href ,(static "/jquery-ui.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")))
|
(link ((rel "stylesheet") (href ,(static "/style.css")) (type "text/css")))
|
||||||
,@(for/list ((sheet (bootstrap-page-stylesheets)))
|
,@(for/list ((sheet (bootstrap-page-stylesheets)))
|
||||||
`(link ((rel "stylesheet") (href ,sheet) (type "text/css"))))
|
`(link ((rel "stylesheet") (href ,sheet) (type "text/css")))))
|
||||||
,@(bootstrap-head-extra))
|
|
||||||
(body ,@(maybe-splice body-class `((class ,body-class)))
|
(body ,@(maybe-splice body-class `((class ,body-class)))
|
||||||
(nav ((class "navbar navbar-inverse navbar-fixed-top") (role "navigation"))
|
(nav ((class "navbar navbar-inverse navbar-fixed-top") (role "navigation"))
|
||||||
(div ((class "container-fluid"))
|
(div ((class "container-fluid"))
|
||||||
|
|
@ -88,7 +81,11 @@
|
||||||
,(bootstrap-project-name))))
|
,(bootstrap-project-name))))
|
||||||
(div ((id "navbar") (class "collapse navbar-collapse"))
|
(div ((id "navbar") (class "collapse navbar-collapse"))
|
||||||
(ul ((class "nav navbar-nav"))
|
(ul ((class "nav navbar-nav"))
|
||||||
,@(render-nav-items (bootstrap-navigation)))
|
,@(for/list ((n (bootstrap-navigation)))
|
||||||
|
(match-define (list text url) n)
|
||||||
|
`(li ,@(maybe-splice (equal? text (bootstrap-active-navigation))
|
||||||
|
`((class "active")))
|
||||||
|
(a ((href ,url)) ,text))))
|
||||||
,@(bootstrap-navbar-extension)
|
,@(bootstrap-navbar-extension)
|
||||||
)))
|
)))
|
||||||
(div ((class "container"))
|
(div ((class "container"))
|
||||||
|
|
@ -104,28 +101,6 @@
|
||||||
,@(for/list ((script (bootstrap-page-scripts)))
|
,@(for/list ((script (bootstrap-page-scripts)))
|
||||||
`(script ((type "text/javascript") (src ,script))))))))
|
`(script ((type "text/javascript") (src ,script))))))))
|
||||||
|
|
||||||
(define (render-nav-items items)
|
|
||||||
(for/list ((n items))
|
|
||||||
(match n
|
|
||||||
[(list text (? string? url))
|
|
||||||
`(li ,@(maybe-splice (equal? text (bootstrap-active-navigation))
|
|
||||||
`((class "active")))
|
|
||||||
(a ((href ,url)) ,text))]
|
|
||||||
['separator
|
|
||||||
`(li ((role "separator") (class "divider")))]
|
|
||||||
[(list text (? list? subitems))
|
|
||||||
`(li ((class "dropdown"))
|
|
||||||
(a ((href "#")
|
|
||||||
(class "dropdown-toggle")
|
|
||||||
(data-toggle "dropdown")
|
|
||||||
(role "button")
|
|
||||||
(aria-haspopup "true")
|
|
||||||
(aria-expanded "false"))
|
|
||||||
,text
|
|
||||||
(span ((class "caret"))))
|
|
||||||
(ul ((class "dropdown-menu"))
|
|
||||||
,@(render-nav-items subitems)))])))
|
|
||||||
|
|
||||||
;; String [#:permanent? Boolean] [#:headers (Listof Header)] -> Response
|
;; String [#:permanent? Boolean] [#:headers (Listof Header)] -> Response
|
||||||
(define (bootstrap-redirect url
|
(define (bootstrap-redirect url
|
||||||
#:permanent? [permanent? #f]
|
#:permanent? [permanent? #f]
|
||||||
|
|
@ -137,7 +112,7 @@
|
||||||
|
|
||||||
;; Request -> Response
|
;; Request -> Response
|
||||||
(define (bootstrap-continuation-expiry-handler request)
|
(define (bootstrap-continuation-expiry-handler request)
|
||||||
(bootstrap-redirect (dynamic (url->string (strip-parameters (request-uri request))))))
|
(bootstrap-redirect (url->string (strip-parameters (request-uri request)))))
|
||||||
|
|
||||||
;; URL -> URL
|
;; URL -> URL
|
||||||
(define (strip-parameters u)
|
(define (strip-parameters u)
|
||||||
|
|
|
||||||
117
src/build-server.rkt
Normal file
117
src/build-server.rkt
Normal file
|
|
@ -0,0 +1,117 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide pkg-build-baseurl)
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
(require racket/file)
|
||||||
|
(require (only-in racket/port copy-port))
|
||||||
|
(require net/url)
|
||||||
|
(require "config.rkt")
|
||||||
|
(require "hash-utils.rkt")
|
||||||
|
(require reloadable)
|
||||||
|
(require "daemon.rkt")
|
||||||
|
(require "rpc.rkt")
|
||||||
|
|
||||||
|
(define pkg-build-baseurl
|
||||||
|
(or (@ (config) pkg-build-baseurl)
|
||||||
|
"http://pkg-build.racket-lang.org/"))
|
||||||
|
|
||||||
|
(define pkg-build-cache-path
|
||||||
|
(or (@ (config) pkg-build-cache-path)
|
||||||
|
(build-path (var-path) "cache")))
|
||||||
|
|
||||||
|
(make-directory* pkg-build-cache-path)
|
||||||
|
|
||||||
|
(define pkg-build-cache-refresh-interval
|
||||||
|
(* 1000 (or (@ (config) pkg-build-cache-refresh-interval)
|
||||||
|
3600))) ;; one hour
|
||||||
|
|
||||||
|
(define (compute-next-refresh-deadline)
|
||||||
|
(+ (current-inexact-milliseconds) pkg-build-cache-refresh-interval))
|
||||||
|
|
||||||
|
(define cached-summary-path (build-path pkg-build-cache-path "summary.rktd"))
|
||||||
|
(define cached-etag-path (build-path pkg-build-cache-path "summary.rktd.etag"))
|
||||||
|
|
||||||
|
(define (extract-etag hs)
|
||||||
|
(for/or ([h (in-list hs)])
|
||||||
|
(match h
|
||||||
|
[(regexp #rx#"^ETag: (.*?)$" (list _ tag-bytes)) tag-bytes]
|
||||||
|
[_ #f])))
|
||||||
|
|
||||||
|
;; Returns #t if the summary file has been updated, or #f if it
|
||||||
|
;; remains the same as it was previously.
|
||||||
|
(define (refresh-build-server-summary!)
|
||||||
|
(define summary-url (combine-url/relative (string->url pkg-build-baseurl) "summary.rktd"))
|
||||||
|
|
||||||
|
(define HEAD-etag
|
||||||
|
(let-values (((HEAD-status HEAD-headers HEAD-body-input-port)
|
||||||
|
(http-sendrecv/url summary-url #:method #"HEAD")))
|
||||||
|
(extract-etag HEAD-headers)))
|
||||||
|
|
||||||
|
(define cached-etag (and (file-exists? cached-etag-path) (file->bytes cached-etag-path)))
|
||||||
|
|
||||||
|
(define need-refresh?
|
||||||
|
(or (not HEAD-etag) ;; server didn't supply an ETag
|
||||||
|
(not cached-etag) ;; we don't have a record of an ETag locally
|
||||||
|
(not (equal? HEAD-etag cached-etag)))) ;; the ETag has changed
|
||||||
|
|
||||||
|
(cond
|
||||||
|
[need-refresh?
|
||||||
|
(log-info "Build server summary.rktd ETag has changed. Refreshing.")
|
||||||
|
(define-values (GET-status GET-headers GET-body-input-port)
|
||||||
|
(http-sendrecv/url summary-url #:method #"GET"))
|
||||||
|
|
||||||
|
(define new-file (make-temporary-file "summary-~a.rktd" #f pkg-build-cache-path))
|
||||||
|
(call-with-output-file new-file
|
||||||
|
(lambda (p) (copy-port GET-body-input-port p))
|
||||||
|
#:exists 'replace)
|
||||||
|
(with-output-to-file cached-etag-path
|
||||||
|
(lambda () (write-bytes (extract-etag GET-headers)))
|
||||||
|
#:exists 'replace)
|
||||||
|
(rename-file-or-directory new-file cached-summary-path #t)]
|
||||||
|
[else
|
||||||
|
(log-info "Build server summary.rktd ETag has not changed.")])
|
||||||
|
|
||||||
|
need-refresh?)
|
||||||
|
|
||||||
|
(define (load-build-server-summary)
|
||||||
|
(if (file-exists? cached-summary-path)
|
||||||
|
(file->value cached-summary-path)
|
||||||
|
(hash)))
|
||||||
|
|
||||||
|
(struct build-server-state (summary-table
|
||||||
|
next-refresh-deadline
|
||||||
|
) #:prefab)
|
||||||
|
|
||||||
|
(define (boot-build-server)
|
||||||
|
(refresh-build-server-summary!)
|
||||||
|
(build-server-main (build-server-state (load-build-server-summary)
|
||||||
|
(compute-next-refresh-deadline))))
|
||||||
|
|
||||||
|
(define (send-change-notifications! old-table new-table)
|
||||||
|
(log-info "HERE ~v ~v" old-table new-table))
|
||||||
|
|
||||||
|
(define (build-server-main state)
|
||||||
|
(match-define (build-server-state summary-table next-refresh-deadline) state)
|
||||||
|
(build-server-main
|
||||||
|
(rpc-handler (sync (rpc-request-evt)
|
||||||
|
(handle-evt (alarm-evt next-refresh-deadline)
|
||||||
|
(lambda (_) (list #f 'refresh!))))
|
||||||
|
[('refresh!)
|
||||||
|
(values (void)
|
||||||
|
(if (refresh-build-server-summary!)
|
||||||
|
(let ((new-summary-table (load-build-server-summary)))
|
||||||
|
(send-change-notifications! summary-table new-summary-table)
|
||||||
|
(struct-copy build-server-state state
|
||||||
|
[summary-table new-summary-table]
|
||||||
|
[next-refresh-deadline (compute-next-refresh-deadline)]))
|
||||||
|
(struct-copy build-server-state state
|
||||||
|
[next-refresh-deadline (compute-next-refresh-deadline)])))]
|
||||||
|
)))
|
||||||
|
|
||||||
|
(define build-server-thread
|
||||||
|
(make-persistent-state 'build-server-thread
|
||||||
|
(lambda () (daemon-thread 'build-server
|
||||||
|
(lambda () (boot-build-server))))))
|
||||||
|
|
||||||
|
(sleep 5)
|
||||||
|
|
@ -14,8 +14,6 @@
|
||||||
|
|
||||||
(define-runtime-path here ".")
|
(define-runtime-path here ".")
|
||||||
(define (config-path str)
|
(define (config-path str)
|
||||||
(unless (path-string? str)
|
|
||||||
(error 'config-path "Not given path string: ~e" str))
|
|
||||||
(define p (if (relative-path? str)
|
(define p (if (relative-path? str)
|
||||||
(build-path here str)
|
(build-path here str)
|
||||||
str))
|
str))
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
(provide daemonize-thunk
|
(provide daemonize-thunk
|
||||||
daemon-thread)
|
daemon-thread)
|
||||||
|
|
||||||
(require (only-in racket/exn exn->string))
|
(require (only-in web-server/private/util exn->string))
|
||||||
|
|
||||||
(define (daemonize-thunk name boot-thunk)
|
(define (daemonize-thunk name boot-thunk)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
|
|
|
||||||
|
|
@ -10,7 +10,7 @@
|
||||||
(require "signals.rkt")
|
(require "signals.rkt")
|
||||||
(require "daemon.rkt")
|
(require "daemon.rkt")
|
||||||
|
|
||||||
(define (start-service* #:port [port 7443]
|
(define (start-service* #:port [port 8443]
|
||||||
#:ssl? [ssl? #t]
|
#:ssl? [ssl? #t]
|
||||||
request-handler-function
|
request-handler-function
|
||||||
on-continuation-expiry
|
on-continuation-expiry
|
||||||
|
|
@ -34,7 +34,7 @@
|
||||||
#:ssl-key (and ssl? (build-path (current-directory) "../private-key.pem"))
|
#:ssl-key (and ssl? (build-path (current-directory) "../private-key.pem"))
|
||||||
#:servlet-regexp #rx"")))))
|
#:servlet-regexp #rx"")))))
|
||||||
|
|
||||||
(define (start-service #:port [port 7443]
|
(define (start-service #:port [port 8443]
|
||||||
#:ssl? [ssl? #t]
|
#:ssl? [ssl? #t]
|
||||||
#:reloadable? [reloadable? #t]
|
#:reloadable? [reloadable? #t]
|
||||||
request-handler-entry-point
|
request-handler-entry-point
|
||||||
|
|
|
||||||
|
|
@ -9,8 +9,8 @@
|
||||||
;; Boolean XExpr ... -> (Listof XExpr)
|
;; Boolean XExpr ... -> (Listof XExpr)
|
||||||
;; Useful for optionally splicing in some contents to a list.
|
;; Useful for optionally splicing in some contents to a list.
|
||||||
;; If the guard is true, returns the contents; otherwise returns the empty list.
|
;; If the guard is true, returns the contents; otherwise returns the empty list.
|
||||||
(define-syntax-rule (maybe-splice guard contents ...)
|
(define (maybe-splice guard . contents)
|
||||||
(if guard (list contents ...) '()))
|
(if guard contents '()))
|
||||||
|
|
||||||
;; Extracts named single-valued bindings from the given request.
|
;; Extracts named single-valued bindings from the given request.
|
||||||
;; If a given binding is missing, the extracted value will be #f.
|
;; If a given binding is missing, the extracted value will be #f.
|
||||||
|
|
|
||||||
|
|
@ -1,160 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; HTTP utilities
|
|
||||||
|
|
||||||
(provide http-redirection-limit
|
|
||||||
http-classify-status-code
|
|
||||||
http-interpret-response
|
|
||||||
http-simple-interpret-response
|
|
||||||
http-follow-redirects
|
|
||||||
http-sendrecv/url
|
|
||||||
|
|
||||||
http/interpret-response
|
|
||||||
http/simple-interpret-response
|
|
||||||
http/follow-redirects)
|
|
||||||
|
|
||||||
(require (only-in racket/port port->bytes))
|
|
||||||
(require (only-in racket/bytes bytes-join))
|
|
||||||
(require racket/match)
|
|
||||||
(require net/http-client)
|
|
||||||
(require net/head)
|
|
||||||
(require (except-in net/url http-sendrecv/url))
|
|
||||||
|
|
||||||
;; (Parameterof Number)
|
|
||||||
;; Number of redirections to automatically follow when retrieving via GET or HEAD.
|
|
||||||
(define http-redirection-limit (make-parameter 20))
|
|
||||||
|
|
||||||
;; Number -> Symbol
|
|
||||||
;; Returns the broad classification associated with a given HTTP status code.
|
|
||||||
(define (http-classify-status-code status-code)
|
|
||||||
(cond
|
|
||||||
[(<= status-code 99) 'unknown]
|
|
||||||
[(<= 100 status-code 199) 'informational]
|
|
||||||
[(<= 200 status-code 299) 'success]
|
|
||||||
[(<= 300 status-code 399) 'redirection]
|
|
||||||
[(<= 400 status-code 499) 'client-error]
|
|
||||||
[(<= 500 status-code 599) 'server-error]
|
|
||||||
[(<= 600 status-code) 'unknown]))
|
|
||||||
|
|
||||||
(define (parse-status-line status-line)
|
|
||||||
(match status-line
|
|
||||||
[(regexp #px#"^([^ ]+) ([^ ]+)( (.*))?$" (list _ v c _ r))
|
|
||||||
(values v (string->number (bytes->string/latin-1 c)) (bytes->string/latin-1 r))]
|
|
||||||
[_
|
|
||||||
(values #f #f #f)]))
|
|
||||||
|
|
||||||
(define (parse-headers response-headers [downcase-header-names? #t])
|
|
||||||
(for/list [(h (extract-all-fields (bytes-join response-headers #"\r\n")))]
|
|
||||||
(cons (string->symbol ((if downcase-header-names? string-downcase values)
|
|
||||||
(bytes->string/latin-1 (car h))))
|
|
||||||
(cdr h))))
|
|
||||||
|
|
||||||
;; <customizations ...>
|
|
||||||
;; -> Bytes (Listof Bytes) InputPort
|
|
||||||
;; -> (Values (Option Bytes)
|
|
||||||
;; (Option Number)
|
|
||||||
;; (Option String)
|
|
||||||
;; (Listof (Cons Symbol Bytes))
|
|
||||||
;; (if read-body? Bytes InputPort))
|
|
||||||
(define ((http-interpret-response #:downcase-header-names? [downcase-header-names? #t]
|
|
||||||
#:read-body? [read-body? #t])
|
|
||||||
status-line response-headers response-body-port)
|
|
||||||
(define-values (http-version status-code reason-phrase) (parse-status-line status-line))
|
|
||||||
(values http-version
|
|
||||||
status-code
|
|
||||||
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)))
|
|
||||||
|
|
||||||
(define (http-simple-interpret-response status-line response-headers response-body-port)
|
|
||||||
(define-values (_http-version
|
|
||||||
status-code
|
|
||||||
_reason-phrase
|
|
||||||
headers
|
|
||||||
body)
|
|
||||||
((http-interpret-response) status-line response-headers response-body-port))
|
|
||||||
(values (http-classify-status-code status-code)
|
|
||||||
headers
|
|
||||||
body))
|
|
||||||
|
|
||||||
(define ((http-follow-redirects method
|
|
||||||
#:version [version #"1.1"])
|
|
||||||
status-line
|
|
||||||
response-headers
|
|
||||||
response-body-port)
|
|
||||||
(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))
|
|
||||||
|
|
||||||
;; 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)
|
|
||||||
(http-interpret-response customization ...)))
|
|
||||||
|
|
||||||
(define-syntax-rule (http/simple-interpret-response req-expr)
|
|
||||||
(call-with-values (lambda () req-expr)
|
|
||||||
http-simple-interpret-response))
|
|
||||||
|
|
||||||
(define-syntax-rule (http/follow-redirects customization ... req-expr)
|
|
||||||
(call-with-values (lambda () req-expr)
|
|
||||||
(http-follow-redirects customization ...)))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(require rackunit)
|
|
||||||
|
|
||||||
(http/simple-interpret-response
|
|
||||||
(http/follow-redirects
|
|
||||||
#"HEAD"
|
|
||||||
(http-sendrecv/url (string->url "http://google.com/") #:method #"HEAD")))
|
|
||||||
)
|
|
||||||
|
|
@ -1,46 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; Trivially simple authenticated JSON-over-HTTPS RPC.
|
|
||||||
|
|
||||||
(provide simple-json-rpc!)
|
|
||||||
|
|
||||||
(require racket/port)
|
|
||||||
(require net/url)
|
|
||||||
(require net/base64)
|
|
||||||
(require json)
|
|
||||||
(require "sessions.rkt")
|
|
||||||
|
|
||||||
(define (make-basic-auth-credentials-header username password)
|
|
||||||
(define token
|
|
||||||
(base64-encode (string->bytes/utf-8 (string-append username ":" password)) #""))
|
|
||||||
(string-append "Authorization: Basic " (bytes->string/utf-8 token)))
|
|
||||||
|
|
||||||
(define (simple-json-rpc! #:sensitive? [sensitive? #f]
|
|
||||||
#:include-credentials? [include-credentials? #t]
|
|
||||||
baseurl
|
|
||||||
site-relative-url
|
|
||||||
jsexpr-to-send)
|
|
||||||
(define s (current-session))
|
|
||||||
(if sensitive?
|
|
||||||
(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?
|
|
||||||
(if s
|
|
||||||
" +creds"
|
|
||||||
" +creds(missing)")
|
|
||||||
"")))
|
|
||||||
(define request-urls (format "~a~a" baseurl site-relative-url))
|
|
||||||
(define request-url (string->url request-urls))
|
|
||||||
(define post-data (string->bytes/utf-8 (jsexpr->string jsexpr-to-send)))
|
|
||||||
(define req-headers
|
|
||||||
(if include-credentials?
|
|
||||||
(list (make-basic-auth-credentials-header (session-email s)
|
|
||||||
(session-password s)))
|
|
||||||
'()))
|
|
||||||
(define response-port (post-pure-port request-url post-data req-headers))
|
|
||||||
(define raw-response (port->string response-port))
|
|
||||||
(close-input-port response-port)
|
|
||||||
(define reply (string->jsexpr raw-response))
|
|
||||||
(unless sensitive? (log-info "simple-json-rpc: reply ~v" reply))
|
|
||||||
reply)
|
|
||||||
52
src/jsonp-client.rkt
Normal file
52
src/jsonp-client.rkt
Normal file
|
|
@ -0,0 +1,52 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide jsonp-baseurl
|
||||||
|
jsonp-rpc!)
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
(require racket/format)
|
||||||
|
(require racket/port)
|
||||||
|
(require net/url)
|
||||||
|
(require net/uri-codec)
|
||||||
|
(require json)
|
||||||
|
(require "sessions.rkt")
|
||||||
|
|
||||||
|
(define jsonp-baseurl (make-parameter #f))
|
||||||
|
|
||||||
|
(define (jsonp-rpc! #:sensitive? [sensitive? #f]
|
||||||
|
#:include-credentials? [include-credentials? #t]
|
||||||
|
site-relative-url
|
||||||
|
original-parameters)
|
||||||
|
(define s (current-session))
|
||||||
|
(if sensitive?
|
||||||
|
(log-info "jsonp-rpc: sensitive request ~a" site-relative-url)
|
||||||
|
(log-info "jsonp-rpc: request ~a params ~a~a"
|
||||||
|
site-relative-url
|
||||||
|
original-parameters
|
||||||
|
(if include-credentials?
|
||||||
|
(if s
|
||||||
|
" +creds"
|
||||||
|
" +creds(missing)")
|
||||||
|
"")))
|
||||||
|
(define stamp (~a (inexact->exact (truncate (current-inexact-milliseconds)))))
|
||||||
|
(define callback-label (format "callback~a" stamp))
|
||||||
|
(define extraction-expr (format "^callback~a\\((.*)\\);$" stamp))
|
||||||
|
(let* ((parameters original-parameters)
|
||||||
|
(parameters (if (and include-credentials? s)
|
||||||
|
(append (list (cons 'email (session-email s))
|
||||||
|
(cons 'passwd (session-password s)))
|
||||||
|
parameters)
|
||||||
|
parameters))
|
||||||
|
(parameters (cons (cons 'callback callback-label) parameters)))
|
||||||
|
(define request-url
|
||||||
|
(string->url
|
||||||
|
(format "~a~a?~a"
|
||||||
|
(or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set"))
|
||||||
|
site-relative-url
|
||||||
|
(alist->form-urlencoded parameters))))
|
||||||
|
(define-values (body-port response-headers) (get-pure-port/headers request-url))
|
||||||
|
(define raw-response (port->string body-port))
|
||||||
|
(match-define (pregexp extraction-expr (list _ json)) raw-response)
|
||||||
|
(define reply (string->jsexpr json))
|
||||||
|
(unless sensitive? (log-info "jsonp-rpc: reply ~a" reply))
|
||||||
|
reply))
|
||||||
|
|
@ -8,10 +8,10 @@
|
||||||
(define (main [config (hash)])
|
(define (main [config (hash)])
|
||||||
(make-persistent-state '*config* (lambda () config))
|
(make-persistent-state '*config* (lambda () config))
|
||||||
(void (make-reloadable-entry-point 'refresh-packages! "packages.rkt"))
|
(void (make-reloadable-entry-point 'refresh-packages! "packages.rkt"))
|
||||||
(void (make-reloadable-entry-point 'rerender! "site.rkt"))
|
(void (make-reloadable-entry-point 'rerender-all! "site.rkt"))
|
||||||
(start-service #:port (hash-ref config 'port (lambda ()
|
(start-service #:port (hash-ref config 'port (lambda ()
|
||||||
(let ((port-str (getenv "SITE_PORT")))
|
(let ((port-str (getenv "SITE_PORT")))
|
||||||
(if port-str (string->number port-str) 7443))))
|
(if port-str (string->number port-str) 8443))))
|
||||||
#:ssl? (hash-ref config 'ssl? (lambda () #t))
|
#:ssl? (hash-ref config 'ssl? (lambda () #t))
|
||||||
#:reloadable? (hash-ref config 'reloadable? (lambda () (getenv "SITE_RELOADABLE")))
|
#:reloadable? (hash-ref config 'reloadable? (lambda () (getenv "SITE_RELOADABLE")))
|
||||||
(make-reloadable-entry-point 'request-handler "site.rkt")
|
(make-reloadable-entry-point 'request-handler "site.rkt")
|
||||||
|
|
|
||||||
|
|
@ -1,182 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(provide create-bucket
|
|
||||||
delete-bucket
|
|
||||||
ls/proc
|
|
||||||
put/bytes
|
|
||||||
get/bytes
|
|
||||||
delete)
|
|
||||||
|
|
||||||
(require file/glob)
|
|
||||||
(require file/md5)
|
|
||||||
(require net/uri-codec)
|
|
||||||
(require racket/date)
|
|
||||||
(require racket/dict)
|
|
||||||
(require racket/file)
|
|
||||||
(require racket/list)
|
|
||||||
(require racket/match)
|
|
||||||
(require racket/string)
|
|
||||||
(require "../config.rkt")
|
|
||||||
|
|
||||||
(module+ test (require rackunit))
|
|
||||||
|
|
||||||
(define (create-bucket bucket [location #f])
|
|
||||||
(define-values (full-bucket-path path-str) (split-bucket+path/create bucket))
|
|
||||||
(when path-str (error 'create-bucket "Do not include a path within the bucket: ~v" bucket)))
|
|
||||||
|
|
||||||
(define (delete-bucket bucket)
|
|
||||||
(define-values (full-bucket-path path-str) (split-bucket+path bucket))
|
|
||||||
(when path-str (error 'delete-bucket "Do not include a path within the bucket: ~v" bucket))
|
|
||||||
(delete-directory/files full-bucket-path #:must-exist? #f))
|
|
||||||
|
|
||||||
(define (ls/proc bucket+path proc init [max-each 1000] #:delimiter [delimiter #f])
|
|
||||||
(when delimiter (error 'ls/proc "mock/aws-s3 lacks support for non-#f delimiter"))
|
|
||||||
(define-values (full-bucket-path path-str) (split-bucket+path/create bucket+path))
|
|
||||||
(define all-files (for/list [(p (glob (build-path full-bucket-path "*")))]
|
|
||||||
(define-values (_dirp f _must-be-dir?) (split-path p))
|
|
||||||
f))
|
|
||||||
(define matching-files
|
|
||||||
(if path-str
|
|
||||||
(filter (lambda (f) (string-prefix? (unescape-filename f) path-str)) all-files)
|
|
||||||
all-files))
|
|
||||||
(for/fold [(acc init)] [(group (batch matching-files max-each))]
|
|
||||||
(proc init (map (lambda (f) (ListBucketResults-file full-bucket-path f)) group))))
|
|
||||||
|
|
||||||
(define (bucket+path->file-path bucket+path)
|
|
||||||
(define-values (full-bucket-path path-str) (split-bucket+path/create bucket+path))
|
|
||||||
(build-path full-bucket-path (escape-filename (or path-str ""))))
|
|
||||||
|
|
||||||
(define (put/bytes bucket+path data mime-type [heads '()])
|
|
||||||
(unless (dict-empty? heads)
|
|
||||||
(log-warning "mock put/bytes: ignoring non-empty 'heads' dictionary: ~v" heads))
|
|
||||||
(display-to-file data (bucket+path->file-path bucket+path) #:exists 'replace))
|
|
||||||
|
|
||||||
(define (get/bytes bucket+path [heads '()] [range-begin #f] [range-end #f])
|
|
||||||
;; Signals an error when the file doesn't exist, but not the same
|
|
||||||
;; error the real S3 package signals.
|
|
||||||
;;
|
|
||||||
(when (or range-begin range-end)
|
|
||||||
(error 'get/bytes "mock/aws-s3 lacks support for get ranges: ~v/~v" range-begin range-end))
|
|
||||||
(unless (dict-empty? heads)
|
|
||||||
(log-warning "mock get/bytes: ignoring non-empty 'heads' dictionary: ~v" heads))
|
|
||||||
(file->bytes (bucket+path->file-path bucket+path)))
|
|
||||||
|
|
||||||
(define (delete bucket+path)
|
|
||||||
(with-handlers [(exn:fail:filesystem? void)]
|
|
||||||
;; ^ ugh, can't distinguish file-not-found from any other error.
|
|
||||||
(delete-file (bucket+path->file-path bucket+path))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(define B "testbucket.mock.aws-s3")
|
|
||||||
(delete-bucket B)
|
|
||||||
(delete-bucket B) ;; it's supposed to be idempotent
|
|
||||||
(create-bucket B)
|
|
||||||
(create-bucket B) ;; should also be idempotent
|
|
||||||
(check-equal? (ls/proc (string-append B "/") append '()) '())
|
|
||||||
(put/bytes (string-append B "/foo/bar") #"/foo/bar" "text/plain")
|
|
||||||
(put/bytes (string-append B "/bar") #"/bar" "text/plain")
|
|
||||||
(check-equal? (get/bytes (string-append B "/foo/bar")) #"/foo/bar")
|
|
||||||
(check-equal? (get/bytes (string-append B "/bar")) #"/bar")
|
|
||||||
(check-match
|
|
||||||
(ls/proc (string-append B "/") append '())
|
|
||||||
`((Contents ()
|
|
||||||
(Key () "bar")
|
|
||||||
(LastModified () ,_)
|
|
||||||
(ETag () "\"" "6a764eebfa109a9ef76c113f3f608c6b" "\"")
|
|
||||||
(Size () "4")
|
|
||||||
(Owner ()
|
|
||||||
(ID () "0000000000000000000000000000000000000000000000000000000000000000")
|
|
||||||
(DisplayName () "mockuser"))
|
|
||||||
(StorageClass () "STANDARD"))
|
|
||||||
(Contents ()
|
|
||||||
(Key () "foo/bar")
|
|
||||||
(LastModified () ,_)
|
|
||||||
(ETag () "\"" "1df481b1ec67d4d8bec721f521d4937d" "\"")
|
|
||||||
(Size () "8")
|
|
||||||
(Owner ()
|
|
||||||
(ID () "0000000000000000000000000000000000000000000000000000000000000000")
|
|
||||||
(DisplayName () "mockuser"))
|
|
||||||
(StorageClass () "STANDARD"))))
|
|
||||||
(delete (string-append B "/zot")) ;; idempotent
|
|
||||||
(delete (string-append B "/bar"))
|
|
||||||
(check-match
|
|
||||||
(ls/proc (string-append B "/") append '())
|
|
||||||
`((Contents ()
|
|
||||||
(Key () "foo/bar")
|
|
||||||
(LastModified () ,_)
|
|
||||||
(ETag () "\"" "1df481b1ec67d4d8bec721f521d4937d" "\"")
|
|
||||||
(Size () "8")
|
|
||||||
(Owner ()
|
|
||||||
(ID () "0000000000000000000000000000000000000000000000000000000000000000")
|
|
||||||
(DisplayName () "mockuser"))
|
|
||||||
(StorageClass () "STANDARD"))))
|
|
||||||
(delete-bucket B))
|
|
||||||
|
|
||||||
(define (batch items batch-size)
|
|
||||||
(if (<= (length items) batch-size)
|
|
||||||
(if (null? items)
|
|
||||||
'()
|
|
||||||
(list items))
|
|
||||||
(let-values (((h t) (split-at items batch-size)))
|
|
||||||
(cons h (batch t batch-size)))))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(check-equal? (batch '() 3) '())
|
|
||||||
(check-equal? (batch '(x) 3) '((x)))
|
|
||||||
(check-equal? (batch '(x y z) 3) '((x y z)))
|
|
||||||
(check-equal? (batch '(x y z w) 3) '((x y z) (w)))
|
|
||||||
(check-equal? (batch '(x y z w a b c d) 3) '((x y z) (w a b) (c d)))
|
|
||||||
(check-equal? (batch '(x y z w a b c d e) 3) '((x y z) (w a b) (c d e))))
|
|
||||||
|
|
||||||
(define (ListBucketResults-file full-bucket-path f)
|
|
||||||
(define path (build-path full-bucket-path f))
|
|
||||||
(define checksum (md5 (file->bytes path)))
|
|
||||||
(define mtime (file-or-directory-modify-seconds path))
|
|
||||||
`(Contents ()
|
|
||||||
(Key () ,(unescape-filename f))
|
|
||||||
(LastModified () ,(parameterize ((date-display-format 'iso-8601))
|
|
||||||
(string-append (date->string (seconds->date mtime #f) #t)
|
|
||||||
".000Z")))
|
|
||||||
(ETag () "\"" ,(bytes->string/utf-8 checksum) "\"")
|
|
||||||
(Size () ,(number->string (file-size path)))
|
|
||||||
(Owner ()
|
|
||||||
(ID () "0000000000000000000000000000000000000000000000000000000000000000")
|
|
||||||
(DisplayName () "mockuser"))
|
|
||||||
(StorageClass () "STANDARD")))
|
|
||||||
|
|
||||||
(define (escape-filename f)
|
|
||||||
(unless (string? f) (error 'escape-filename "Expects a string: ~v" f))
|
|
||||||
(string->path (string-append "f-" (uri-encode f))))
|
|
||||||
|
|
||||||
(define (unescape-filename f)
|
|
||||||
(unless (path? f) (error 'escape-filename "Expects a path: ~v" f))
|
|
||||||
(match (path->string f)
|
|
||||||
[(regexp #px"f-(.*)" (list _ s)) (uri-decode s)]
|
|
||||||
[_ (error 'unescape-filename "Invalid filename: ~v" f)]))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(check-equal? (escape-filename "") (string->path "f-"))
|
|
||||||
(check-equal? (escape-filename "abc") (string->path "f-abc"))
|
|
||||||
(check-equal? (escape-filename "abc/def") (string->path "f-abc%2Fdef"))
|
|
||||||
(check-equal? (escape-filename "abc%def") (string->path "f-abc%25def"))
|
|
||||||
(check-equal? (unescape-filename (string->path "f-")) "")
|
|
||||||
(check-equal? (unescape-filename (string->path "f-abc")) "abc")
|
|
||||||
(check-equal? (unescape-filename (string->path "f-abc%2Fdef")) "abc/def")
|
|
||||||
(check-equal? (unescape-filename (string->path "f-abc%25def")) "abc%def"))
|
|
||||||
|
|
||||||
(define (split-bucket+path bucket+path)
|
|
||||||
(define elements0 (explode-path bucket+path))
|
|
||||||
(when (null? elements0) (error 'split-bucket+path/create "No bucket supplied"))
|
|
||||||
(define elements (if (equal? (string->path "/") (car elements0))
|
|
||||||
(cdr elements0)
|
|
||||||
elements0))
|
|
||||||
(match-define (cons bucket-path path-element-paths) elements)
|
|
||||||
(define full-bucket-path (build-path (var-path) "mock/aws-s3" bucket-path))
|
|
||||||
(values full-bucket-path
|
|
||||||
(and (pair? path-element-paths)
|
|
||||||
(path->string (apply build-path path-element-paths)))))
|
|
||||||
|
|
||||||
(define (split-bucket+path/create bucket+path)
|
|
||||||
(define-values (full-bucket-path path-str) (split-bucket+path bucket+path))
|
|
||||||
(make-directory* full-bucket-path)
|
|
||||||
(values full-bucket-path path-str))
|
|
||||||
355
src/package-catalog/NOTES.md
Normal file
355
src/package-catalog/NOTES.md
Normal file
|
|
@ -0,0 +1,355 @@
|
||||||
|
# New design
|
||||||
|
|
||||||
|
Packages have *authoritative* (human-managed) and *computed* keys in
|
||||||
|
the database. Then, separately, a static-rendered form of the package
|
||||||
|
description hashtable is computed from the database record.
|
||||||
|
|
||||||
|
Package ownership is determined by the presence or absence of an email
|
||||||
|
address in the package's `authors` list.
|
||||||
|
|
||||||
|
Authoritative keys:
|
||||||
|
|
||||||
|
- `name`, string
|
||||||
|
- `source`, quasi-URL
|
||||||
|
- `description`, string
|
||||||
|
- `tags`, list of strings
|
||||||
|
- `authors`, list of strings (email addresses)
|
||||||
|
- NB. existing code treats `author` as authoritative, with
|
||||||
|
`authors` computed
|
||||||
|
- If an email address is present in this list, then the
|
||||||
|
corresponding user may edit/delete the package, including
|
||||||
|
changing ownership of it.
|
||||||
|
- `versions`
|
||||||
|
- hash table mapping version name string (NOT `'default`!) to
|
||||||
|
hash table containing a `source` key mapping to a quasi-URL
|
||||||
|
- note that no default entry is to be present in this table:
|
||||||
|
instead, it's computed (for the benefit of 5.3.6 and older) as
|
||||||
|
part of the computation and static-rendering step.
|
||||||
|
- `ring`, number; 0, 1, or 2. Updateable by catalog admin only
|
||||||
|
- `last-edit`
|
||||||
|
|
||||||
|
Computed keys:
|
||||||
|
|
||||||
|
- `author`, string, space-joined `authors`
|
||||||
|
- `last-updated`
|
||||||
|
- `last-checked`
|
||||||
|
- `versions`
|
||||||
|
- each version gets its checksum computed, and placed in a
|
||||||
|
`checksum` key alongside its `source` key.
|
||||||
|
- `checksum-error`
|
||||||
|
- `#f` if no error; otherwise, a string. In the existing code,
|
||||||
|
the first checksum-computation to yield an error is stored
|
||||||
|
here, and the remainder of the computations are abandoned. In
|
||||||
|
the new code, this should store a record of all the failed
|
||||||
|
computations.
|
||||||
|
- `checksum`
|
||||||
|
- checksum for the top-level (default) source
|
||||||
|
- `conflicts`
|
||||||
|
- `modules`
|
||||||
|
- `dependencies`
|
||||||
|
|
||||||
|
In the rendered form of a package record, the default source and
|
||||||
|
checksum and the versions table are arranged differently. If a version
|
||||||
|
named `"5.3.6"` exists, its source (and checksum) are used at
|
||||||
|
top-level; and either way, the default source and checksum are copied
|
||||||
|
into a version named `'default`. In addition, each version in the
|
||||||
|
`versions` table (including `'default`) has a `source_url` field added
|
||||||
|
to it, with an HTTP(S) URL for humans to visit heuristically derived
|
||||||
|
from the `source` quasi-URL.
|
||||||
|
|
||||||
|
The rendered form also has the following additional top-level keys:
|
||||||
|
|
||||||
|
- `build`, a hash-table:
|
||||||
|
- currently includes:
|
||||||
|
- `success-log`
|
||||||
|
- `failure-log`
|
||||||
|
- `dep-failure-log`
|
||||||
|
- `conflicts-log`, either `#f`, a build-host-relative URL
|
||||||
|
string pointing at the conflicts log, or `(list/c "indirect"
|
||||||
|
string?)`, which again seems to point at some kind of log
|
||||||
|
but flagged somehow? Ah, this kind of indirect report means
|
||||||
|
that one of the dependencies of the package has a conflict.
|
||||||
|
- `docs`, a list of
|
||||||
|
- `(list/c (or/c "main" "extract" "salvage" string?
|
||||||
|
string?)`, where the last string is the URL-fragment
|
||||||
|
relative to the build host where the rendered
|
||||||
|
documentation is stored and the penultimate string is the
|
||||||
|
name of this chunk of documentation.
|
||||||
|
- `(list/c "none" string?)`, where the last string is the
|
||||||
|
name of the chunk of documentation, but no rendered form
|
||||||
|
is available.
|
||||||
|
- should also include:
|
||||||
|
- `test-success-log`
|
||||||
|
- `test-failure-log`
|
||||||
|
- `min-failure-log` - records problems due to missing
|
||||||
|
environmental dependencies. See
|
||||||
|
http://pkg-build.racket-lang.org/
|
||||||
|
- `search-terms`, a hash-table where each present key has `#t` as its
|
||||||
|
value. Each key is a symbol. Keys that may be present:
|
||||||
|
- one per tag in the package's `tags` list (as symbols)
|
||||||
|
- `ring:N` where N corresponds to the package's ring
|
||||||
|
- `author:X` where X is drawn from the package's `authors` list
|
||||||
|
- `:no-tag:` if `tags` is empty
|
||||||
|
- `:error:` if `checksum-error` is non-false
|
||||||
|
- `:no-desc:` if `description` is the empty string
|
||||||
|
- `:conflicts:` if `conflicts` is not the empty list
|
||||||
|
- `:build-success:` if the success-log is non-false
|
||||||
|
- `:build-fail:` if the failure-log is non-false
|
||||||
|
- `:build-dep-fail:` if the dep-failure-log is non-false
|
||||||
|
- `:build-conflicts:` if the conflicts-log is non-false
|
||||||
|
- `:docs:` if some docs exist and not all of them are `doc/none` instances
|
||||||
|
- `:docs-error:` if some docs exist but none of them is a `doc/main` instance
|
||||||
|
|
||||||
|
# JSON variations on various records
|
||||||
|
|
||||||
|
- Racket lists, numbers and booleans map to JSON lists, numbers and booleans
|
||||||
|
- Racket strings and symbols map to JSON strings
|
||||||
|
- Racket keywords map to a JSON hash with key "kw" and value the
|
||||||
|
result of `keyword->string` on the keyword
|
||||||
|
- Racket hash tables map to JSON hashes; keys may be either strings or symbols.
|
||||||
|
|
||||||
|
# Users
|
||||||
|
|
||||||
|
User records are currently just a file containing only their bcrypted
|
||||||
|
passwords. They should probably also have an `administrator?` flag
|
||||||
|
associated with them.
|
||||||
|
|
||||||
|
# Notes on existing package catalog code
|
||||||
|
|
||||||
|
## Existing API
|
||||||
|
|
||||||
|
The JSONP requests are all GET requests. Clients include a spurious
|
||||||
|
unique parameter to avoid cache problems.
|
||||||
|
|
||||||
|
- `/jsonp/authenticate` - registration/validation/login
|
||||||
|
- `email`
|
||||||
|
- `passwd`
|
||||||
|
- `code` - optional; used only when email not registered or
|
||||||
|
password incorrect.
|
||||||
|
|
||||||
|
- `/jsonp/update` - causes a refresh of all packages editable by the current user
|
||||||
|
|
||||||
|
- `/jsonp/package/del` - delete a package, if current user is an author
|
||||||
|
- `pkg`
|
||||||
|
|
||||||
|
- `/jsonp/package/modify` - create or update (including renaming) a package
|
||||||
|
- `pkg` - old/existing package name; empty to create a package
|
||||||
|
- `name` - new/updated name
|
||||||
|
- `description`
|
||||||
|
- `source`
|
||||||
|
|
||||||
|
- `/jsonp/package/version/add` - add a non-default version to a package
|
||||||
|
- `pkg`
|
||||||
|
- `version`
|
||||||
|
- `source`
|
||||||
|
|
||||||
|
- `/jsonp/package/version/del` - remove a non-default version from a package
|
||||||
|
- `pkg`
|
||||||
|
- `version`
|
||||||
|
|
||||||
|
- `/jsonp/package/tag/add` - add a tag to a package
|
||||||
|
- `pkg`
|
||||||
|
- `tag`
|
||||||
|
|
||||||
|
- `/jsonp/package/tag/del` - remove a tag from a package
|
||||||
|
- `pkg`
|
||||||
|
- `tag`
|
||||||
|
|
||||||
|
- `/jsonp/package/author/add` - add an author to a package
|
||||||
|
- `pkg`
|
||||||
|
- `author`
|
||||||
|
|
||||||
|
- `/jsonp/package/author/del` - remove an author from a package
|
||||||
|
- `pkg`
|
||||||
|
- `author`
|
||||||
|
|
||||||
|
- `/jsonp/package/curate` - change the ring of a package. Only
|
||||||
|
accessible to site administrators.
|
||||||
|
- `pkg`
|
||||||
|
- `ring` - string form of new ring number; e.g. `"2"`.
|
||||||
|
|
||||||
|
- `/jsonp/notice` - retrieves the current notice text
|
||||||
|
|
||||||
|
The following request is not JSONP, and requires that the method be
|
||||||
|
POST, not GET:
|
||||||
|
|
||||||
|
- `/api/upload` - accessible only to site administrators. Uploads
|
||||||
|
multiple raw package descriptions at once.
|
||||||
|
- POST data is read as Racket data. It is to be a `(list/c string?
|
||||||
|
string? (hash/c string? package/c))`, where `package/c` is a
|
||||||
|
hashtable containing a bunch of keys to be merged with any
|
||||||
|
existing keys in the package database.
|
||||||
|
|
||||||
|
## Package details
|
||||||
|
|
||||||
|
Each package is given:
|
||||||
|
|
||||||
|
- `checksum`
|
||||||
|
- `checksum-error`
|
||||||
|
|
||||||
|
The static-rendered version adds:
|
||||||
|
|
||||||
|
- `default` version info, with
|
||||||
|
- `source` from the main table
|
||||||
|
- `checksum` from the main table
|
||||||
|
- `source_url` computed from the adjacent source field
|
||||||
|
- `authors` list, presumably split from `author` field?
|
||||||
|
- `build` table
|
||||||
|
- `search-terms` table
|
||||||
|
|
||||||
|
From the raw DB:
|
||||||
|
|
||||||
|
#hasheq((name . "ansi")
|
||||||
|
(source . "github://github.com/tonyg/racket-ansi/master")
|
||||||
|
(last-updated . 1420421711)
|
||||||
|
(last-edit . 1418835706)
|
||||||
|
(last-checked . 1421174660)
|
||||||
|
(versions . #hash())
|
||||||
|
(tags . ("terminal"))
|
||||||
|
(checksum-error . #f)
|
||||||
|
(ring . 1)
|
||||||
|
(checksum . "0f9cc06dffa81100df9617ba9deeb46382013e90")
|
||||||
|
(author . "tonygarnockjones@gmail.com")
|
||||||
|
(conflicts . ())
|
||||||
|
(description . "ANSI and VT10x escape sequences for Racket.")
|
||||||
|
(modules . ((lib "ansi/ansi.rkt")
|
||||||
|
(lib "ansi/test-modes.rkt")
|
||||||
|
(lib "ansi/test-raw.rkt")
|
||||||
|
(lib "ansi/test-ansi.rkt")
|
||||||
|
(lib "ansi/lcd-terminal.rkt")
|
||||||
|
(lib "ansi/private/install.rkt")
|
||||||
|
(lib "ansi/main.rkt")))
|
||||||
|
(dependencies . ("base" "dynext-lib" "rackunit-lib")))
|
||||||
|
|
||||||
|
From the static-rendered version:
|
||||||
|
|
||||||
|
#hasheq((name . "ansi")
|
||||||
|
(source . "github://github.com/tonyg/racket-ansi/master")
|
||||||
|
(last-updated . 1420421711)
|
||||||
|
(last-edit . 1418835706)
|
||||||
|
(last-checked . 1421174660)
|
||||||
|
(versions
|
||||||
|
. #hash((default
|
||||||
|
. #hasheq((source . "github://github.com/tonyg/racket-ansi/master")
|
||||||
|
(checksum . "0f9cc06dffa81100df9617ba9deeb46382013e90")
|
||||||
|
(source_url . "http://github.com/tonyg/racket-ansi/tree/master")))))
|
||||||
|
(tags . ("terminal"))
|
||||||
|
(checksum-error . #f)
|
||||||
|
(ring . 1)
|
||||||
|
(checksum . "0f9cc06dffa81100df9617ba9deeb46382013e90")
|
||||||
|
(author . "tonygarnockjones@gmail.com")
|
||||||
|
(conflicts . ())
|
||||||
|
(description . "ANSI and VT10x escape sequences for Racket.")
|
||||||
|
(modules . ((lib "ansi/ansi.rkt")
|
||||||
|
(lib "ansi/test-modes.rkt")
|
||||||
|
(lib "ansi/test-raw.rkt")
|
||||||
|
(lib "ansi/test-ansi.rkt")
|
||||||
|
(lib "ansi/lcd-terminal.rkt")
|
||||||
|
(lib "ansi/private/install.rkt")
|
||||||
|
(lib "ansi/main.rkt")))
|
||||||
|
(dependencies . ("base" "dynext-lib" "rackunit-lib"))
|
||||||
|
(authors . ("tonygarnockjones@gmail.com"))
|
||||||
|
(build
|
||||||
|
. #hash((docs . ())
|
||||||
|
(success-log . "server/built/install/ansi.txt")
|
||||||
|
(failure-log . #f)
|
||||||
|
(dep-failure-log . #f)
|
||||||
|
(conflicts-log . #f)))
|
||||||
|
(search-terms
|
||||||
|
. #hasheq((:build-success: . #t)
|
||||||
|
(terminal . #t)
|
||||||
|
(ring:1 . #t)
|
||||||
|
(author:tonygarnockjones@gmail.com . #t))))
|
||||||
|
|
||||||
|
|
||||||
|
A richer raw DB record:
|
||||||
|
|
||||||
|
#hash((name . "racket-lib")
|
||||||
|
(source . "git://github.com/plt/racket/?path=pkgs/racket-lib")
|
||||||
|
(author . "eli@racket-lang.org jay@racket-lang.org matthias@racket-lang.org mflatt@racket-lang.org robby@racket-lang.org ryanc@racket-lang.org samth@racket-lang.org")
|
||||||
|
(last-updated . 1420948817)
|
||||||
|
(last-edit . 1418046514)
|
||||||
|
(last-checked . 1421095037)
|
||||||
|
(versions . #hash(("5.3.5" . #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip") (checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
|
||||||
|
("5.3.4" . #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip") (checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
|
||||||
|
("5.3.6" . #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip") (checksum . "9f098dddde7f217879070816090c1e8e74d49432")))))
|
||||||
|
(tags . ("main-distribution"))
|
||||||
|
(checksum-error . #f)
|
||||||
|
(ring . 0)
|
||||||
|
(checksum . "486debd70483427f0a90b53cb9c52cf51e899a37")
|
||||||
|
(description . "Combines platform-specific native libraries that are useful for base Racket")
|
||||||
|
(modules . ())
|
||||||
|
(dependencies . (("racket-win32-i386-2" #:platform "win32\\i386") ("racket-win32-x86_64-2" #:platform "win32\\x86_64") ("racket-x86_64-linux-natipkg-2" #:platform "x86_64-linux-natipkg") ("db-ppc-macosx" #:platform "ppc-macosx") ("db-win32-i386" #:platform "win32\\i386") ("db-win32-x86_64" #:platform "win32\\x86_64") ("db-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg") ("com-win32-i386" #:platform "win32\\i386") ("com-win32-x86_64" #:platform "win32\\x86_64")))
|
||||||
|
(conflicts . ()))
|
||||||
|
|
||||||
|
A richer static-rendered description:
|
||||||
|
|
||||||
|
#hash((name . "racket-lib")
|
||||||
|
(source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
|
||||||
|
(author . "eli@racket-lang.org jay@racket-lang.org matthias@racket-lang.org mflatt@racket-lang.org robby@racket-lang.org ryanc@racket-lang.org samth@racket-lang.org")
|
||||||
|
(last-updated . 1421178060)
|
||||||
|
(last-checked . 1421178060)
|
||||||
|
(last-edit . 1418046514)
|
||||||
|
(versions
|
||||||
|
. #hash((default
|
||||||
|
. #hasheq((source . "git://github.com/plt/racket/?path=pkgs/racket-lib")
|
||||||
|
(checksum . "9f3c82c30ad1741d35c11ea3e1bb510119e7f476")
|
||||||
|
(source_url . "git://github.com/plt/racket/?path=pkgs/racket-lib")))
|
||||||
|
("5.3.5"
|
||||||
|
. #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
|
||||||
|
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")
|
||||||
|
(source_url . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")))
|
||||||
|
("5.3.4"
|
||||||
|
. #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
|
||||||
|
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")
|
||||||
|
(source_url . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")))
|
||||||
|
("5.3.6"
|
||||||
|
. #hash((source . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
|
||||||
|
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")
|
||||||
|
(source_url . "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")))))
|
||||||
|
(tags . ("main-distribution"))
|
||||||
|
(checksum-error . #f)
|
||||||
|
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")
|
||||||
|
(ring . 0)
|
||||||
|
(description . "Combines platform-specific native libraries that are useful for base Racket")
|
||||||
|
(modules . ())
|
||||||
|
(dependencies . (("racket-win32-i386-2" #:platform "win32\\i386")
|
||||||
|
("racket-win32-x86_64-2" #:platform "win32\\x86_64")
|
||||||
|
("racket-x86_64-linux-natipkg-2" #:platform "x86_64-linux-natipkg")
|
||||||
|
("db-ppc-macosx" #:platform "ppc-macosx")
|
||||||
|
("db-win32-i386" #:platform "win32\\i386")
|
||||||
|
("db-win32-x86_64" #:platform "win32\\x86_64")
|
||||||
|
("db-x86_64-linux-natipkg" #:platform "x86_64-linux-natipkg")
|
||||||
|
("com-win32-i386" #:platform "win32\\i386")
|
||||||
|
("com-win32-x86_64" #:platform "win32\\x86_64")))
|
||||||
|
(conflicts . ())
|
||||||
|
(authors . ("eli@racket-lang.org" "jay@racket-lang.org" "matthias@racket-lang.org" "mflatt@racket-lang.org" "robby@racket-lang.org" "ryanc@racket-lang.org" "samth@racket-lang.org"))
|
||||||
|
(build . #hash((docs . ())
|
||||||
|
(success-log . #f)
|
||||||
|
(failure-log . #f)
|
||||||
|
(dep-failure-log . #f)
|
||||||
|
(conflicts-log . #f)))
|
||||||
|
(search-terms . #hasheq((author:mflatt@racket-lang.org . #t)
|
||||||
|
(author:eli@racket-lang.org . #t)
|
||||||
|
(main-distribution . #t)
|
||||||
|
(ring:0 . #t)
|
||||||
|
(author:robby@racket-lang.org . #t)
|
||||||
|
(author:samth@racket-lang.org . #t)
|
||||||
|
(author:ryanc@racket-lang.org . #t)
|
||||||
|
(author:jay@racket-lang.org . #t)
|
||||||
|
(author:matthias@racket-lang.org . #t))))
|
||||||
|
|
||||||
|
## Summary.rktd from the build server
|
||||||
|
|
||||||
|
Sometimes only the `docs` key is present.
|
||||||
|
|
||||||
|
("rmacs" . #hash((author . "tonygarnockjones@gmail.com")
|
||||||
|
(docs . ())
|
||||||
|
(success-log . "server/built/install/rmacs.txt")
|
||||||
|
(failure-log . #f)
|
||||||
|
(dep-failure-log . #f)
|
||||||
|
(test-success-log . #f)
|
||||||
|
(test-failure-log . "server/built/test-fail/rmacs.txt")
|
||||||
|
(min-failure-log . #f)
|
||||||
|
(conflicts-log . #f)))
|
||||||
|
|
||||||
2
src/package-catalog/api.rkt
Normal file
2
src/package-catalog/api.rkt
Normal file
|
|
@ -0,0 +1,2 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
52
src/package-catalog/db.rkt
Normal file
52
src/package-catalog/db.rkt
Normal file
|
|
@ -0,0 +1,52 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide make-db
|
||||||
|
db?
|
||||||
|
db-has-key?
|
||||||
|
db-ref
|
||||||
|
db-set!
|
||||||
|
db-remove!
|
||||||
|
db-keys)
|
||||||
|
|
||||||
|
(require racket/file)
|
||||||
|
(require file/sha1)
|
||||||
|
|
||||||
|
(struct db (name path serializer deserializer) #:transparent)
|
||||||
|
|
||||||
|
(define (make-db name path serializer deserializer)
|
||||||
|
(make-directory* path)
|
||||||
|
(db name path serializer deserializer))
|
||||||
|
|
||||||
|
(define (check-key what db key)
|
||||||
|
(unless (string? key)
|
||||||
|
(error what "Invalid key for db ~a: ~v" (db-name db) key)))
|
||||||
|
|
||||||
|
;; We avoid potential filesystem subdirectory escape attacks by
|
||||||
|
;; encoding key paths into hex. Special characters in keys are thus
|
||||||
|
;; permitted and rendered harmless.
|
||||||
|
(define (key->path what db key)
|
||||||
|
(check-key what db key)
|
||||||
|
(build-path (db-path db) (bytes->hex-string (string->bytes/utf-8 key))))
|
||||||
|
|
||||||
|
(define (db-has-key? db key)
|
||||||
|
(file-exists? (key->path 'db-has-key? db key)))
|
||||||
|
|
||||||
|
(define (db-ref db key default)
|
||||||
|
(define p (key->path 'db-ref db key))
|
||||||
|
(cond
|
||||||
|
[(file-exists? p) ((db-deserializer db) (file->value p))]
|
||||||
|
[(procedure? default) (default)]
|
||||||
|
[else default]))
|
||||||
|
|
||||||
|
(define (db-set! db key value)
|
||||||
|
(define p (key->path 'db-set! db key))
|
||||||
|
(write-to-file ((db-serializer db) value) p #:exists 'replace))
|
||||||
|
|
||||||
|
(define (db-remove! db key)
|
||||||
|
(define p (key->path 'db-remove! db key))
|
||||||
|
(when (file-exists? p)
|
||||||
|
(delete-file p)))
|
||||||
|
|
||||||
|
(define (db-keys db)
|
||||||
|
(map (lambda (p) (bytes->string/utf-8 (hex-string->bytes (path->string p))))
|
||||||
|
(directory-list (db-path db))))
|
||||||
7
src/package-catalog/main.rkt
Normal file
7
src/package-catalog/main.rkt
Normal file
|
|
@ -0,0 +1,7 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide (all-from-out "structs.rkt")
|
||||||
|
(all-from-out "source.rkt"))
|
||||||
|
|
||||||
|
(require "structs.rkt")
|
||||||
|
(require "source.rkt")
|
||||||
182
src/package-catalog/source.rkt
Normal file
182
src/package-catalog/source.rkt
Normal file
|
|
@ -0,0 +1,182 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide (struct-out url-source)
|
||||||
|
(struct-out git-source)
|
||||||
|
package-source?
|
||||||
|
string->package-source
|
||||||
|
package-source->string
|
||||||
|
github-source?
|
||||||
|
github-user+repo)
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
(require net/url)
|
||||||
|
(require pkg/name)
|
||||||
|
(require pkg/private/repo-path)
|
||||||
|
(require (only-in racket/string string-join))
|
||||||
|
|
||||||
|
(struct url-source (url ;; String
|
||||||
|
)
|
||||||
|
#:prefab)
|
||||||
|
(struct git-source (host ;; String
|
||||||
|
port ;; Nat or #f
|
||||||
|
repo ;; String (e.g. for github.com, "/user/repo")
|
||||||
|
branch ;; String
|
||||||
|
path ;; Relative URL String
|
||||||
|
)
|
||||||
|
#:prefab)
|
||||||
|
|
||||||
|
(define (package-source? x)
|
||||||
|
(or (url-source? x)
|
||||||
|
(git-source? x)))
|
||||||
|
|
||||||
|
(define (string->package-source str)
|
||||||
|
(define u (string->url str))
|
||||||
|
(define-values (_name type) (package-source->name+type str #f))
|
||||||
|
(cond
|
||||||
|
[(memq type '(git github))
|
||||||
|
(define-values (_type host port repo branch path)
|
||||||
|
(if (equal? "github" (url-scheme u))
|
||||||
|
(match (split-github-url u)
|
||||||
|
[(list* user repo branch path)
|
||||||
|
(values 'github "github.com" #f (string-append user "/" repo) branch path)]
|
||||||
|
[(list user repo)
|
||||||
|
(values 'github "github.com" #f (string-append user "/" repo) "master" '())]
|
||||||
|
[_ (error 'string->package-source "Invalid github url: ~v" str)])
|
||||||
|
(split-git-url u)))
|
||||||
|
;; TODO: clean this up in repo-path.rkt
|
||||||
|
(git-source host
|
||||||
|
port
|
||||||
|
repo
|
||||||
|
branch
|
||||||
|
(string-join path "/"))]
|
||||||
|
;; [(and (member (url-scheme u) '("http" "https"))
|
||||||
|
;; (equal? (url-host u) "github.com"))
|
||||||
|
;; ;; ... parse the path, etc., and turn it into a git-source ...
|
||||||
|
;; ]
|
||||||
|
[else
|
||||||
|
(url-source (url->string u))]))
|
||||||
|
|
||||||
|
(define (package-source->string s)
|
||||||
|
(match s
|
||||||
|
[(url-source u) u]
|
||||||
|
[(git-source host port repo branch path)
|
||||||
|
(url->string (url "git"
|
||||||
|
#f
|
||||||
|
host
|
||||||
|
port
|
||||||
|
#t
|
||||||
|
(url-path (path->url repo))
|
||||||
|
(if (string=? path "")
|
||||||
|
'()
|
||||||
|
(list (cons 'path path)))
|
||||||
|
branch))]))
|
||||||
|
|
||||||
|
(define (github-source? s)
|
||||||
|
(unless (package-source? s) (error 'github-source? "Expected package-source: ~v" s))
|
||||||
|
(match s
|
||||||
|
[(git-source "github.com" #f (regexp "^([^/]+)/([^/]+)/*$") _ _) #t]
|
||||||
|
[_ #f]))
|
||||||
|
|
||||||
|
(define (github-user+repo s)
|
||||||
|
(unless (github-source? s) (error 'github-user+repo "Expected github package-source: ~v" s))
|
||||||
|
(match (regexp-match "^([^/]+)/([^/]+)/*$" (git-source-repo s))
|
||||||
|
[(list _ user repo) (values user repo)]
|
||||||
|
[#f (error 'github-user+repo "Invalid github repo path: ~v" (git-source-repo s))]))
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(require rackunit)
|
||||||
|
|
||||||
|
(check-equal? (string->package-source "https://github.com/user/repo")
|
||||||
|
(url-source "https://github.com/user/repo"))
|
||||||
|
(check-equal? (string->package-source "http://example.com/some/path/to/package.zip")
|
||||||
|
(url-source "http://example.com/some/path/to/package.zip"))
|
||||||
|
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" ""))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo#master")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" ""))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo?path=/subdir1/subdir2#master")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo?path=subdir1/subdir2#master")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo?path=%2fsubdir1%2fsubdir2#master")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo?path=subdir1%2fsubdir2#master")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo#otherbranch")
|
||||||
|
(git-source "github.com" #f "user/repo" "otherbranch" ""))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo?path=/subdir1/subdir2#otherbranch")
|
||||||
|
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo?path=subdir1/subdir2#otherbranch")
|
||||||
|
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo?path=%2fsubdir1%2fsubdir2#otherbranch")
|
||||||
|
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
|
||||||
|
(check-equal? (string->package-source "git://github.com/user/repo?path=subdir1%2fsubdir2#otherbranch")
|
||||||
|
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
|
||||||
|
|
||||||
|
(check-exn #px"Invalid github url"
|
||||||
|
(lambda () (string->package-source "github://github.com/user/")))
|
||||||
|
|
||||||
|
(check-equal? (string->package-source "github://github.com/user/repo")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" ""))
|
||||||
|
(check-equal? (string->package-source "github://github.com/user/repo/")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" ""))
|
||||||
|
(check-equal? (string->package-source "github://github.com/user/repo/master")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" ""))
|
||||||
|
(check-equal? (string->package-source "github://github.com/user/repo/master/")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" ""))
|
||||||
|
(check-equal? (string->package-source "github://github.com/user/repo/master/subdir1/subdir2")
|
||||||
|
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
|
||||||
|
(check-equal? (string->package-source "github://github.com/user/repo/otherbranch")
|
||||||
|
(git-source "github.com" #f "user/repo" "otherbranch" ""))
|
||||||
|
(check-equal? (string->package-source "github://github.com/user/repo/otherbranch/")
|
||||||
|
(git-source "github.com" #f "user/repo" "otherbranch" ""))
|
||||||
|
(check-equal? (string->package-source "github://github.com/user/repo/otherbranch/subdir1/subdir2")
|
||||||
|
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
|
||||||
|
|
||||||
|
(check-equal? (package-source->string
|
||||||
|
(git-source "github.com" #f "user/repo" "master" "subdir1/subdir2"))
|
||||||
|
"git://github.com/user/repo?path=subdir1%2Fsubdir2#master")
|
||||||
|
(check-equal? (package-source->string
|
||||||
|
(git-source "github.com" #f "user/repo" "otherbranch" "subdir1/subdir2"))
|
||||||
|
"git://github.com/user/repo?path=subdir1%2Fsubdir2#otherbranch")
|
||||||
|
|
||||||
|
(define (roundtrip str)
|
||||||
|
(check-equal? (package-source->string (string->package-source str)) str))
|
||||||
|
|
||||||
|
(roundtrip "https://github.com/user/repo")
|
||||||
|
(roundtrip "http://example.com/some/path/to/package.zip")
|
||||||
|
(roundtrip "git://github.com/user/repo#master")
|
||||||
|
(roundtrip "git://github.com/user/repo#otherbranch")
|
||||||
|
|
||||||
|
(check-equal? (github-source? (string->package-source "github://github.com/user/repo")) #t)
|
||||||
|
(check-equal? (github-source? (string->package-source "github://github.com/user/repo/master")) #t)
|
||||||
|
(check-equal? (github-source? (string->package-source "github://github.com/user/repo/master/subdir")) #t)
|
||||||
|
|
||||||
|
(check-equal? (github-source? (string->package-source "git://github.com/user/repo")) #t)
|
||||||
|
(check-equal? (github-source? (string->package-source "git://github.com/user/repo#master")) #t)
|
||||||
|
(check-equal? (github-source? (string->package-source "git://github.com/user/repo?path=subdir#master")) #t)
|
||||||
|
|
||||||
|
(check-equal? (github-source? (string->package-source "git://github.com/user/repo/more")) #f)
|
||||||
|
(check-equal? (github-source? (string->package-source "git://github.com/user/repo/more#master")) #f)
|
||||||
|
(check-equal? (github-source? (string->package-source "git://github.com/user/repo/more?path=subdir#master")) #f)
|
||||||
|
|
||||||
|
(check-equal? (github-source? (string->package-source "git://github.com/user")) #f)
|
||||||
|
(check-equal? (github-source? (string->package-source "git://github.com/user#master")) #f)
|
||||||
|
(check-equal? (github-source? (string->package-source "git://github.com/user?path=subdir#master")) #f)
|
||||||
|
|
||||||
|
(check-equal? (github-source? (string->package-source "git://example.com/user/repo")) #f)
|
||||||
|
(check-equal? (github-source? (string->package-source "git://example.com/user/repo#master")) #f)
|
||||||
|
(check-equal? (github-source? (string->package-source "git://example.com/user/repo?path=subdir#master")) #f)
|
||||||
|
|
||||||
|
(define (extract-user+repo str)
|
||||||
|
(define-values (user repo) (github-user+repo (string->package-source str)))
|
||||||
|
(list user repo))
|
||||||
|
|
||||||
|
(check-equal? (extract-user+repo "github://github.com/user/repo") (list "user" "repo"))
|
||||||
|
(check-equal? (extract-user+repo "github://github.com/user/repo/master") (list "user" "repo"))
|
||||||
|
(check-equal? (extract-user+repo "github://github.com/user/repo/master/subdir") (list "user" "repo"))
|
||||||
|
(check-equal? (extract-user+repo "git://github.com/user/repo") (list "user" "repo"))
|
||||||
|
(check-equal? (extract-user+repo "git://github.com/user/repo#master") (list "user" "repo"))
|
||||||
|
(check-equal? (extract-user+repo "git://github.com/user/repo?path=subdir#master") (list "user" "repo"))
|
||||||
|
)
|
||||||
269
src/package-catalog/structs.rkt
Normal file
269
src/package-catalog/structs.rkt
Normal file
|
|
@ -0,0 +1,269 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide (struct-out package)
|
||||||
|
package-author
|
||||||
|
serialize-package
|
||||||
|
deserialize-package
|
||||||
|
|
||||||
|
(struct-out computed-info)
|
||||||
|
serialize-computed-info
|
||||||
|
deserialize-computed-info
|
||||||
|
|
||||||
|
(struct-out github-info)
|
||||||
|
serialize-github-info
|
||||||
|
deserialize-github-info)
|
||||||
|
|
||||||
|
(require racket/set)
|
||||||
|
(require racket/match)
|
||||||
|
(require (only-in racket/string string-split string-join))
|
||||||
|
(require "source.rkt")
|
||||||
|
|
||||||
|
;; A Time here is milliseconds-since-epoch - e.g. a result from
|
||||||
|
;; (current-inexact-milliseconds).
|
||||||
|
|
||||||
|
(define package-format-version 0) ;; IMPORTANT - UPDATE THIS AND CHANGE SERIALIZATION
|
||||||
|
;; WHENEVER THE STRUCT DEFINITION FOR package CHANGES
|
||||||
|
(struct package (name ;; String
|
||||||
|
source ;; PackageSource
|
||||||
|
description ;; String
|
||||||
|
tags ;; (Listof String)
|
||||||
|
authors ;; (Listof String)
|
||||||
|
versions ;; (HashTable String PackageSource)
|
||||||
|
ring ;; Nat
|
||||||
|
last-edit ;; Time
|
||||||
|
)
|
||||||
|
#:prefab)
|
||||||
|
|
||||||
|
(define (package-author p)
|
||||||
|
(string-join (package-authors p) " "))
|
||||||
|
|
||||||
|
(define computed-info-format-version 0) ;; IMPORTANT - UPDATE THIS AND CHANGE SERIALIZATION
|
||||||
|
;; WHENEVER THE STRUCT DEFINITION FOR computed-info CHANGES
|
||||||
|
(struct computed-info (package-name ;; String
|
||||||
|
last-updated ;; Time, most recent change to package source
|
||||||
|
last-checked ;; Time, when package source was most recently checked
|
||||||
|
checksums ;; (HashTable String String), including "default" key
|
||||||
|
checksum-errors ;; (HashTable String String), including "default" key
|
||||||
|
github-info ;; GithubInfo or #f
|
||||||
|
declared-conflicts ;; (Setof String), package names
|
||||||
|
modules ;; (Listof ModulePath)
|
||||||
|
dependencies ;; (Listof String), package names
|
||||||
|
)
|
||||||
|
#:prefab)
|
||||||
|
|
||||||
|
(define github-info-format-version 0) ;; IMPORTANT - UPDATE THIS AND CHANGE SERIALIZATION
|
||||||
|
;; WHENEVER THE STRUCT DEFINITION FOR github-info CHANGES
|
||||||
|
(struct github-info (readme-exists? ;; Boolean
|
||||||
|
)
|
||||||
|
#:prefab)
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
;; This is the kind of stupid repetitive code our struct system should
|
||||||
|
;; allow us to automate.
|
||||||
|
|
||||||
|
(define (serialize-package p)
|
||||||
|
(match-define (package name source description tags authors versions ring last-edit) p)
|
||||||
|
(list 'package package-format-version
|
||||||
|
(hash 'name name
|
||||||
|
'source (package-source->string source)
|
||||||
|
'description description
|
||||||
|
'tags tags
|
||||||
|
'authors authors
|
||||||
|
'versions (for/hash [((version source) (in-hash versions))]
|
||||||
|
(values version (package-source->string source)))
|
||||||
|
'ring ring
|
||||||
|
'last-edit last-edit)))
|
||||||
|
|
||||||
|
(define (deserialize-package p)
|
||||||
|
(match p
|
||||||
|
[(? hash?)
|
||||||
|
(package (hash-ref p 'name)
|
||||||
|
(string->package-source (hash-ref p 'source))
|
||||||
|
(hash-ref p 'description "")
|
||||||
|
(hash-ref p 'tags '())
|
||||||
|
(string-split (hash-ref p 'author ""))
|
||||||
|
(for/hash [((version fields) (in-hash (hash-ref p 'versions (hash))))]
|
||||||
|
(values version (string->package-source (hash-ref fields 'source))))
|
||||||
|
(hash-ref p 'ring 2)
|
||||||
|
(hash-ref p 'last-edit 0))]
|
||||||
|
[(list 'package 0
|
||||||
|
(hash-table ['name (? string? name)]
|
||||||
|
['source (? string? source0)]
|
||||||
|
['description (? string? description)]
|
||||||
|
['tags (and (list (? string?) ...) tags)]
|
||||||
|
['authors (and (list (? string?) ...) authors)]
|
||||||
|
['versions versions0]
|
||||||
|
['ring (? number? ring)]
|
||||||
|
['last-edit (? number? last-edit)]))
|
||||||
|
(define source (string->package-source source0))
|
||||||
|
(define versions (for/hash [((version source) (in-hash versions0))]
|
||||||
|
(values version (string->package-source source))))
|
||||||
|
(package name source description tags authors versions ring last-edit)]
|
||||||
|
[_
|
||||||
|
(error 'deserialize-package "Unrecognized serialized package: ~v" p)]))
|
||||||
|
|
||||||
|
(define (serialize-computed-info ci)
|
||||||
|
(match-define (computed-info package-name
|
||||||
|
last-updated
|
||||||
|
last-checked
|
||||||
|
checksums
|
||||||
|
checksum-errors
|
||||||
|
github-info
|
||||||
|
declared-conflicts
|
||||||
|
modules
|
||||||
|
dependencies)
|
||||||
|
ci)
|
||||||
|
(list 'computed-info computed-info-format-version
|
||||||
|
(hash 'package-name package-name
|
||||||
|
'last-updated last-updated
|
||||||
|
'last-checked last-checked
|
||||||
|
'checksums checksums
|
||||||
|
'checksum-errors checksum-errors
|
||||||
|
'github-info (and github-info (serialize-github-info github-info))
|
||||||
|
'declared-conflicts declared-conflicts
|
||||||
|
'modules modules
|
||||||
|
'dependencies dependencies)))
|
||||||
|
|
||||||
|
(define (deserialize-computed-info ci)
|
||||||
|
(match ci
|
||||||
|
[(? hash?)
|
||||||
|
(computed-info (hash-ref ci 'name)
|
||||||
|
(hash-ref ci 'last-updated 0)
|
||||||
|
(hash-ref ci 'last-checked 0)
|
||||||
|
(let ((cs (for/hash [((v fs) (in-hash (hash-ref ci 'versions (hash))))
|
||||||
|
#:when (hash-has-key? fs 'checksum)]
|
||||||
|
(values v (hash-ref fs 'checksum)))))
|
||||||
|
(if (hash-has-key? ci 'checksum)
|
||||||
|
(hash-set cs "default" (hash-ref ci 'checksum))
|
||||||
|
cs))
|
||||||
|
(let ((err (hash-ref ci 'checksum-error #f)))
|
||||||
|
(if err
|
||||||
|
(hash "default" err)
|
||||||
|
(hash)))
|
||||||
|
#f
|
||||||
|
(list->set (hash-ref ci 'conflicts '()))
|
||||||
|
(hash-ref ci 'modules '())
|
||||||
|
(hash-ref ci 'dependencies '()))]
|
||||||
|
[(list 'computed-info 0
|
||||||
|
(hash-table ['package-name (? string? package-name)]
|
||||||
|
['last-updated (? number? last-updated)]
|
||||||
|
['last-checked (? number? last-checked)]
|
||||||
|
['checksums checksums]
|
||||||
|
['checksum-errors checksum-errors]
|
||||||
|
['github-info github-info0]
|
||||||
|
['declared-conflicts declared-conflicts]
|
||||||
|
['modules (and (list (? module-path?) ...) modules)]
|
||||||
|
['dependencies (and (list (? string?) ...) dependencies)]))
|
||||||
|
(define github-info (and github-info0 (deserialize-github-info github-info0)))
|
||||||
|
(computed-info package-name
|
||||||
|
last-updated
|
||||||
|
last-checked
|
||||||
|
checksums
|
||||||
|
checksum-errors
|
||||||
|
github-info
|
||||||
|
declared-conflicts
|
||||||
|
modules
|
||||||
|
dependencies)]
|
||||||
|
[_
|
||||||
|
(error 'deserialize-computed-info "Unrecognized serialized computed-info: ~v" ci)]))
|
||||||
|
|
||||||
|
(define (serialize-github-info gi)
|
||||||
|
(match-define (github-info readme-exists?) gi)
|
||||||
|
(list 'github-info github-info-format-version
|
||||||
|
(hash 'readme-exists? readme-exists?)))
|
||||||
|
|
||||||
|
(define (deserialize-github-info gi)
|
||||||
|
(match gi
|
||||||
|
[(list 'github-info 0
|
||||||
|
(hash-table ['readme-exists? readme-exists?]))
|
||||||
|
(github-info readme-exists?)]
|
||||||
|
[_
|
||||||
|
(error 'deserialize-github-info "Unrecognized serialized github-info: ~v" gi)]))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(require rackunit)
|
||||||
|
|
||||||
|
(define empty-zip "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
|
||||||
|
(define empty-zip-checksum "9f098dddde7f217879070816090c1e8e74d49432")
|
||||||
|
|
||||||
|
(define xrepl-lib-hash
|
||||||
|
#hash((name . "xrepl-lib")
|
||||||
|
(source . "git://github.com/racket/xrepl/?path=xrepl-lib")
|
||||||
|
(author . "eli@racket-lang.org")
|
||||||
|
(last-updated . 1417912075)
|
||||||
|
(last-edit . 1417659583)
|
||||||
|
(last-checked . 1421095102)
|
||||||
|
(versions
|
||||||
|
. #hash(("5.3.5"
|
||||||
|
. #hash((source
|
||||||
|
. "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
|
||||||
|
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
|
||||||
|
("5.3.4"
|
||||||
|
. #hash((source
|
||||||
|
. "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
|
||||||
|
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")))
|
||||||
|
("5.3.6"
|
||||||
|
. #hash((source
|
||||||
|
. "http://racket-packages.s3-us-west-2.amazonaws.com/pkgs/empty.zip")
|
||||||
|
(checksum . "9f098dddde7f217879070816090c1e8e74d49432")))))
|
||||||
|
(tags . ("main-distribution"))
|
||||||
|
(checksum-error . #f)
|
||||||
|
(ring . 0)
|
||||||
|
(checksum . "c88f8430b054d8a207a95acb0d1de0efece33510")
|
||||||
|
(description . "implementation (no documentation) part of \"xrepl\"")
|
||||||
|
(modules . ((lib "xrepl/saved-values.rkt")
|
||||||
|
(lib "xrepl/xrepl.rkt")
|
||||||
|
(lib "xrepl/main.rkt")))
|
||||||
|
(dependencies . ("base" "readline-lib" "scribble-text-lib"))
|
||||||
|
(conflicts . ())))
|
||||||
|
|
||||||
|
(define xrepl-lib (package "xrepl-lib"
|
||||||
|
(git-source "github.com"
|
||||||
|
#f
|
||||||
|
"racket/xrepl"
|
||||||
|
"master"
|
||||||
|
"xrepl-lib")
|
||||||
|
"implementation (no documentation) part of \"xrepl\""
|
||||||
|
'("main-distribution")
|
||||||
|
'("eli@racket-lang.org")
|
||||||
|
(hash "5.3.4" (url-source empty-zip)
|
||||||
|
"5.3.5" (url-source empty-zip)
|
||||||
|
"5.3.6" (url-source empty-zip))
|
||||||
|
0
|
||||||
|
1417659583))
|
||||||
|
|
||||||
|
(define xrepl-lib-info (computed-info "xrepl-lib"
|
||||||
|
1417912075
|
||||||
|
1421095102
|
||||||
|
(hash "5.3.4" empty-zip-checksum
|
||||||
|
"5.3.5" empty-zip-checksum
|
||||||
|
"5.3.6" empty-zip-checksum
|
||||||
|
"default" "c88f8430b054d8a207a95acb0d1de0efece33510")
|
||||||
|
(hash)
|
||||||
|
#f
|
||||||
|
(set)
|
||||||
|
(list '(lib "xrepl/saved-values.rkt")
|
||||||
|
'(lib "xrepl/xrepl.rkt")
|
||||||
|
'(lib "xrepl/main.rkt"))
|
||||||
|
(list "base" "readline-lib" "scribble-text-lib")))
|
||||||
|
|
||||||
|
(check-equal? (deserialize-package xrepl-lib-hash) xrepl-lib)
|
||||||
|
(check-equal? (serialize-package xrepl-lib)
|
||||||
|
(list 'package package-format-version
|
||||||
|
(hash 'name "xrepl-lib"
|
||||||
|
'source "git://github.com/racket/xrepl?path=xrepl-lib#master"
|
||||||
|
'tags '("main-distribution")
|
||||||
|
'description "implementation (no documentation) part of \"xrepl\""
|
||||||
|
'last-edit 1417659583
|
||||||
|
'versions (hash "5.3.4" empty-zip
|
||||||
|
"5.3.5" empty-zip
|
||||||
|
"5.3.6" empty-zip)
|
||||||
|
'ring 0
|
||||||
|
'authors '("eli@racket-lang.org"))))
|
||||||
|
(check-equal? (deserialize-package (serialize-package xrepl-lib)) xrepl-lib)
|
||||||
|
|
||||||
|
(check-equal? (deserialize-computed-info xrepl-lib-hash) xrepl-lib-info)
|
||||||
|
(check-equal? (deserialize-computed-info (serialize-computed-info xrepl-lib-info)) xrepl-lib-info)
|
||||||
|
)
|
||||||
|
|
@ -1,160 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; Package Source URLs: their various kinds
|
|
||||||
|
|
||||||
;; Here we're only interested in remote URLs -- http, https, git and
|
|
||||||
;; github. Local file and directory package sources are not to be
|
|
||||||
;; accepted.
|
|
||||||
|
|
||||||
(provide parse-package-source
|
|
||||||
parsed-package-source-human-url
|
|
||||||
parsed-package-source-human-tree-url
|
|
||||||
unparse-package-source
|
|
||||||
package-source->human-tree-url
|
|
||||||
(struct-out parsed-package-source)
|
|
||||||
(struct-out simple-url-source)
|
|
||||||
(struct-out git-source))
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require (only-in racket/string string-join string-split))
|
|
||||||
(require net/url)
|
|
||||||
(require pkg/private/repo-path)
|
|
||||||
(require pkg/name)
|
|
||||||
|
|
||||||
;; A ParsedPackageSource is one of
|
|
||||||
;; -- (simple-url-source String (Option String) (Option Symbol))
|
|
||||||
;; -- (git-source String (Option String) Symbol Symbol String (Option Number) String String String)
|
|
||||||
(struct parsed-package-source (url-string inferred-name type) #:prefab)
|
|
||||||
(struct simple-url-source parsed-package-source () #:prefab)
|
|
||||||
(struct git-source parsed-package-source (transport host port repo commit path) #:prefab)
|
|
||||||
|
|
||||||
;; String -> (Values (Option ParsedPackageSource) (Listof String))
|
|
||||||
;; The second result is a list of complaints about the passed-in package source URL string.
|
|
||||||
(define (parse-package-source p)
|
|
||||||
(define complaints '())
|
|
||||||
(define (complain message) (set! complaints (append complaints (list message))))
|
|
||||||
|
|
||||||
(define-values (name type)
|
|
||||||
(with-handlers ([void (lambda (e) (values #f #f))])
|
|
||||||
(package-source->name+type p #f
|
|
||||||
#:complain (lambda (_p message) (complain message))
|
|
||||||
#:must-infer-name? #t)))
|
|
||||||
|
|
||||||
(define parsed-source
|
|
||||||
(match type
|
|
||||||
[#f
|
|
||||||
(complain "couldn't guess package source type")
|
|
||||||
(simple-url-source p name type)]
|
|
||||||
|
|
||||||
;; ['name] -- only ever returned if it was passed in as second arg to package-source->name+type
|
|
||||||
;; ['clone] -- only returned if passed in, like 'name
|
|
||||||
;; ['link] -- only returned if #:link-dirs? given, except if it's a file:// url with a type query parameter of link
|
|
||||||
;; ['static-link] -- only returned if it's a file:// url with a type query parameter of static-link
|
|
||||||
|
|
||||||
[(or 'file 'dir)
|
|
||||||
(complain "local file or directory package source types are not permitted")
|
|
||||||
#f]
|
|
||||||
|
|
||||||
[(or 'git 'github)
|
|
||||||
(with-handlers ([void (lambda (e) (simple-url-source p name type))])
|
|
||||||
(define u (string->url p))
|
|
||||||
(define-values (transport host port repo commit path) (split-git-or-hub-url u #:type type))
|
|
||||||
(git-source p name type
|
|
||||||
(if (eq? type 'github) 'git transport)
|
|
||||||
host
|
|
||||||
port
|
|
||||||
repo
|
|
||||||
commit
|
|
||||||
(string-join path "/")))]
|
|
||||||
|
|
||||||
[(or 'file-url 'dir-url)
|
|
||||||
(with-handlers ([void (lambda (e) (simple-url-source p name type))])
|
|
||||||
(define u (string->url p)) ;; just to check it *can* be parsed as a URL
|
|
||||||
(simple-url-source p name type))]))
|
|
||||||
|
|
||||||
(values parsed-source complaints))
|
|
||||||
|
|
||||||
(define (parsed-package-source-human-url s)
|
|
||||||
(match s
|
|
||||||
[(git-source u _ type _ host port repo _ _)
|
|
||||||
(real-git-url (string->url u) host port repo #:type type)]
|
|
||||||
[(simple-url-source u _ _)
|
|
||||||
u]))
|
|
||||||
|
|
||||||
(define (parsed-package-source-human-tree-url s)
|
|
||||||
(match s
|
|
||||||
[(git-source _ _ _ _ "github.com" _ repo commit path)
|
|
||||||
(url->string
|
|
||||||
(url "https"
|
|
||||||
#f
|
|
||||||
"github.com"
|
|
||||||
#f
|
|
||||||
#t
|
|
||||||
(append (->url-path (regexp-replace #rx"[.]git$" repo ""))
|
|
||||||
(list (path/param "tree" '())
|
|
||||||
(path/param commit '()))
|
|
||||||
(->url-path path))
|
|
||||||
'()
|
|
||||||
#f))]
|
|
||||||
[_ (parsed-package-source-human-url s)]))
|
|
||||||
|
|
||||||
(define (unparse-package-source s)
|
|
||||||
(match s
|
|
||||||
[(git-source _ _ _ transport host port repo commit path)
|
|
||||||
(url->string
|
|
||||||
(url (symbol->string transport)
|
|
||||||
#f
|
|
||||||
host
|
|
||||||
port
|
|
||||||
#t
|
|
||||||
(->url-path repo)
|
|
||||||
(match path ["" '()] [_ (list (cons 'path path))])
|
|
||||||
(match commit [#f #f] ["master" #f] [_ commit])))]
|
|
||||||
[(simple-url-source u _ _)
|
|
||||||
u]))
|
|
||||||
|
|
||||||
(define (->url-path str)
|
|
||||||
(map (lambda (s) (path/param s '())) (string-split str "/")))
|
|
||||||
|
|
||||||
(define (package-source->human-tree-url source)
|
|
||||||
(define-values (parsed complaints) (parse-package-source source))
|
|
||||||
(if parsed (parsed-package-source-human-tree-url parsed) source))
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(define test-data
|
|
||||||
(list
|
|
||||||
"http://github.com/test/repo.git"
|
|
||||||
"https://github.com/test/repo.git"
|
|
||||||
"http://leastfixedpoint.com:55555/foo/bar.git?path=zot/quux/baz#release"
|
|
||||||
"git://leastfixedpoint.com:55555/foo/bar.git?path=zot/quux/baz#release"
|
|
||||||
"github://github.com/foo/bar/master"
|
|
||||||
"github://github.com/foo/bar.git/master"
|
|
||||||
"github://github.com/foo/bar.git/release/zot/quux/baz"
|
|
||||||
"github://github.com/foo/bar/release/zot/quux/baz"
|
|
||||||
"github://github.com/tonyg/racket-ansi.git/master"
|
|
||||||
"github://github.com/tonyg/racket-ansi/master"
|
|
||||||
))
|
|
||||||
|
|
||||||
(require rackunit)
|
|
||||||
(require racket/set)
|
|
||||||
|
|
||||||
(define seen-types
|
|
||||||
(for/set ((p test-data))
|
|
||||||
(define-values (name type) (package-source->name+type p #f))
|
|
||||||
type))
|
|
||||||
|
|
||||||
(define expected-types
|
|
||||||
(set 'git 'github 'file-url 'dir-url))
|
|
||||||
|
|
||||||
(check-equal? (set) (set-subtract seen-types expected-types))
|
|
||||||
(check-equal? (set) (set-subtract expected-types seen-types))
|
|
||||||
|
|
||||||
(for ((p test-data))
|
|
||||||
(define-values (parsed-source complaints) (parse-package-source p))
|
|
||||||
(printf "~v:\n - ~v\n - ~v\n - ~v\n"
|
|
||||||
p
|
|
||||||
parsed-source
|
|
||||||
complaints
|
|
||||||
(unparse-package-source parsed-source))
|
|
||||||
(void)
|
|
||||||
)
|
|
||||||
)
|
|
||||||
|
|
@ -53,20 +53,14 @@
|
||||||
(define (fetch-remote-packages)
|
(define (fetch-remote-packages)
|
||||||
(log-info "Fetching package list from ~a" package-index-url)
|
(log-info "Fetching package list from ~a" package-index-url)
|
||||||
(define result
|
(define result
|
||||||
(with-handlers ([exn:fail?
|
(with-handlers ((exn:fail? (lambda (e) #f)))
|
||||||
(lambda (e)
|
(define response-bytes (port->bytes (get-pure-port (string->url package-index-url))))
|
||||||
((error-display-handler) (exn-message e) e)
|
|
||||||
#f)])
|
|
||||||
(define response-port
|
|
||||||
(get-pure-port (string->url package-index-url)))
|
|
||||||
(define response-bytes (port->bytes response-port))
|
|
||||||
(close-input-port response-port)
|
|
||||||
(define decompressed (gunzip/bytes response-bytes))
|
(define decompressed (gunzip/bytes response-bytes))
|
||||||
(define decoded (bytes->jsexpr decompressed))
|
(define decoded (bytes->jsexpr decompressed))
|
||||||
decoded))
|
decoded))
|
||||||
(if (hash? result)
|
(if (hash? result)
|
||||||
(log-info "Fetched package list containing ~a packages." (hash-count result))
|
(log-info "Fetched package list containing ~a packages." (hash-count result))
|
||||||
(log-info "Fetched bogus package list: ~e" result))
|
(log-info "Fetched bogus package list"))
|
||||||
result)
|
result)
|
||||||
|
|
||||||
(define (tombstone? pkg)
|
(define (tombstone? pkg)
|
||||||
|
|
@ -127,17 +121,13 @@
|
||||||
[all-tags
|
[all-tags
|
||||||
(for/fold ((ts (set)))
|
(for/fold ((ts (set)))
|
||||||
((pkg (in-hash-values (package-manager-state-local-packages state))))
|
((pkg (in-hash-values (package-manager-state-local-packages state))))
|
||||||
(if (tombstone? pkg)
|
(set-union ts (list->set
|
||||||
ts
|
(map symbol->string
|
||||||
(set-union ts (list->set
|
(hash-keys (or (@ pkg search-terms) (hash)))))))]
|
||||||
(map symbol->string
|
|
||||||
(hash-keys (or (@ pkg search-terms) (hash))))))))]
|
|
||||||
[all-formal-tags
|
[all-formal-tags
|
||||||
(for/fold ((ts (set)))
|
(for/fold ((ts (set)))
|
||||||
((pkg (in-hash-values (package-manager-state-local-packages state))))
|
((pkg (in-hash-values (package-manager-state-local-packages state))))
|
||||||
(if (tombstone? pkg)
|
(set-union ts (list->set (or (@ pkg tags) '()))))]))
|
||||||
ts
|
|
||||||
(set-union ts (list->set (or (@ pkg tags) '())))))]))
|
|
||||||
|
|
||||||
(define (replace-package completion-ch old-pkg new-pkg state)
|
(define (replace-package completion-ch old-pkg new-pkg state)
|
||||||
(define local-packages (package-manager-state-local-packages state))
|
(define local-packages (package-manager-state-local-packages state))
|
||||||
|
|
@ -207,7 +197,7 @@
|
||||||
[('package-detail name)
|
[('package-detail name)
|
||||||
(values (lookup-package name local-packages) state)]
|
(values (lookup-package name local-packages) state)]
|
||||||
[('package-batch-detail names)
|
[('package-batch-detail names)
|
||||||
(values (filter values (for/list ((name names)) (lookup-package name local-packages))) state)]
|
(values (for/list ((name names)) (lookup-package name local-packages)) state)]
|
||||||
[('external-information name)
|
[('external-information name)
|
||||||
(values (hash-ref external-information name (lambda () (hash))) state)]
|
(values (hash-ref external-information name (lambda () (hash))) state)]
|
||||||
[('set-external-information! name info)
|
[('set-external-information! name info)
|
||||||
|
|
@ -259,7 +249,7 @@
|
||||||
(define (next-fetch-deadline) (manager-rpc 'next-fetch-deadline))
|
(define (next-fetch-deadline) (manager-rpc 'next-fetch-deadline))
|
||||||
|
|
||||||
(define (sort-package-names names)
|
(define (sort-package-names names)
|
||||||
(sort names (lambda (a b) (string-ci<? (symbol->string a) (symbol->string b)))))
|
(sort names (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))
|
||||||
|
|
||||||
(define (sorted-package-names)
|
(define (sorted-package-names)
|
||||||
(sort-package-names (all-package-names)))
|
(sort-package-names (all-package-names)))
|
||||||
|
|
@ -281,11 +271,7 @@
|
||||||
|
|
||||||
(define ((package-text-matches? pkg) re)
|
(define ((package-text-matches? pkg) re)
|
||||||
(and (not (tombstone? pkg))
|
(and (not (tombstone? pkg))
|
||||||
(regexp-match? re (or (@ pkg _SEARCHABLE-TEXT_)
|
(regexp-match? re (@ pkg _SEARCHABLE-TEXT_))))
|
||||||
;; Packages lacking the _SEARCHABLE-TEXT_ key are _LOCALLY_MODIFIED_.
|
|
||||||
;; Synthesise searchable text here; a better (?) alternative would be
|
|
||||||
;; to do this at package save time, but this will do for now.
|
|
||||||
(pkg->searchable-text pkg)))))
|
|
||||||
|
|
||||||
(define (package-search text tags)
|
(define (package-search text tags)
|
||||||
(define res (map (lambda (r) (regexp (regexp-quote r #f))) (string-split text)))
|
(define res (map (lambda (r) (regexp (regexp-quote r #f))) (string-split text)))
|
||||||
|
|
|
||||||
28
src/rpc.rkt
28
src/rpc.rkt
|
|
@ -1,15 +1,11 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(provide (struct-out exn:fail:rpc)
|
(provide rpc-request-evt
|
||||||
rpc-request-evt
|
|
||||||
rpc-handler
|
rpc-handler
|
||||||
rpc-call
|
rpc-call
|
||||||
rpc-cast!)
|
rpc-cast!)
|
||||||
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/exn)
|
|
||||||
|
|
||||||
(struct exn:fail:rpc exn:fail (inner-exn) #:transparent)
|
|
||||||
|
|
||||||
(define (rpc-request-evt)
|
(define (rpc-request-evt)
|
||||||
(handle-evt (thread-receive-evt)
|
(handle-evt (thread-receive-evt)
|
||||||
|
|
@ -19,30 +15,16 @@
|
||||||
(match ch-and-req
|
(match ch-and-req
|
||||||
[(cons ch request)
|
[(cons ch request)
|
||||||
(define-values (reply-value new-state)
|
(define-values (reply-value new-state)
|
||||||
(with-handlers [(exn:fail? (lambda (e)
|
(match request
|
||||||
(channel-put ch e)
|
[(list argpat ...) body ...]
|
||||||
(raise e)))]
|
...))
|
||||||
(match request
|
|
||||||
[(list argpat ...) body ...]
|
|
||||||
...)))
|
|
||||||
(when ch (channel-put ch reply-value))
|
(when ch (channel-put ch reply-value))
|
||||||
new-state]))
|
new-state]))
|
||||||
|
|
||||||
(define (rpc-call thread . request)
|
(define (rpc-call thread . request)
|
||||||
(define ch (make-channel))
|
(define ch (make-channel))
|
||||||
(thread-send thread (cons ch request))
|
(thread-send thread (cons ch request))
|
||||||
(define result
|
(channel-get ch))
|
||||||
(sync (handle-evt thread
|
|
||||||
(lambda (_)
|
|
||||||
(raise (exn:fail:rpc "Server thread terminated unexpectedly"
|
|
||||||
(current-continuation-marks)
|
|
||||||
#f))))
|
|
||||||
ch))
|
|
||||||
(when (exn? result)
|
|
||||||
(raise (exn:fail:rpc (format "RPC exception:\n~a" (exn->string result))
|
|
||||||
(current-continuation-marks)
|
|
||||||
result)))
|
|
||||||
result)
|
|
||||||
|
|
||||||
(define (rpc-cast! thread . request)
|
(define (rpc-cast! thread . request)
|
||||||
(thread-send thread (cons #f request)))
|
(thread-send thread (cons #f request)))
|
||||||
|
|
|
||||||
|
|
@ -20,7 +20,7 @@
|
||||||
(* 7 24 60 60)) ;; one week in seconds
|
(* 7 24 60 60)) ;; one week in seconds
|
||||||
1000)) ;; convert to milliseconds
|
1000)) ;; convert to milliseconds
|
||||||
|
|
||||||
(struct session (key expiry email password curator? superuser?) #:prefab)
|
(struct session (key expiry email password) #:prefab)
|
||||||
|
|
||||||
(define sessions (make-persistent-state 'session-store (lambda () (make-hash))))
|
(define sessions (make-persistent-state 'session-store (lambda () (make-hash))))
|
||||||
|
|
||||||
|
|
@ -36,7 +36,7 @@
|
||||||
(when (and s (<= (session-expiry s) now))
|
(when (and s (<= (session-expiry s) now))
|
||||||
(hash-remove! ss session-key))))
|
(hash-remove! ss session-key))))
|
||||||
|
|
||||||
(define (create-session! email password #:curator? [curator? #f] #:superuser? [superuser? #f])
|
(define (create-session! email password)
|
||||||
(expire-sessions!)
|
(expire-sessions!)
|
||||||
(define session-key (bytes->string/utf-8 (random-bytes/base64 32)))
|
(define session-key (bytes->string/utf-8 (random-bytes/base64 32)))
|
||||||
(hash-set! (sessions)
|
(hash-set! (sessions)
|
||||||
|
|
@ -44,9 +44,7 @@
|
||||||
(session session-key
|
(session session-key
|
||||||
(+ (current-inexact-milliseconds) session-lifetime)
|
(+ (current-inexact-milliseconds) session-lifetime)
|
||||||
email
|
email
|
||||||
password
|
password))
|
||||||
curator?
|
|
||||||
superuser?))
|
|
||||||
session-key)
|
session-key)
|
||||||
|
|
||||||
(define (destroy-session! session-key)
|
(define (destroy-session! session-key)
|
||||||
|
|
|
||||||
|
|
@ -4,20 +4,14 @@
|
||||||
(provide poll-signal
|
(provide poll-signal
|
||||||
start-restart-signal-watcher)
|
start-restart-signal-watcher)
|
||||||
|
|
||||||
(require (only-in racket/file file->string))
|
|
||||||
(require reloadable)
|
(require reloadable)
|
||||||
(require "daemon.rkt")
|
(require "daemon.rkt")
|
||||||
|
|
||||||
(define (poll-signal signal-file-name message handler)
|
(define (poll-signal signal-file-name message handler)
|
||||||
(when (file-exists? signal-file-name)
|
(when (file-exists? signal-file-name)
|
||||||
(define contents (file->string signal-file-name))
|
(log-info message)
|
||||||
(if (string=? contents "")
|
|
||||||
(log-info "~a" message)
|
|
||||||
(log-info "~a: ~a" message contents))
|
|
||||||
(delete-file signal-file-name)
|
(delete-file signal-file-name)
|
||||||
(if (procedure-arity-includes? handler 1)
|
(handler)))
|
||||||
(handler contents)
|
|
||||||
(handler))))
|
|
||||||
|
|
||||||
(define (start-restart-signal-watcher)
|
(define (start-restart-signal-watcher)
|
||||||
(daemon-thread
|
(daemon-thread
|
||||||
|
|
@ -39,17 +33,11 @@
|
||||||
reload!)
|
reload!)
|
||||||
(poll-signal "../signals/.fetchindex"
|
(poll-signal "../signals/.fetchindex"
|
||||||
"Index refresh signal received"
|
"Index refresh signal received"
|
||||||
(lambda ()
|
(reloadable-entry-point->procedure
|
||||||
(reloadable-entry-point->procedure
|
(lookup-reloadable-entry-point 'refresh-packages! "packages.rkt")))
|
||||||
(lookup-reloadable-entry-point 'refresh-packages! "packages.rkt"))))
|
|
||||||
(poll-signal "../signals/.rerender"
|
(poll-signal "../signals/.rerender"
|
||||||
"Static rerender request received"
|
"Static rerender request received"
|
||||||
(lambda (request-body)
|
(reloadable-entry-point->procedure
|
||||||
(define items-to-rerender (read (open-input-string request-body)))
|
(lookup-reloadable-entry-point 'rerender-all! "site.rkt")))
|
||||||
((reloadable-entry-point->procedure
|
|
||||||
(lookup-reloadable-entry-point 'rerender! "site.rkt"))
|
|
||||||
(if (eof-object? items-to-rerender)
|
|
||||||
#f
|
|
||||||
items-to-rerender))))
|
|
||||||
(sleep 0.5)
|
(sleep 0.5)
|
||||||
(loop)))))
|
(loop)))))
|
||||||
|
|
|
||||||
1306
src/site.rkt
1306
src/site.rkt
File diff suppressed because it is too large
Load Diff
279
src/static.rkt
279
src/static.rkt
|
|
@ -1,78 +1,39 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(provide rendering-static-page?
|
(provide static-generated-directory
|
||||||
|
rendering-static-page?
|
||||||
static-render!
|
static-render!
|
||||||
static-put-file!
|
finish-static-update!
|
||||||
static-delete-file!
|
|
||||||
static-finish-update!
|
|
||||||
extra-files-paths)
|
extra-files-paths)
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require racket/system)
|
(require racket/system)
|
||||||
(require racket/path)
|
|
||||||
(require racket/port)
|
|
||||||
(require racket/promise)
|
(require racket/promise)
|
||||||
(require racket/file)
|
(require racket/file)
|
||||||
(require web-server/private/servlet)
|
(require web-server/private/servlet)
|
||||||
(require web-server/http/request-structs)
|
(require web-server/http/request-structs)
|
||||||
(require web-server/http/response-structs)
|
(require web-server/http/response-structs)
|
||||||
(require file/md5)
|
|
||||||
(require xml)
|
|
||||||
(require xml/path)
|
|
||||||
(require net/url)
|
(require net/url)
|
||||||
(require aws/s3)
|
|
||||||
(require reloadable)
|
|
||||||
(require "config.rkt")
|
(require "config.rkt")
|
||||||
(require "daemon.rkt")
|
|
||||||
(require "rpc.rkt")
|
|
||||||
(require "hash-utils.rkt")
|
(require "hash-utils.rkt")
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Config
|
|
||||||
|
|
||||||
(define static-output-type
|
|
||||||
;; Either 'aws-s3 or 'file
|
|
||||||
(or (@ (config) static-output-type)
|
|
||||||
'file))
|
|
||||||
|
|
||||||
(define aws-s3-bucket+path
|
|
||||||
;; Must end in "/"
|
|
||||||
(@ (config) aws-s3-bucket+path))
|
|
||||||
|
|
||||||
(define static-generated-directory
|
(define static-generated-directory
|
||||||
;; Relevant to static-output-type 'file only
|
|
||||||
(config-path (or (@ (config) static-generated-directory)
|
(config-path (or (@ (config) static-generated-directory)
|
||||||
(build-path (var-path) "generated-htdocs"))))
|
(build-path (var-path) "generated-htdocs"))))
|
||||||
|
|
||||||
(define static-content-target-directory
|
(define static-content-target-directory
|
||||||
;; Relevant to static-output-type 'file only
|
|
||||||
(let ((p (@ (config) static-content-target-directory)))
|
(let ((p (@ (config) static-content-target-directory)))
|
||||||
(and p (config-path p))))
|
(and p (config-path p))))
|
||||||
|
|
||||||
(define pkg-index-generated-directory
|
(define static-content-update-hook (@ (config) static-content-update-hook))
|
||||||
(config-path (or (@ (config) pkg-index-generated-directory)
|
|
||||||
(error 'pkg-index-generated-directory "Not specified"))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(define extra-static-content-directories
|
||||||
;; Static rendering daemon -- Interface
|
(map config-path
|
||||||
|
(or (@ (config) extra-static-content-directories)
|
||||||
|
'())))
|
||||||
|
|
||||||
(define rendering-static-page? (make-parameter #f))
|
(define rendering-static-page? (make-parameter #f))
|
||||||
|
|
||||||
(define (assert-absolute! what absolute-path)
|
|
||||||
(when (not (eqv? (string-ref absolute-path 0) #\/))
|
|
||||||
(error what "Path must start with /; got ~v" absolute-path)))
|
|
||||||
|
|
||||||
(define (static-put-file! absolute-path content-bytes mime-type)
|
|
||||||
(assert-absolute! 'static-put-file! absolute-path)
|
|
||||||
(renderer-rpc 'put-file! absolute-path content-bytes mime-type))
|
|
||||||
|
|
||||||
(define (static-delete-file! absolute-path)
|
|
||||||
(assert-absolute! 'static-delete-file! absolute-path)
|
|
||||||
(renderer-rpc 'delete-file! absolute-path))
|
|
||||||
|
|
||||||
(define (static-render! #:filename [base-filename #f]
|
(define (static-render! #:filename [base-filename #f]
|
||||||
#:ignore-response-code? [ignore-response-code? #f]
|
|
||||||
#:mime-type mime-type
|
|
||||||
named-url handler . named-url-args)
|
named-url handler . named-url-args)
|
||||||
(define request-url (apply named-url handler named-url-args))
|
(define request-url (apply named-url handler named-url-args))
|
||||||
(log-info "Rendering static version of ~a~a"
|
(log-info "Rendering static version of ~a~a"
|
||||||
|
|
@ -97,209 +58,39 @@
|
||||||
"127.0.0.1")
|
"127.0.0.1")
|
||||||
named-url-args))
|
named-url-args))
|
||||||
servlet-prompt)))))
|
servlet-prompt)))))
|
||||||
(define absolute-path (or base-filename request-url))
|
(define filename (format "~a~a" static-generated-directory (or base-filename request-url)))
|
||||||
(assert-absolute! 'static-render! absolute-path)
|
|
||||||
(define content-bytes (call-with-output-bytes (response-output response)))
|
|
||||||
(cond
|
(cond
|
||||||
[(or (<= 200 (response-code response) 299) ;; "OKish" range
|
[(<= 200 (response-code response) 299) ;; "OKish" range
|
||||||
ignore-response-code?)
|
(make-parent-directory* filename)
|
||||||
(static-put-file! absolute-path content-bytes mime-type)]
|
(call-with-output-file filename
|
||||||
|
(response-output response)
|
||||||
|
#:exists 'replace)]
|
||||||
[(= (response-code response) 404) ;; Not found -> delete the file
|
[(= (response-code response) 404) ;; Not found -> delete the file
|
||||||
(static-delete-file! absolute-path)]
|
(when (file-exists? filename)
|
||||||
|
(delete-file filename))]
|
||||||
[else
|
[else
|
||||||
(log-warning "Unexpected response code ~v when static-rendering ~v"
|
(log-warning "Unexpected response code ~v when static-rendering ~v"
|
||||||
(response-code response)
|
(response-code response)
|
||||||
(cons handler named-url-args))]))
|
(cons handler named-url-args))]))
|
||||||
|
|
||||||
(define (static-finish-update!)
|
(define (finish-static-update!)
|
||||||
(renderer-rpc 'finish-update!))
|
(when static-content-target-directory
|
||||||
|
(make-directory* static-content-target-directory)
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(define command
|
||||||
;; Static rendering daemon -- Implementation
|
(append (list (path->string (find-executable-path "rsync"))
|
||||||
|
"-a"
|
||||||
(define (static-renderer-main)
|
"--delete"
|
||||||
(match static-output-type
|
(path->string (build-path static-generated-directory "."))
|
||||||
['file (static-renderer-file)]
|
(path->string (build-path (config-path "../static") ".")))
|
||||||
['aws-s3 (static-renderer-aws-s3 #f)])
|
(for/list [(dir extra-static-content-directories)]
|
||||||
(static-renderer-main))
|
(path->string (build-path dir ".")))
|
||||||
|
(list (path->string (build-path static-content-target-directory ".")))))
|
||||||
;;---------------------------------------- 'file
|
(log-info "Executing rsync to replicate static content; argv: ~v" command)
|
||||||
|
(apply system* command))
|
||||||
(define (static-renderer-file)
|
(when static-content-update-hook
|
||||||
(rpc-handler (sync (rpc-request-evt))
|
(system static-content-update-hook)))
|
||||||
[('reload!)
|
|
||||||
(values (void) (void))]
|
|
||||||
[('put-file! absolute-path content-bytes mime-type)
|
|
||||||
(define filename (format "~a~a" static-generated-directory absolute-path))
|
|
||||||
(make-parent-directory* filename)
|
|
||||||
(call-with-output-file filename
|
|
||||||
(lambda (p) (write-bytes content-bytes p))
|
|
||||||
#:exists 'replace)
|
|
||||||
(values (void) (void))]
|
|
||||||
[('delete-file! absolute-path)
|
|
||||||
(define filename (format "~a~a" static-generated-directory absolute-path))
|
|
||||||
(when (file-exists? filename)
|
|
||||||
(delete-file filename))
|
|
||||||
(values (void) (void))]
|
|
||||||
[('finish-update!)
|
|
||||||
(when static-content-target-directory
|
|
||||||
(make-directory* static-content-target-directory)
|
|
||||||
(define command
|
|
||||||
(append (list (path->string (find-executable-path "rsync"))
|
|
||||||
"-a"
|
|
||||||
"--delete"
|
|
||||||
(path->string (build-path static-generated-directory "."))
|
|
||||||
(path->string (build-path (config-path "../static") ".")))
|
|
||||||
(list (path->string (build-path pkg-index-generated-directory ".")))
|
|
||||||
(list (path->string (build-path static-content-target-directory ".")))))
|
|
||||||
(log-info "Executing rsync to replicate static content; argv: ~v" command)
|
|
||||||
(apply system* command))
|
|
||||||
(values (void) (void))]))
|
|
||||||
|
|
||||||
;;---------------------------------------- 'aws-s3
|
|
||||||
|
|
||||||
(define (initial-aws-s3-index)
|
|
||||||
(for/hash [(entry (ls/proc aws-s3-bucket+path append '()))]
|
|
||||||
(match-define (pregexp "^\"(.*)\"$" (list _ file-md5-str))
|
|
||||||
(apply string-append (se-path*/list '(ETag) entry)))
|
|
||||||
(values (se-path* '(Key) entry)
|
|
||||||
(string->bytes/utf-8 file-md5-str))))
|
|
||||||
|
|
||||||
(define (absolute-path->relative-path absolute-path)
|
|
||||||
(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
|
|
||||||
(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))
|
|
||||||
(define new-md5 (md5 content-bytes))
|
|
||||||
(if (equal? new-md5 (hash-ref index relative-path #f))
|
|
||||||
(begin
|
|
||||||
;; (log-info "Not uploading ~a to S3, since MD5 has not changed" relative-path)
|
|
||||||
(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
|
|
||||||
(cons (cons 'x-amz-acl "public-read")
|
|
||||||
headers))))
|
|
||||||
(hash-set index relative-path new-md5))
|
|
||||||
|
|
||||||
(define (aws-delete-file! index absolute-path)
|
|
||||||
(define relative-path (absolute-path->relative-path absolute-path))
|
|
||||||
(log-info "Deleting ~a from S3" relative-path)
|
|
||||||
(delete (string-append aws-s3-bucket+path relative-path))
|
|
||||||
(hash-remove index relative-path))
|
|
||||||
|
|
||||||
(define (extension-map p)
|
|
||||||
(match (filename-extension p)
|
|
||||||
[#"html" "text/html"]
|
|
||||||
[#"css" "text/css"]
|
|
||||||
[#"js" "application/javascript"]
|
|
||||||
[#"json" "application/json"]
|
|
||||||
[#"png" "image/png"]
|
|
||||||
[#"svg" "image/svg"]
|
|
||||||
[#f "application/octet-stream"]
|
|
||||||
[other ;; (log-info "Unknown extension in extension-map: ~a" other)
|
|
||||||
"application/octet-stream"]))
|
|
||||||
|
|
||||||
(define (upload-directory! index source-directory0 target-absolute-path-prefix)
|
|
||||||
(define source-directory (simple-form-path source-directory0))
|
|
||||||
(for/fold [(index index)]
|
|
||||||
[(filepath (find-files file-exists? source-directory))]
|
|
||||||
(define absolute-path
|
|
||||||
(path->string (build-path target-absolute-path-prefix
|
|
||||||
(find-relative-path source-directory filepath))))
|
|
||||||
;; https://github.com/tonyg/racket-pkg-website/issues/28
|
|
||||||
;; TOCTTOU: we checked that `file-exists?` above, but that may have changed since!
|
|
||||||
(define contents
|
|
||||||
(with-handlers [(exn:fail:filesystem?
|
|
||||||
;; ^ It would be nice to be able to be more precise here, e.g.
|
|
||||||
;; file-not-found, but `file->bytes` delegates to `file-size` which
|
|
||||||
;; only raises `exn:fail:filesystem` when a problem occurs.
|
|
||||||
(lambda (e)
|
|
||||||
(log-warning "Transient (?) problem reading ~v: ~v"
|
|
||||||
filepath
|
|
||||||
(exn-message e))
|
|
||||||
#f))]
|
|
||||||
(file->bytes filepath)))
|
|
||||||
(if contents
|
|
||||||
(aws-put-file! index absolute-path contents (extension-map filepath))
|
|
||||||
(aws-delete-file! index absolute-path))))
|
|
||||||
|
|
||||||
(define (configure-s3-cors!)
|
|
||||||
(log-info "Configuring S3 CORS headers:\n~a"
|
|
||||||
(put/bytes (string-append aws-s3-bucket+path "?cors")
|
|
||||||
(string->bytes/utf-8 (xexpr->string
|
|
||||||
`(CORSConfiguration
|
|
||||||
(CORSRule (AllowedOrigin "*")
|
|
||||||
(AllowedMethod "GET")
|
|
||||||
(AllowedHeader "*")))))
|
|
||||||
"application/xml"
|
|
||||||
'())))
|
|
||||||
|
|
||||||
(define (static-renderer-aws-s3 index)
|
|
||||||
(s3-region "us-west-2")
|
|
||||||
(when (not index) (configure-s3-cors!))
|
|
||||||
(let ((index (or index (initial-aws-s3-index))))
|
|
||||||
(match
|
|
||||||
(rpc-handler (sync (rpc-request-evt))
|
|
||||||
[('reload!)
|
|
||||||
(values (void) 'reload!)]
|
|
||||||
[('put-file! absolute-path content-bytes mime-type)
|
|
||||||
(values (void) (aws-put-file! index absolute-path content-bytes mime-type))]
|
|
||||||
[('delete-file! absolute-path)
|
|
||||||
(values (void) (aws-delete-file! index absolute-path))]
|
|
||||||
[('finish-update!)
|
|
||||||
(let* ((index (upload-directory! index (build-path (config-path "../static") ".") "/"))
|
|
||||||
(index (upload-directory! index
|
|
||||||
(build-path pkg-index-generated-directory "pkg")
|
|
||||||
"/pkg/")))
|
|
||||||
(values (void)
|
|
||||||
(for/fold [(index index)]
|
|
||||||
[(leaf (in-list `(("atom.xml" "application/atom+xml")
|
|
||||||
("pkgs" "application/octet-stream")
|
|
||||||
("pkgs-all" "application/octet-stream")
|
|
||||||
("pkgs-all.json.gz" "application/json"
|
|
||||||
(Content-Encoding . "gzip"))
|
|
||||||
("pkgs.json" "application/json"))))]
|
|
||||||
(match-define (list* filename mime-type headers) leaf)
|
|
||||||
(aws-put-file! index
|
|
||||||
(path->string (build-path "/" filename))
|
|
||||||
(file->bytes
|
|
||||||
(build-path pkg-index-generated-directory filename))
|
|
||||||
mime-type
|
|
||||||
headers))))])
|
|
||||||
['reload! (void)] ;; effectively restarts daemon
|
|
||||||
[next-index (static-renderer-aws-s3 next-index)])))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Static rendering daemon -- Startup
|
|
||||||
|
|
||||||
(define static-renderer-thread
|
|
||||||
(make-persistent-state 'static-renderer-thread
|
|
||||||
(lambda () (daemon-thread 'static-renderer
|
|
||||||
(lambda () (static-renderer-main))))))
|
|
||||||
|
|
||||||
(define (renderer-rpc . request) (apply rpc-call (static-renderer-thread) request))
|
|
||||||
|
|
||||||
(renderer-rpc 'reload!)
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Interface to web-server static file serving
|
|
||||||
|
|
||||||
(define (extra-files-paths)
|
(define (extra-files-paths)
|
||||||
(list static-generated-directory
|
(list* static-generated-directory
|
||||||
(config-path "../static")
|
(config-path "../static")
|
||||||
pkg-index-generated-directory))
|
extra-static-content-directories))
|
||||||
|
|
|
||||||
|
|
@ -18,30 +18,34 @@ function preenSourceType(e) {
|
||||||
}
|
}
|
||||||
return control(e, n).val();
|
return control(e, n).val();
|
||||||
}
|
}
|
||||||
function showhide(s, gt, gh, gr, gc, gp) {
|
function showhide(s, gh, gu, gp, gb) {
|
||||||
return [showhide1("simple_url", s),
|
return [showhide1("simple_url", s),
|
||||||
showhide1("g_transport", gt),
|
showhide1("g_host", gh),
|
||||||
showhide1("g_host_port", gh),
|
showhide1("g_user", gu),
|
||||||
showhide1("g_repo", gr),
|
showhide1("g_project", gp),
|
||||||
showhide1("g_commit", gc),
|
showhide1("g_branch", gb)];
|
||||||
showhide1("g_path", gp)];
|
|
||||||
}
|
}
|
||||||
var pieces;
|
var pieces;
|
||||||
var previewUrl;
|
var previewUrl;
|
||||||
var previewGroup = control(e, "urlpreview__group");
|
var previewGroup = control(e, "urlpreview__group");
|
||||||
var previewInput = control(e, "urlpreview");
|
var previewInput = control(e, "urlpreview");
|
||||||
switch (e.value) {
|
switch (e.value) {
|
||||||
|
case "github":
|
||||||
|
previewGroup.show();
|
||||||
|
pieces = showhide(false, false, true, true, true);
|
||||||
|
previewUrl = "github://github.com/" + pieces[2] + "/" + pieces[3] +
|
||||||
|
(pieces[4] ? "/" + pieces[4] : "");
|
||||||
|
break;
|
||||||
case "git":
|
case "git":
|
||||||
previewGroup.show();
|
previewGroup.show();
|
||||||
pieces = showhide(false, true, true, true, true, true);
|
pieces = showhide(false, true, true, true, true);
|
||||||
previewUrl = pieces[1] + "://" + pieces[2] + "/" + pieces[3] +
|
previewUrl = "git://" + pieces[1] + "/" + pieces[2] + "/" + pieces[3] +
|
||||||
(pieces[5] ? "?path=" + pieces[5] : "") +
|
(pieces[4] ? "/" + pieces[4] : "");
|
||||||
(pieces[4] && (pieces[4] !== 'master') ? '#' + pieces[4] : "");
|
|
||||||
break;
|
break;
|
||||||
case "simple":
|
case "simple":
|
||||||
default:
|
default:
|
||||||
previewGroup.hide();
|
previewGroup.hide();
|
||||||
pieces = showhide(true, false, false, false, false, false);
|
pieces = showhide(true, false, false, false, false);
|
||||||
previewUrl = pieces[0];
|
previewUrl = pieces[0];
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
@ -70,7 +74,7 @@ $(document).ready(function () {
|
||||||
$(".package-version-source-type").each(function (index, e) {
|
$(".package-version-source-type").each(function (index, e) {
|
||||||
var preenE = function () { preenSourceType(e); };
|
var preenE = function () { preenSourceType(e); };
|
||||||
$(e).change(preenE);
|
$(e).change(preenE);
|
||||||
var names = ['simple_url', 'g_transport', 'g_host_port', 'g_repo', 'g_commit', 'g_path'];
|
var names = ['simple_url', 'g_host', 'g_user', 'g_project', 'g_branch'];
|
||||||
for (var i = 0; i < names.length; i++) {
|
for (var i = 0; i < names.length; i++) {
|
||||||
control(e, names[i]).change(preenE).keyup(preenE);
|
control(e, names[i]).change(preenE).keyup(preenE);
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -1,13 +0,0 @@
|
||||||
"use strict";
|
|
||||||
|
|
||||||
$(document).ready(function () {
|
|
||||||
// "Cool URLs Don't Break" - catch uses of fragment-based links to
|
|
||||||
// specific packages, and effectively redirect to the new-style
|
|
||||||
// specific package URL.
|
|
||||||
//
|
|
||||||
var oldstyle_link = document.location.hash.match(/#\[(.*)\]$/);
|
|
||||||
if (oldstyle_link) {
|
|
||||||
var linked_package = oldstyle_link[1];
|
|
||||||
document.location = document.location.pathname + 'package/' + linked_package;
|
|
||||||
}
|
|
||||||
});
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 5.7 KiB After Width: | Height: | Size: 18 KiB |
|
|
@ -1,5 +1,6 @@
|
||||||
$(document).ready(function () {
|
$(document).ready(function () {
|
||||||
PkgSite.staticJSON("search-completions", function (searchCompletions) {
|
$("#q").focus();
|
||||||
|
PkgSite.getJSON("search-completions", function (searchCompletions) {
|
||||||
searchCompletions.sort();
|
searchCompletions.sort();
|
||||||
PkgSite.multiTermComplete(PkgSite.preventTabMovingDuringSelection($("#q")), searchCompletions);
|
PkgSite.multiTermComplete(PkgSite.preventTabMovingDuringSelection($("#q")), searchCompletions);
|
||||||
});
|
});
|
||||||
|
|
|
||||||
|
|
@ -25,20 +25,14 @@ PkgSite = (function () {
|
||||||
});
|
});
|
||||||
}
|
}
|
||||||
|
|
||||||
function dynamicJSON(relative_url, k) {
|
function getJSON(relative_url, k) {
|
||||||
return $.getJSON(PkgSiteDynamicBaseUrl + '/json/' + relative_url, k);
|
return $.getJSON(PkgSiteDynamicBaseUrl + '/json/' + relative_url, k);
|
||||||
}
|
}
|
||||||
|
|
||||||
function staticJSON(relative_url, k) {
|
|
||||||
return $.getJSON((IsStaticPage ? PkgSiteStaticBaseUrl : PkgSiteDynamicBaseUrl)
|
|
||||||
+ '/json/' + relative_url, k);
|
|
||||||
}
|
|
||||||
|
|
||||||
return {
|
return {
|
||||||
multiTermComplete: multiTermComplete,
|
multiTermComplete: multiTermComplete,
|
||||||
preventTabMovingDuringSelection: preventTabMovingDuringSelection,
|
preventTabMovingDuringSelection: preventTabMovingDuringSelection,
|
||||||
dynamicJSON: dynamicJSON,
|
getJSON: getJSON
|
||||||
staticJSON: staticJSON
|
|
||||||
};
|
};
|
||||||
})();
|
})();
|
||||||
|
|
||||||
|
|
@ -46,14 +40,13 @@ $(document).ready(function () {
|
||||||
$("table.sortable").tablesorter();
|
$("table.sortable").tablesorter();
|
||||||
|
|
||||||
if ($("#tags").length) {
|
if ($("#tags").length) {
|
||||||
PkgSite.dynamicJSON((document.body.className === "package-form")
|
PkgSite.getJSON((document.body.className === "package-form")
|
||||||
? "formal-tags"
|
? "formal-tags"
|
||||||
: "tag-search-completions",
|
: "tag-search-completions",
|
||||||
function (completions) {
|
function (completions) {
|
||||||
completions.sort();
|
completions.sort();
|
||||||
PkgSite.multiTermComplete(
|
PkgSite.multiTermComplete(PkgSite.preventTabMovingDuringSelection($("#tags")),
|
||||||
PkgSite.preventTabMovingDuringSelection($("#tags")),
|
completions);
|
||||||
completions);
|
});
|
||||||
});
|
|
||||||
}
|
}
|
||||||
});
|
});
|
||||||
|
|
|
||||||
|
|
@ -11,7 +11,7 @@ body {
|
||||||
-webkit-font-smoothing: antialiased;
|
-webkit-font-smoothing: antialiased;
|
||||||
}
|
}
|
||||||
|
|
||||||
.navbar { background: white; }
|
.navbar { background: black; }
|
||||||
|
|
||||||
/*---------------------------------------------------------------------------*/
|
/*---------------------------------------------------------------------------*/
|
||||||
/* Make the navbar the same height as the main racket page's navbar */
|
/* Make the navbar the same height as the main racket page's navbar */
|
||||||
|
|
@ -20,10 +20,6 @@ body {
|
||||||
line-height: 60px;
|
line-height: 60px;
|
||||||
height: 60px;
|
height: 60px;
|
||||||
padding-top: 0;
|
padding-top: 0;
|
||||||
color: #444 !important; /* override bootstrap.css */
|
|
||||||
}
|
|
||||||
.navbar-nav > .active > a {
|
|
||||||
color: white !important; /* override bootstrap.css */
|
|
||||||
}
|
}
|
||||||
.navbar-btn {
|
.navbar-btn {
|
||||||
margin-top: 13px;
|
margin-top: 13px;
|
||||||
|
|
@ -142,9 +138,4 @@ th.headerSortDown::after { content: " ▲"; }
|
||||||
border-radius: 10px;
|
border-radius: 10px;
|
||||||
}
|
}
|
||||||
.registration-step h1 { margin: 0.5em; }
|
.registration-step h1 { margin: 0.5em; }
|
||||||
.registration-step p { font-size: 140%; }
|
.registration-step p { font-size: 140%; }
|
||||||
|
|
||||||
.ring-change-link {
|
|
||||||
display: inline-block;
|
|
||||||
padding: 0 0.15em;
|
|
||||||
}
|
|
||||||
|
|
@ -1,51 +0,0 @@
|
||||||
$(function() {
|
|
||||||
"use strict";
|
|
||||||
|
|
||||||
function applyFilter() {
|
|
||||||
$("table.packages > tbody > tr").each(function() {
|
|
||||||
var row = this;
|
|
||||||
if (Number.parseInt($(row).data("todokey"), 10) === 0) {
|
|
||||||
row.style.display = "none";
|
|
||||||
}
|
|
||||||
});
|
|
||||||
$("table.packages").trigger("sorton", [[[4, 1]]]);
|
|
||||||
}
|
|
||||||
|
|
||||||
function removeFilter() {
|
|
||||||
$("table.packages > tbody > tr").each(function() {
|
|
||||||
var row = this;
|
|
||||||
if (Number.parseInt($(row).data("todokey"), 10) === 0) {
|
|
||||||
row.style.display = "";
|
|
||||||
}
|
|
||||||
});
|
|
||||||
$("table.packages").trigger("sorton", [[[1, 0]]]);
|
|
||||||
}
|
|
||||||
|
|
||||||
var todoTotal = $("table.packages").data("todokey");
|
|
||||||
|
|
||||||
if (todoTotal > 0) {
|
|
||||||
$("#todo-msg").show();
|
|
||||||
$("#todo-msg").html(
|
|
||||||
todoTotal + " todos. " +
|
|
||||||
"<a style='cursor:pointer' id='filter-pkgs'> Click here to see them.</a>"
|
|
||||||
);
|
|
||||||
|
|
||||||
var filterIsApplied = false;
|
|
||||||
|
|
||||||
$("#filter-pkgs").click(function() {
|
|
||||||
var filterLink = $(this);
|
|
||||||
if (!filterIsApplied) {
|
|
||||||
applyFilter();
|
|
||||||
filterLink.text("Click to see all packages.");
|
|
||||||
filterIsApplied = true;
|
|
||||||
} else {
|
|
||||||
removeFilter();
|
|
||||||
filterLink.text("Click here to see them.");
|
|
||||||
filterIsApplied = false;
|
|
||||||
}
|
|
||||||
});
|
|
||||||
} else {
|
|
||||||
$("#todo-msg").hide();
|
|
||||||
}
|
|
||||||
|
|
||||||
}); /* document.ready */
|
|
||||||
Loading…
Reference in New Issue
Block a user