From 718cbd4c419cc8532511ddf8d108975835709aea Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 9 May 2014 09:45:26 -0600 Subject: [PATCH] distro-build: fix catalog relative paths The old use of relative paths was unusual and fragile. Proper relative paths are now supported, so generate paths consistent with that. --- Makefile | 2 +- .../distro-build-server/pack-and-catalog.rkt | 14 +++++--- .../distro-build-server/pack-built.rkt | 10 ++++-- .../distro-build-server/serve-catalog.rkt | 36 ++++++------------- 4 files changed, 28 insertions(+), 34 deletions(-) diff --git a/Makefile b/Makefile index a5c5072375..05127ea8d3 100644 --- a/Makefile +++ b/Makefile @@ -326,7 +326,7 @@ complain-no-submodule: exit 1 # Create packages and a catalog for all native libraries: -PACK_NATIVE = --native --absolute --pack build/native/pkgs \ +PACK_NATIVE = --native --pack build/native/pkgs \ ++catalog build/native/catalog \ ++catalog build/local/catalog native-catalog: diff --git a/pkgs/distro-build-pkgs/distro-build-server/pack-and-catalog.rkt b/pkgs/distro-build-pkgs/distro-build-server/pack-and-catalog.rkt index 3713a613d4..f369b2a06e 100644 --- a/pkgs/distro-build-pkgs/distro-build-server/pack-and-catalog.rkt +++ b/pkgs/distro-build-pkgs/distro-build-server/pack-and-catalog.rkt @@ -4,6 +4,7 @@ racket/port racket/string racket/list + racket/path file/zip openssl/sha1 net/url @@ -120,6 +121,7 @@ (build-path info-path "info.rkt"))))) (define (write-catalog-entry catalog-dir) + (define catalog-dir/normal (simplify-path (path->complete-path catalog-dir))) (define catalog-pkg-dir (build-path catalog-dir "pkg")) (define checksum (if dest-zip (call-with-input-file* dest-zip sha1) @@ -154,10 +156,14 @@ #:exists 'truncate (lambda (o) (write (hash 'source (path->string - ((if relative? values path->complete-path) - (if dest-zip - checksum-dest - (path->directory-path pkg-dir)))) + (let ([p (path->complete-path + (if dest-zip + checksum-dest + (path->directory-path pkg-dir)))]) + (if relative? + (find-relative-path catalog-dir/normal + (simplify-path p)) + p))) 'checksum checksum 'name (path->string pkg-name) 'author (string-join (for/list ([r (get 'pkg-authors)]) diff --git a/pkgs/distro-build-pkgs/distro-build-server/pack-built.rkt b/pkgs/distro-build-pkgs/distro-build-server/pack-built.rkt index 8cfa45bee4..6b458b4610 100644 --- a/pkgs/distro-build-pkgs/distro-build-server/pack-built.rkt +++ b/pkgs/distro-build-pkgs/distro-build-server/pack-built.rkt @@ -5,6 +5,7 @@ net/url racket/set racket/file + racket/path openssl/sha1 racket/cmdline) @@ -23,7 +24,8 @@ (define dest-dir (build-path build-dir (~a create-mode))) (define native-dir (build-path build-dir "native" "pkgs")) (define pkg-dest-dir (path->complete-path (build-path dest-dir "pkgs"))) -(define catalog-dir (build-path dest-dir "catalog" "pkg")) +(define catalog-dir (build-path dest-dir "catalog")) +(define catalog-pkg-dir (build-path catalog-dir "pkg")) (make-directory* pkg-dest-dir) (make-directory* catalog-dir) @@ -36,10 +38,12 @@ #:dest pkg-dest-dir #:mode create-mode) (call-with-output-file* - (build-path catalog-dir pkg) + (build-path catalog-pkg-dir pkg) #:exists 'truncate (lambda (o) - (write (hash 'source (path->string dest-zip) + (write (hash 'source (path->string (find-relative-path + (simple-form-path catalog-dir) + (simple-form-path dest-zip))) 'checksum (call-with-input-file* dest-zip sha1) 'name pkg 'author "plt@racket-lang.org" diff --git a/pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt b/pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt index 11ad01faf3..3e36907b69 100644 --- a/pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt +++ b/pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt @@ -47,37 +47,20 @@ (define dirs (list built-dir native-dir)) (define (pkg-name->info req name) - (define (extract-host-header sel) - (for/or ([h (in-list (request-headers/raw req))]) - (and (equal? (header-field h) #"Host") - (let ([m (regexp-match #rx#"^(.*):([0-9]+)$" - (header-value h))]) - (and m - (sel (list (bytes->string/utf-8 (cadr m)) - (string->number (bytes->string/utf-8 (caddr m)))))))))) (for/or ([d (in-list dirs)]) (define f (build-path d "catalog" "pkg" name)) (and (file-exists? f) - (let ([h (call-with-input-file* + ;; Change leading "../" to "./" in source, because + ;; we've shifted "pkg" relative to the site root + ;; by skipping over "catalog" in the URL. + (let ([ht (call-with-input-file* f read)]) - (define s (hash-ref h 'source)) - (hash-set h + (hash-set ht 'source - (url->string - (url "http" - #f - (or (extract-host-header car) - (let ([h (request-host-ip req)]) - (if (equal? h "::1") - "localhost" - h))) - (or (extract-host-header cadr) - (request-host-port req)) - #t - (list (path/param (~a name ".zip") null)) - null - #f))))))) + (regexp-replace #rx"^[.][.]/" + (hash-ref ht 'source) + "./")))))) (define (response/sexpr v) (response 200 #"Okay" (current-seconds) @@ -160,8 +143,9 @@ (append (list (build-path build-dir "origin")) (list readmes-dir) + ;; for "pkgs" directories: (for/list ([d (in-list dirs)]) - (path->complete-path (build-path d "pkgs"))) + (path->complete-path d)) ;; for ".git": (list (current-directory))) #:servlet-regexp #rx""