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

first cut at script to push PLT packages to pkg.racket-lang.org

Browse Source
This commit is contained in:
Matthew Flatt 2013-08-11 06:36:37 -06:00
parent ad45434c21
commit 35bff5b683
8 changed files with 299 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
Makefile
View File

@ -219,9 +219,7 @@ win32-pkg-links:
# On a server platform (for an installer build):
server:
$(MAKE) build/site.rkt
$(MAKE) base
$(MAKE) stamp
$(MAKE) server-from-base
build/site.rkt:
@ -240,8 +238,13 @@ stamp-from-git:
stamp-from-date:
date +"%Y%m%d" > build/stamp.txt
local-from-base:
$(MAKE) build/site.rkt
$(MAKE) stamp
if [ "$(SRC_CATALOG)" = 'local' ] ; then $(MAKE) build-from-local ; else $(MAKE) build-from-catalog ; fi
server-from-base:
if [ "$(EEAPP)" = '' ] ; then $(MAKE) build-from-local ; else $(MAKE) build-from-catalog ; fi
$(MAKE) local-from-base
$(MAKE) origin-collects
$(MAKE) built-catalog
$(MAKE) built-catalog-server
@ -336,16 +339,6 @@ binary-catalog:
binary-catalog-server:
$(RACKET) -l- distro-build/serve-catalog --mode binary
# Assemble all packages from this repo into ".zip" form
# to checksum-based subdirectories of "build/archive/pkgs"
# and a catalog in "build/archive/catalog":
PACK_ARCHIVE = --at-checksum build/archive/pkgs \
--pack build/archive/pre-pkgs \
++catalog build/archive/catalog
archive-catalog:
$(RACKET) $(DISTBLD)/pack-and-catalog.rkt --native $(PACK_ARCHIVE) native-pkgs
$(RACKET) $(DISTBLD)/pack-and-catalog.rkt $(PACK_ARCHIVE) pkgs
# ------------------------------------------------------------
# On each supported platform (for an installer build):
#

40
pkgs/distro-build/pack-and-catalog.rkt
View File

