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

@@ -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:

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)])

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"

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""