www

commit 0bde624aa5d71573156453770a43f70e00774a19
parent c043fed508ade6f520b04843b38cf8c44765c629
Author: Matthew Flatt <mflatt@racket-lang.org>
Date:   Fri,  9 May 2014 09:45:26 -0600

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.

original commit: 718cbd4c419cc8532511ddf8d108975835709aea

Diffstat:
M
pkgs/distro-build-pkgs/distro-build-server/pack-built.rkt
 | 
10
+++++++---
M
pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt
 | 
36
++++++++++--------------------------

2 files changed, 17 insertions(+), 29 deletions(-)
diff --git 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
@@ -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""