@ -3,6 +3,7 @@
racket/file
racket/port
racket/string
racket/list
file/zip
openssl/sha1
net/url
@ -41,18 +42,22 @@
(define (stream-directory d)
(define-values (i o) (make-pipe (* 100 4096)))
(define (skip-path? p)
(member (let-values ([(base name dir?) (split-path p)]) (path->string name))
'("compiled")))
(let-values ([(base name dir?) (split-path p)])
(define s (path->string name))
(or (member s '("compiled"))
(regexp-match? #rx#"^(?:[.]git.*|[.]svn|.*~|#.*#)$" s))))
(thread (lambda ()
(for ([f (in-directory d)])
(cond
[(skip-path? f) (void)]
[(directory-exists? f)
(write (directory-list f) o)]
[(file-exists? f)
(call-with-input-file*
f
(lambda (i) (copy-port i o)))]))
(let loop ([d d])
(for ([f (directory-list d #:build? #t)])
(cond
[(skip-path? f) (void)]
[(directory-exists? f)
(write (filter-not skip-path? (directory-list f)) o)
(loop f)]
[(file-exists? f)
(call-with-input-file*
f
(lambda (i) (copy-port i o)))])))
(close-output-port o)))
i)
@ -61,6 +66,7 @@
(define dest-zip (and pack-dest-dir
(build-path (path->complete-path pack-dest-dir)
zip-file)))
(when pack-dest-dir
(define sum-file (path-add-suffix pkg-name #".srcsum"))
(define pkg-src-dir (build-path src-dir pkg-name))
@ -73,12 +79,16 @@
(call-with-input-file* dest-sum read)))
(printf "packing ~a\n" zip-file)
(define tmp-dir (make-temporary-file "~a-pkg" 'directory))
(generate-stripped-directory (if native? 'binary 'source)
pkg-src-dir
tmp-dir)
(parameterize ([strip-binary-compile-info #f]) ; for deterministic checksum
(generate-stripped-directory (if native? 'binary 'source)
pkg-src-dir
tmp-dir))
(parameterize ([current-directory tmp-dir])
(when (file-exists? dest-zip) (delete-file dest-zip))
(apply zip dest-zip (directory-list)))
(apply zip dest-zip (directory-list)
;; Use a constant timestamp so that the checksum does
;; not depend on timestamps:
#:timestamp 1359788400))
(delete-directory/files tmp-dir)
(call-with-output-file*
dest-sum

52
pkgs/plt-services/meta/pkg-push/Makefile Normal file
View File

@ -0,0 +1,52 @@
# ------------------------------------------------------------
# Configuration
# This `racket' must have the the "distro-build" and "aws" packages
# installed:
RACKET = racket
# In `PLT_TOP', "build/latest" should be a git clone to update (and it
# shouldn't be the clone that implements `RACKET'), and other files
# will be written and cached at "build":
PLT_TOP = ../../../..
# Along with the following, "~/.aws-keys" must have your AWS keys in
# the form
# AWSAccessKeyId=....
# AWSSecretKey=....
S3_HOST = s3-us-west-2.amazonaws.com
BUCKET = racket-packages
# The catalog server to update:
DEST_CATALOG = https://localhost:9004
# ------------------------------------------------------------
# Targets
# Make `push' periodically to push packages to pkgs.racket-lang.org:
push:
$(MAKE) pull-latest-from-git
$(MAKE) archive-catalog
$(MAKE) push-catalog
# Update repo checkout in "build/latest" --- assuming that the
# repo has been checked out before.
pull-latest-from-git:
cd $(PLT_TOP)/build/latest && git pull && git submodule update
# Assemble all packages from a repo checkout into ".zip" form
# to checksum-based subdirectories of "build/archive/pkgs"
# and a catalog in "build/archive/catalog":
PACK_ARCHIVE = --at-checksum $(PLT_TOP)/build/archive/pkgs \
--pack $(PLT_TOP)/build/archive/pre-pkgs \
++catalog $(PLT_TOP)/build/archive/catalog
archive-catalog:
rm -rf $(PLT_TOP)/build/archive/catalog
$(RACKET) -l- distro-build/pack-and-catalog --native $(PACK_ARCHIVE) $(PLT_TOP)/build/latest/native-pkgs
$(RACKET) -l- distro-build/pack-and-catalog $(PACK_ARCHIVE) $(PLT_TOP)/build/latest/pkgs
# Copy files from "build/archive" to $(BUCKET), and update
# $(DEST_CATALOG):
AWS_AND_CATALOG = $(S3_HOST) $(BUCKET) $(DEST_CATALOG)
push-catalog:
$(RACKET) push-catalog.rkt $(PLT_TOP)/build/archive $(AWS_AND_CATALOG)

3
pkgs/plt-services/meta/pkg-push/info.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang info
(define compile-omit-files '("push-catalog.rkt")) ; uses extra packages

173
pkgs/plt-services/meta/pkg-push/push-catalog.rkt Normal file
View File

@ -0,0 +1,173 @@
#lang racket/base
(require aws/keys
aws/s3
racket/file
racket/cmdline
racket/set
racket/format
racket/port
net/url
http/head
pkg/lib)
(define-values (src-dir s3-hostname bucket dest-catalog)
(command-line
#:args
(src-dir s3-hostname bucket dest-catalog)
(values src-dir s3-hostname bucket dest-catalog)))
(ensure-have-keys)
(s3-host s3-hostname)
(define-values (catalog-email catalog-password)
(call-with-input-file*
(build-path (find-system-path 'home-dir) ".pkg-catalog-login")
(lambda (i) (values (read i) (read i)))))
(printf "Getting current packages at ~a...\n" dest-catalog)
(define current-pkgs
(parameterize ([current-pkg-catalogs (list (string->url dest-catalog))])
(get-all-pkg-details-from-catalogs)))
(printf "... got it.\n")
(define new-pkgs
(let ([dir (build-path src-dir "catalog" "pkg")])
(for/hash ([i (in-list (directory-list dir))])
(define ht (call-with-input-file* (build-path dir i) read))
(values (path->string i)
(hash-set ht
'source
(format "http://~a.~a/pkgs/~a/~a.zip"
bucket
s3-hostname
(hash-ref ht 'checksum)
i))))))
(printf "Getting current S3 content...\n")
(define old-content (list->set (ls (string-append bucket "/pkgs"))))
(printf "... got it.\n")
;; A list of `(cons checksum p)':
(define new-checksums&files
(let ([dir (build-path src-dir "pkgs")])
(for*/list ([checksum (in-list (directory-list dir))]
[p (in-list (directory-list (build-path dir checksum)))])
(cons (path->string checksum) (path->string p)))))
;; A tag that we install for each checksum that is used.
;; We can detect obsolte checksums as not having a recent
;; enough tag (i.e., older than an era). An "era" is
;; currently defined as a week.
(define now-era (quotient (current-seconds) (* 7 24 60 60)))
(define now (~a now-era))
(define recently (~a (sub1 now-era)))
;; ----------------------------------------
;; Push one file at a given chcksum to the bucket
(define (sync-one checksum p)
(printf "Checking ~a @ ~a\n" p checksum)
(define (at-checksum p)
(string-append "pkgs/" checksum "/" p))
(define (at-bucket&checksum p)
(string-append bucket "/" (at-checksum p)))
(define (put p content)
(printf "Putting ~a\n" p)
(define s (put/bytes p
content
"application/octet-stream"
#hash((x-amz-storage-class . "REDUCED_REDUNDANCY")
(x-amz-acl . "public-read"))))
(unless (member (extract-http-code s) '(200))
(printf "put failed for ~s: ~s\n" p s)))
(unless (set-member? old-content (at-checksum now))
(put (at-bucket&checksum now)
#"ok"))
(unless (set-member? old-content (at-checksum p))
(put (at-bucket&checksum p)
(file->bytes (build-path src-dir "pkgs" checksum p)))))
;; Discard an obsolete file
(define (purge-one checksum raw-p)
(printf "Removing ~a @ ~a\n" raw-p checksum)
(define p (string-append bucket "/pkgs/" checksum "/" raw-p))
(define s (delete p))
(unless (member (extract-http-code s) '(200 204))
(printf "delete failed for ~s: ~s\n" p s)))
;; Update the package catalog:
(define (update-catalog the-email the-password the-post)
(define the-url
(let ([u (string->url dest-catalog)])
(struct-copy url u
[path
(append
(url-path u)
(list (path/param "api" null)
(path/param "upload" null)))])))
(define bs
(call/input-url the-url
(λ (url)
(post-pure-port the-url
(with-output-to-bytes
(λ ()
(write (list the-email
(string->bytes/utf-8 the-password)
the-post))))))
port->bytes))
(read (open-input-bytes bs)))
;; ------------------------------
;; Upload current files:
(for ([p (in-list new-checksums&files)])
(sync-one (car p) (cdr p)))
;; Update the catalog:
(let ([changed-pkgs
(for/hash ([(k v) (in-hash new-pkgs)]
#:unless (let ([ht (hash-ref current-pkgs k #hash())])
(and (equal? (hash-ref v 'source)
(hash-ref ht 'source #f))
(equal? (hash-ref v 'checksum)
(hash-ref ht 'checksum #f)))))
(values k v))])
(unless (zero? (hash-count changed-pkgs))
(printf "Updating catalog:\n")
(for ([k (in-hash-keys changed-pkgs)])
(printf " ~a\n" k))
(define r (update-catalog catalog-email catalog-password changed-pkgs))
(unless (equal? r #t)
(printf "unexpected result from catalog update: ~s\n" r))))
(printf "Catalog updated\n")
;; Look for files that can be discarded:
(let ([new-checksums
(for/set ([pr (in-list new-checksums&files)])
(car pr))])
(for ([p (in-set old-content)])
(define m (regexp-match #rx"^pkgs/([^/]*)/([^/]*)$" p))
(when m
(define checksum (cadr m))
(define p (caddr m))
(cond
[(set-member? new-checksums checksum)
;; Keep this checksum, but look for old timestamp files.
(when (regexp-match? #rx"^[0-9]*$" p)
(unless (or (equal? p now)
(equal? p recently))
;; Looks like we can delete it
(purge-one checksum p)))]
[(or (set-member? old-content (string-append "pkgs/" checksum "/" recently))
(set-member? old-content (string-append "pkgs/" checksum "/" recently)))
;; Recent enough timestamp; don't discard
(void)]
[else
;; Old checksum, so discard
(purge-one checksum p)]))))

20
pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl
View File

@ -8,25 +8,35 @@ utilities to create @exec{zip} archive files, which are compatible
with both Windows and Unix (including Mac OS X) unpacking. The actual
compression is implemented by @racket[deflate].}
@defproc[(zip [zip-file path-string?][path path-string?] ...)
@defproc[(zip [zip-file path-string?] [path path-string?] ...
[#:timestamp timestamp (or/c #f exact-integer?) #f])
void?]{
Creates @racket[zip-file], which holds the complete content of all
@racket[path]s. The given @racket[path]s are all expected to be
@racket[path]s.
The given @racket[path]s are all expected to be
relative path names of existing directories and files (i.e., relative
to the current directory). If a nested path is provided as a
@racket[path], its ancestor directories are also added to the
resulting zip file, up to the current directory (using
@racket[pathlist-closure]). Files are packaged as usual for
@racket[pathlist-closure]).
Files are packaged as usual for
@exec{zip} files, including permission bits for both Windows and Unix
(including Mac OS X). The permission bits are determined by
@racket[file-or-directory-permissions], which does not preserve the
distinction between owner/group/other permissions. Also, symbolic
links are always followed.}
links are always followed.
If @racket[timestamp] is not @racket[#f], it is used as the
modification date for each file, instead of the result of
@racket[file-or-directory-modify-seconds].}
@defproc[(zip->output [paths (listof path-string?)]
[out output-port? (current-output-port)])
[out output-port? (current-output-port)]
[#:timestamp timestamp (or/c #f exact-integer?) #f])
void?]{
Zips each of the given @racket[paths], and packages it as a zip

29
racket/collects/file/zip.rkt
View File

@ -142,8 +142,8 @@
(write-int comment-length 2)
(write-bytes *zip-comment*)))
;; write-central-directory : (listof header) ->
(define (write-central-directory headers)
;; write-central-directory : (listof header) (or/c #f exact-integer?) ->
(define (write-central-directory headers timestamp)
(let ([count (length headers)])
(let loop ([headers headers] [offset 0] [size 0])
(if (null? headers)
@ -155,7 +155,10 @@
[attributes (metadata-attributes metadata)]
[compression (metadata-compression metadata)]
[version (bitwise-ior *spec-version*
(arithmetic-shift *system* 8))])
(arithmetic-shift (if timestamp
3
*system*)
8))])
(write-int #x02014b50 4)
(write-int version 2)
(write-int *required-version* 2)
@ -224,9 +227,10 @@
(define (with-slash-separator bytes)
(regexp-replace* *os-specific-separator-regexp* bytes #"/"))
;; build-metadata : relative-path -> metadata
(define (build-metadata path)
(let* ([mod (seconds->date (file-or-directory-modify-seconds path))]
;; build-metadata : relative-path (or/c #f exact-integer?) -> metadata
(define (build-metadata path timestamp)
(let* ([mod (seconds->date (or timestamp
(file-or-directory-modify-seconds path)))]
[dir? (directory-exists? path)]
[path (cond [(path? path) path]
[(string? path) (string->path path)]
@ -246,24 +250,27 @@
;; zip-write : (listof relative-path) ->
;; writes a zip file to current-output-port
(provide zip->output)
(define (zip->output files [out (current-output-port)])
(define (zip->output files [out (current-output-port)]
#:timestamp [timestamp #f])
(parameterize ([current-output-port out])
(let* ([seekable? (seekable-port? (current-output-port))]
[headers ; note: Racket's `map' is always left-to-right
(map (lambda (file)
(zip-one-entry (build-metadata file) seekable?))
(zip-one-entry (build-metadata file timestamp) seekable?))
files)])
(when (zip-verbose)
(eprintf "zip: writing headers...\n"))
(write-central-directory headers))
(write-central-directory headers timestamp))
(when (zip-verbose)
(eprintf "zip: done.\n"))))
;; zip : output-file paths ->
(provide zip)
(define (zip zip-file . paths)
(define (zip zip-file #:timestamp [timestamp #f]
. paths)
;; (when (null? paths) (error 'zip "no paths specified"))
(with-output-to-file zip-file
(lambda () (zip->output (pathlist-closure paths)))))
(lambda () (zip->output (pathlist-closure paths)
#:timestamp timestamp))))
)

10
racket/collects/pkg/strip.rkt
View File

@ -8,7 +8,10 @@
racket/set)
(provide generate-stripped-directory
fixup-local-redirect-reference)
fixup-local-redirect-reference
strip-binary-compile-info)
(define strip-binary-compile-info (make-parameter #t))
(define (generate-stripped-directory mode dir dest-dir)
(define drop-keep-ns (make-base-namespace))
@ -214,8 +217,9 @@
(unless (get-info/full dir #:namespace (make-base-namespace))
(error 'pkg-binary-create "rewrite failed"))
;; compile it, if not top level:
(unless (eq? src-base 'same)
(managed-compile-zo new-p))))
(when (strip-binary-compile-info)
(unless (eq? src-base 'same)
(managed-compile-zo new-p)))))
(define ((fixup-info-definition get-info) defn)
(match defn