From 35bff5b68342cc7a3d51f80e3c5a7909ab81820f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 11 Aug 2013 06:36:37 -0600 Subject: [PATCH] first cut at script to push PLT packages to pkg.racket-lang.org --- Makefile | 19 +- pkgs/distro-build/pack-and-catalog.rkt | 40 ++-- pkgs/plt-services/meta/pkg-push/Makefile | 52 ++++++ pkgs/plt-services/meta/pkg-push/info.rkt | 3 + .../meta/pkg-push/push-catalog.rkt | 173 ++++++++++++++++++ .../racket-doc/file/scribblings/zip.scrbl | 20 +- racket/collects/file/zip.rkt | 29 +-- racket/collects/pkg/strip.rkt | 10 +- 8 files changed, 299 insertions(+), 47 deletions(-) create mode 100644 pkgs/plt-services/meta/pkg-push/Makefile create mode 100644 pkgs/plt-services/meta/pkg-push/info.rkt create mode 100644 pkgs/plt-services/meta/pkg-push/push-catalog.rkt diff --git a/Makefile b/Makefile index 703cd4a8de..0091fb244b 100644 --- a/Makefile +++ b/Makefile @@ -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): # diff --git a/pkgs/distro-build/pack-and-catalog.rkt b/pkgs/distro-build/pack-and-catalog.rkt index dc86437675..d13a2bc1b0 100644 --- a/pkgs/distro-build/pack-and-catalog.rkt +++ b/pkgs/distro-build/pack-and-catalog.rkt @@ -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 diff --git a/pkgs/plt-services/meta/pkg-push/Makefile b/pkgs/plt-services/meta/pkg-push/Makefile new file mode 100644 index 0000000000..852d2df730 --- /dev/null +++ b/pkgs/plt-services/meta/pkg-push/Makefile @@ -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) diff --git a/pkgs/plt-services/meta/pkg-push/info.rkt b/pkgs/plt-services/meta/pkg-push/info.rkt new file mode 100644 index 0000000000..1b61bcd5b3 --- /dev/null +++ b/pkgs/plt-services/meta/pkg-push/info.rkt @@ -0,0 +1,3 @@ +#lang info + +(define compile-omit-files '("push-catalog.rkt")) ; uses extra packages diff --git a/pkgs/plt-services/meta/pkg-push/push-catalog.rkt b/pkgs/plt-services/meta/pkg-push/push-catalog.rkt new file mode 100644 index 0000000000..690a330c47 --- /dev/null +++ b/pkgs/plt-services/meta/pkg-push/push-catalog.rkt @@ -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)])))) diff --git a/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl b/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl index afd11d743d..0a831ebf94 100644 --- a/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl +++ b/pkgs/racket-pkgs/racket-doc/file/scribblings/zip.scrbl @@ -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 diff --git a/racket/collects/file/zip.rkt b/racket/collects/file/zip.rkt index 5f353ffb09..6341e3af1b 100644 --- a/racket/collects/file/zip.rkt +++ b/racket/collects/file/zip.rkt @@ -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)))) ) diff --git a/racket/collects/pkg/strip.rkt b/racket/collects/pkg/strip.rkt index c01530806d..3935e035ca 100644 --- a/racket/collects/pkg/strip.rkt +++ b/racket/collects/pkg/strip.rkt @@ -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