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

distro-build: fix catalog relative paths

Browse Source 
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
This commit is contained in:
Matthew Flatt 2014-05-09 09:45:26 -06:00
parent c043fed508
commit 0bde624aa5
2 changed files with 17 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/distro-build-pkgs/distro-build-server/pack-built.rkt
View File

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

36
pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt
View File

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