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

- make the planet module resolver thread safe

Browse Source 
- fixed planet to actually use the uninstalled (.plt file) cache

- linkage code was completely broken, so it now stubbed out (see the file to
  resurrect it)

- other minor cleanups
This commit is contained in:
Robby Findler 2011-08-10 12:45:47 -05:00
parent de732dd538
commit cc4de51fb0
7 changed files with 683 additions and 311 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

305
collects/planet/private/linkage.rkt
View File

@ -1,141 +1,178 @@
(module linkage mzscheme #lang racket/base
(require "planet-shared.rkt"
"../config.rkt"
mzlib/match)
(provide get/linkage (require "planet-shared.rkt"
get-linkage "../config.rkt"
add-linkage! racket/match
remove-linkage-to! racket/file)
remove-all-linkage!)
; ==========================================================================================
; PHASE 1: LINKAGE
; The first check is to see if there is a valid linkage for the module.
; ==========================================================================================
;; get/linkage : pkg-getter [see ../resolver.rkt] (provide get/linkage
;; getter for the linkage table get-linkage
(define (get/linkage rmp pkg-specifier success-k failure-k) add-linkage!
(let ([linked-pkg (get-linkage rmp pkg-specifier)]) remove-linkage-to!
(if linked-pkg remove-all-linkage!
(success-k linked-pkg) current-linkage)
(failure-k
void ; ==========================================================================================
(λ (pkg) (add-linkage! rmp pkg-specifier pkg)) ; PHASE 1: LINKAGE
(λ (x) x))))) ; The first check is to see if there is a valid linkage for the module.
; ==========================================================================================
;; NOTE :: right now we have a nasty situation with the linkage-table: it doesn't associate ;; get/linkage : pkg-getter [see ../resolver.rkt]
;; keys to packages, which it seems it should. Instead it associates keys to the arguments ;; getter for the linkage table
;; to the pkg-spec constructor; this is done to facilitate reading the data from disk but (define (get/linkage rmp pkg-specifier success-k failure-k)
;; causes ugliness in add-linkage! where we have the actual package but have to break it down (let ([linked-pkg (get-linkage rmp pkg-specifier)])
;; so the arguments needed to reconstitute it can be stored. (if linked-pkg
(success-k linked-pkg)
(failure-k
; LINKAGE-TABLE ::= hash-table[LINKAGE-KEY -> PKG-LOCATION] void
(define LT #f) (λ (pkg) (add-linkage! rmp pkg-specifier pkg))
(λ (x) x)))))
; get-linkage-table : -> hash-table[LINKAGE-KEY -> PKG-LOCATION]
(define (get-linkage-table)
(unless (file-exists? (LINKAGE-FILE)) (with-output-to-file (LINKAGE-FILE) newline)) (define (get-linkage rmp pkg-specifier) #f)
(unless LT (set! LT (build-hash-table (with-input-from-file (LINKAGE-FILE) read-all)))) (define (add-linkage! rmp pkg-specifier pkg) pkg)
LT) (define (remove-linkage-to! pkg) (void))
(define (remove-all-linkage!) (void))
; add-linkage! : (resolved-module-path | #f) FULL-PKG-SPEC PKG -> PKG (define (current-linkage) '())
; unless the first argument is #f, associates the pair of the first two arguments
; with the last in the linkage table. Returns the given package-location ;; The linkage stuff is completely broken.
(define (add-linkage! rmp pkg-spec pkg) ;; See get-linkage below for why.
(when rmp ;;
(let ((key (get-key rmp pkg-spec))) ;; Since it has been completely broken since
(hash-table-get ;; sometime in late 2005 or early 2006, the
(get-linkage-table) ;; above 5 functions are a substite for the
key ;; below that just do nothing
(lambda () ;;
(let ((plist (pkg-as-list pkg))) ;; In addition to the noted problem below, this
(begin ;; code is not thread safe, which is why is now
(hash-table-put! (get-linkage-table) key plist) ;; being replaced by code that actually does
(with-output-to-file (LINKAGE-FILE) ;; nothing (and thus is thread safe).
(lambda () (write (list key plist)))
'append)))))))
pkg) #|
;; remove-linkage! pkg-spec -> void ;; NOTE :: right now we have a nasty situation with the linkage-table: it doesn't associate
;; eliminates linkage to the given package ;; keys to packages, which it seems it should. Instead it associates keys to the arguments
(define (remove-linkage-to! pkg) ;; to the pkg-spec constructor; this is done to facilitate reading the data from disk but
(let ((l (get-linkage-table))) ;; causes ugliness in add-linkage! where we have the actual package but have to break it down
;; so the arguments needed to reconstitute it can be stored.
;; first remove bad entries from the in-memory hash table
(hash-table-for-each
l ; LINKAGE-TABLE ::= hash-table[LINKAGE-KEY -> PKG-LOCATION]
(lambda (k v) (define LT #f)
(match v
[(name route maj min _) ; get-linkage-table : -> hash-table[LINKAGE-KEY -> PKG-LOCATION]
(when (and (equal? name (pkg-name pkg)) (define (get-linkage-table)
(equal? route (pkg-route pkg)) (unless (file-exists? (LINKAGE-FILE)) (with-output-to-file (LINKAGE-FILE) newline))
(= maj (pkg-maj pkg)) (unless LT (set! LT (build-hash-table (with-input-from-file (LINKAGE-FILE) read-all))))
(= min (pkg-min pkg))) LT)
(hash-table-remove! l k))]
[_ (void)]))) ; add-linkage! : (resolved-module-path | #f) FULL-PKG-SPEC PKG -> PKG
; unless the first argument is #f, associates the pair of the first two arguments
;; now write the new table out to disk to keep it in sync ; with the last in the linkage table. Returns the given package-location
(with-output-to-file (LINKAGE-FILE) (define (add-linkage! rmp pkg-spec pkg)
(lambda () (when rmp
(printf "\n") (let ((key (get-key rmp pkg-spec)))
(hash-table-for-each (hash-ref
l (get-linkage-table)
(lambda (k v) (write (list k v))))) key
'truncate/replace))) (lambda ()
(let ((plist (pkg-as-list pkg)))
;; kill the whole linkage-table (begin
(define (remove-all-linkage!) (hash-set! (get-linkage-table) key plist)
(with-output-to-file (LINKAGE-FILE)
(lambda () (write (list key plist)))
#:exists 'append)))))))
pkg)
;; remove-linkage! pkg-spec -> void
;; eliminates linkage to the given package
(define (remove-linkage-to! pkg)
(let ((l (get-linkage-table)))
;; first remove bad entries from the in-memory hash table
(hash-for-each
l
(lambda (k v)
(match v
[(list name route maj min _)
(when (and (equal? name (pkg-name pkg))
(equal? route (pkg-route pkg))
(= maj (pkg-maj pkg))
(= min (pkg-min pkg)))
(hash-remove! l k))]
[_ (void)])))
;; now write the new table out to disk to keep it in sync
(with-output-to-file (LINKAGE-FILE) (with-output-to-file (LINKAGE-FILE)
(lambda () (printf "\n")) (lambda ()
'truncate/replace) (printf "\n")
(set! LT #f)) (hash-for-each
l
;; pkg-as-list : PKG -> (list string string nat nat bytes[path]) (lambda (k v) (write (list k v)))))
(define (pkg-as-list pkg) #:exists 'truncate/replace)))
(list (pkg-name pkg)
(pkg-route pkg) ;; kill the whole linkage-table
(pkg-maj pkg) (define (remove-all-linkage!)
(pkg-min pkg) (with-output-to-file (LINKAGE-FILE)
(path->bytes (pkg-path pkg)))) (lambda () (printf "\n"))
#:exists 'truncate/replace)
(set! LT #f))
;; pkg-as-list : PKG -> (list string string nat nat bytes[path])
(define (pkg-as-list pkg)
(list (pkg-name pkg)
(pkg-route pkg)
(pkg-maj pkg)
(pkg-min pkg)
(path->bytes (pkg-path pkg))))
; get-linkage : (resolved-module-path | #f) FULL-PKG-SPEC -> PKG | #f
; returns the already-linked module location, or #f if there is none
(define (get-linkage rmp pkg-specifier)
(cond
[rmp
(let ((pkg-fields (hash-table-get
(get-linkage-table)
(get-key rmp pkg-specifier)
(lambda () #f))))
(if pkg-fields
(with-handlers ([exn:fail? (lambda (e) #f)])
(match-let ([(name route maj min pathbytes) pkg-fields])
(make-pkg name route maj min (bytes->path pathbytes))))
#f))]
[else #f]))
; get-key : resolved-module-path? FULL-PKG-SPEC -> LINKAGE-KEY
; produces a linkage key for the given pair.
(define (get-key rmp pkg-spec)
(list* (get-module-id rmp)
(pkg-spec-name pkg-spec)
(pkg-spec-maj pkg-spec)
(pkg-spec-minor-lo pkg-spec)
(pkg-spec-minor-hi pkg-spec)
(pkg-spec-path pkg-spec)))
; get-module-id : resolved-module-path? -> LINKAGE-MODULE-KEY
; key suitable for marshalling that represents the given resolved-module-path
(define (get-module-id rmp)
(path->string (resolved-module-path-name rmp)))
)
; get-linkage : (resolved-module-path | #f) FULL-PKG-SPEC -> PKG | #f
; returns the already-linked module location, or #f if there is none
(define (get-linkage rmp pkg-specifier)
(cond
[rmp
(let ((pkg-fields (hash-ref
(get-linkage-table)
(get-key rmp pkg-specifier)
(lambda () #f))))
(if pkg-fields
(with-handlers ([exn:fail? (lambda (e) #f)])
(match-let ([(list name route maj min pathbytes) pkg-fields])
;; this arity error in the line just below
;; means that get-linkage always returns #f.
(make-pkg name route maj min (bytes->path pathbytes))))
#f))]
[else #f]))
; get-key : resolved-module-path? FULL-PKG-SPEC -> LINKAGE-KEY
; produces a linkage key for the given pair.
(define (get-key rmp pkg-spec)
(list* (get-module-id rmp)
(pkg-spec-name pkg-spec)
(pkg-spec-maj pkg-spec)
(pkg-spec-minor-lo pkg-spec)
(pkg-spec-minor-hi pkg-spec)
(pkg-spec-path pkg-spec)))
; get-module-id : resolved-module-path? -> LINKAGE-MODULE-KEY
; key suitable for marshalling that represents the given resolved-module-path
(define (get-module-id rmp)
(path->string (resolved-module-path-name rmp)))
;; current-linkage : -> ((symbol (package-name nat nat) ...) ...)
;; gives the current "linkage table"; a table that links modules to particular versions
;; of planet requires that satisfy those linkages
(define (current-linkage)
(let* ((links
(if (file-exists? (LINKAGE-FILE))
(with-input-from-file (LINKAGE-FILE) read-all)
'()))
(buckets (categorize caar links)))
(map
(lambda (x) (cons (car x) (map (lambda (y) (drop-last (cadr y))) (cdr x))))
buckets)))
|#

332
collects/planet/private/planet-shared.rkt
View File

@ -13,8 +13,73 @@ Various common pieces of code that both the client and server need to access
"../config.rkt" "../config.rkt"
"data.rkt") "data.rkt")
(provide (all-defined-out) (provide (all-from-out "data.rkt")
(all-from-out "data.rkt")) (struct-out exn:fail:filesystem:no-directory)
(struct-out mz-version)
(struct-out branch)
(struct-out star)
try-make-directory*
language-version->repository
version->description
legal-language?
lookup-package
lookup-package-by-keys
empty-table
get-min-core-version
points-to?
row->package
add-hard-link!
filter-link-table!
get-hard-link-table
update-element
update/create-element
first-n-list-selectors
make-assoc-table-row
string->mz-version
version<=
pkg<
pkg>
pkg=
compatible-version?
get-best-match
get-installed-package
make-cutoff-port
write-line
for-each/n
nat?
read-n-chars-to-file
copy-n-chars
repeat-forever
build-hash-table
categorize
drop-last
read-all
wrap
planet-logging-to-stdout
planet-log
with-logging
pkg->info
directory->tree
filter-tree-by-pattern
tree-apply
tree->list
repository-tree
assoc-table-row->name
assoc-table-row->path
assoc-table-row->maj
assoc-table-row->min
assoc-table-row->dir
assoc-table-row->required-version
assoc-table-row->type
check/take-installation-lock
installed-successfully?
release-installation-lock
dir->successful-installation-file
dir->metadata-files)
; ========================================================================================== ; ==========================================================================================
; CACHE LOGIC ; CACHE LOGIC
@ -41,12 +106,17 @@ Various common pieces of code that both the client and server need to access
; lookup-package : FULL-PKG-SPEC [path (optional)] -> PKG | #f ; lookup-package : FULL-PKG-SPEC [path (optional)] -> PKG | #f
; returns the directory pointing to the appropriate package in the cache, the user's hardlink table, ; returns the directory pointing to the appropriate package in the cache, the user's hardlink table,
; or #f if the given package isn't in the cache or the hardlink table ; or #f if the given package isn't in the cache or the hardlink table
(define lookup-package (define (lookup-package pkg [dir (CACHE-DIR)] #:check-success? [check-success? #f])
(case-lambda (define at (build-assoc-table pkg dir check-success?))
[(pkg) (lookup-package pkg (CACHE-DIR))] (get-best-match at pkg))
[(pkg dir)
(let* ((at (build-assoc-table pkg dir))) ; build-assoc-table : FULL-PKG-SPEC path -> assoc-table
(get-best-match at pkg))])) ; returns a version-number -> directory association table for the given package
(define (build-assoc-table pkg dir check-success?)
(append
(pkg->assoc-table pkg dir check-success?)
(hard-links pkg)))
;; lookup-package-by-keys : string string nat nat nat -> (list path string string (listof string) nat nat) | #f ;; lookup-package-by-keys : string string nat nat nat -> (list path string string (listof string) nat nat) | #f
;; looks up and returns a list representation of the package named by the given owner, ;; looks up and returns a list representation of the package named by the given owner,
@ -74,13 +144,6 @@ Various common pieces of code that both the client and server need to access
#f))) #f)))
; build-assoc-table : FULL-PKG-SPEC path -> assoc-table
; returns a version-number -> directory association table for the given package
(define (build-assoc-table pkg dir)
(add-to-table
(pkg->assoc-table pkg dir)
(hard-links pkg)))
;; assoc-table ::= (listof (list n n path)) ;; assoc-table ::= (listof (list n n path))
(define empty-table '()) (define empty-table '())
@ -95,10 +158,10 @@ Various common pieces of code that both the client and server need to access
#f)) #f))
#f))) #f)))
; pkg->assoc-table : FULL-PKG-SPEC path -> assoc-table ; pkg->assoc-table : FULL-PKG-SPEC path boolean? -> assoc-table
; returns the on-disk packages for the given planet package in the ; returns the on-disk packages for the given planet package in the
; on-disk table rooted at the given directory ; on-disk table rooted at the given directory
(define (pkg->assoc-table pkg dir) (define (pkg->assoc-table pkg dir check-success?)
(define path (build-path (apply build-path dir (pkg-spec-path pkg)) (pkg-spec-name pkg))) (define path (build-path (apply build-path dir (pkg-spec-path pkg)) (pkg-spec-name pkg)))
(define (tree-stuff->row-or-false p majs mins) (define (tree-stuff->row-or-false p majs mins)
@ -107,15 +170,16 @@ Various common pieces of code that both the client and server need to access
(if (and (path? p) maj min) (if (and (path? p) maj min)
(let* ((the-path (build-path path majs mins)) (let* ((the-path (build-path path majs mins))
(min-core-version (get-min-core-version the-path))) (min-core-version (get-min-core-version the-path)))
(make-assoc-table-row (and (or (not check-success?)
(pkg-spec-name pkg) (installed-successfully? the-path))
(pkg-spec-path pkg) (make-assoc-table-row
maj min (pkg-spec-name pkg)
the-path (pkg-spec-path pkg)
min-core-version maj min
'normal)) the-path
min-core-version
'normal)))
#f))) #f)))
(if (directory-exists? path) (if (directory-exists? path)
(filter (filter
(λ (x) x) (λ (x) x)
@ -138,21 +202,41 @@ Various common pieces of code that both the client and server need to access
;; verify-well-formed-hard-link-parameter! : -> void ;; verify-well-formed-hard-link-parameter! : -> void
;; pitches a fit if the hard link table parameter isn't set right ;; pitches a fit if the hard link table parameter isn't set right
(define (verify-well-formed-hard-link-parameter!) (define (verify-well-formed-hard-link-parameter!)
(unless (and (absolute-path? (HARD-LINK-FILE)) (path-only (HARD-LINK-FILE))) (define hlf (HARD-LINK-FILE))
(unless (and (absolute-path? hlf) (path-only hlf))
(raise (make-exn:fail:contract (raise (make-exn:fail:contract
(format (format
"The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s" "The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s"
(HARD-LINK-FILE)) hlf)
(current-continuation-marks))))) (current-continuation-marks)))))
;; get-hard-link-table : -> assoc-table ;; get-hard-link-table/internal : -> assoc-table
(define (get-hard-link-table) (define (get-hard-link-table/internal)
(verify-well-formed-hard-link-parameter!) (verify-well-formed-hard-link-parameter!)
(if (file-exists? (HARD-LINK-FILE)) (if (file-exists? (HARD-LINK-FILE))
(map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item))) (map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item)))
(with-input-from-file (HARD-LINK-FILE) read-all)) (with-input-from-file (HARD-LINK-FILE) read-all))
'())) '()))
(define (with-hard-link-lock t)
(let-values ([(base name dir) (split-path (HARD-LINK-FILE))])
(try-make-directory* base))
(call-with-file-lock/timeout
(HARD-LINK-FILE)
'exclusive
t
(λ ()
(error 'planet/planet-shared.rkt "unable to obtain lock on ~s" (HARD-LINK-FILE)))))
(define (get-hard-link-table)
;; we can only call with-hard-link-lock when the directory containing
;; (HARD-LINK-FILE) exists
(if (file-exists? (HARD-LINK-FILE))
(with-hard-link-lock
(λ ()
(get-hard-link-table/internal)))
'()))
;; row-for-package? : row string (listof string) num num -> boolean ;; row-for-package? : row string (listof string) num num -> boolean
;; determines if the row associates the given package with a dir ;; determines if the row associates the given package with a dir
(define (points-to? row name path maj min) (define (points-to? row name path maj min)
@ -171,10 +255,9 @@ Various common pieces of code that both the client and server need to access
;; save-hard-link-table : assoc-table -> void ;; save-hard-link-table : assoc-table -> void
;; saves the given table, overwriting any file that might be there ;; saves the given table, overwriting any file that might be there
;; assumes that the lock on the HARD-LINK table file has been acquired
(define (save-hard-link-table table) (define (save-hard-link-table table)
(verify-well-formed-hard-link-parameter!) (verify-well-formed-hard-link-parameter!)
(let-values ([(base name dir) (split-path (HARD-LINK-FILE))])
(make-directory* base))
(with-output-to-file (HARD-LINK-FILE) #:exists 'truncate (with-output-to-file (HARD-LINK-FILE) #:exists 'truncate
(lambda () (lambda ()
(display "") (display "")
@ -188,23 +271,29 @@ Various common pieces of code that both the client and server need to access
;; adds the given hard link, clearing any previous ones already in place ;; adds the given hard link, clearing any previous ones already in place
;; for the same package ;; for the same package
(define (add-hard-link! name path maj min dir) (define (add-hard-link! name path maj min dir)
(let ([complete-dir (path->complete-path dir)]) (with-hard-link-lock
(let* ([original-table (get-hard-link-table)] (λ ()
[new-table (cons (let ([complete-dir (path->complete-path dir)])
(make-assoc-table-row name path maj min complete-dir #f 'development-link) (let* ([original-table (get-hard-link-table/internal)]
(filter [new-table (cons
(lambda (row) (not (points-to? row name path maj min))) (make-assoc-table-row name path maj min complete-dir #f 'development-link)
original-table))]) (filter
(save-hard-link-table new-table)))) (lambda (row) (not (points-to? row name path maj min)))
original-table))])
(save-hard-link-table new-table))))))
;; filter-link-table! : (row -> boolean) (row -> any/c) -> void ;; filter-link-table! : (row -> boolean) (row -> any/c) -> void
;; removes all rows from the hard link table that don't match the given predicate. ;; removes all rows from the hard link table that don't match the given predicate.
;; also updates auxiliary datastructures that might have dangling pointers to ;; also updates auxiliary datastructures that might have dangling pointers to
;; the removed links ;; the removed links
(define (filter-link-table! f on-delete) (define (filter-link-table! f on-delete)
(let-values ([(in-links out-links) (srfi1:partition f (get-hard-link-table))]) (define out-links
(for-each on-delete out-links) (with-hard-link-lock
(save-hard-link-table in-links))) (λ ()
(let-values ([(in-links out-links) (srfi1:partition f (get-hard-link-table/internal))])
(save-hard-link-table in-links)
out-links))))
(for-each on-delete out-links))
;; update-element : number (x -> y) (listof any [x in position number]) -> (listof any [y in position number]) ;; update-element : number (x -> y) (listof any [x in position number]) -> (listof any [y in position number])
(define (update-element n f l) (define (update-element n f l)
@ -223,10 +312,6 @@ Various common pieces of code that both the client and server need to access
(cons (f (car l)) (cdr l))] (cons (f (car l)) (cdr l))]
[else (cons (car l) (update/create-element (sub1 n) f (cdr l)))])) [else (cons (car l) (update/create-element (sub1 n) f (cdr l)))]))
; add-to-table assoc-table (listof assoc-table-row) -> assoc-table
(define add-to-table append)
;; first-n-list-selectors : number -> (values (listof x -> x) ...) ;; first-n-list-selectors : number -> (values (listof x -> x) ...)
;; returns n list selectors for the first n elements of a list ;; returns n list selectors for the first n elements of a list
;; (useful for defining meaningful names to list-structured data) ;; (useful for defining meaningful names to list-structured data)
@ -547,24 +632,23 @@ Various common pieces of code that both the client and server need to access
(define-struct (exn:fail:filesystem:no-directory exn:fail:filesystem) (dir)) (define-struct (exn:fail:filesystem:no-directory exn:fail:filesystem) (dir))
;; directory->tree : directory (string -> bool) [nat | bool] [path->X] -> tree[X] | #f ;; directory->tree : directory (string -> bool) [nat | bool] [path->X] -> tree[X] | #f
(define directory->tree (define (directory->tree directory valid-dir? [max-depth #f] [path->x path->string])
(lambda (directory valid-dir? [max-depth #f] [path->x path->string]) (unless (directory-exists? directory)
(unless (directory-exists? directory) (raise (make-exn:fail:filesystem:no-directory
(raise (make-exn:fail:filesystem:no-directory "Directory ~s does not exist"
"Directory ~s does not exist" (current-continuation-marks)
(current-continuation-marks) directory)))
directory))) (let-values ([(path name _) (split-path directory)])
(let-values ([(path name _) (split-path directory)]) (let* ((files (directory-list directory))
(let* ((files (directory-list directory)) (files (map (lambda (d) (build-path directory d)) files))
(files (map (lambda (d) (build-path directory d)) files)) (files (filter (lambda (d) (and (directory-exists? d) (valid-dir? d))) files)))
(files (filter (lambda (d) (and (directory-exists? d) (valid-dir? d))) files))) (make-branch
(make-branch (path->x name)
(path->x name) ;; NOTE: the above line should not use path->string. I don't have time to track this down though
;; NOTE: the above line should not use path->string. I don't have time to track this down though (if (equal? max-depth 0)
(if (equal? max-depth 0) '()
'() (let ((next-depth (if max-depth (sub1 max-depth) #f)))
(let ((next-depth (if max-depth (sub1 max-depth) #f))) (map (lambda (d) (directory->tree d valid-dir? next-depth)) files)))))))
(map (lambda (d) (directory->tree d valid-dir? next-depth)) files))))))))
;; filter-pattern : (listof pattern-term) ;; filter-pattern : (listof pattern-term)
;; pattern-term : (x -> y) | (make-star (tst -> bool) (x -> y)) ;; pattern-term : (x -> y) | (make-star (tst -> bool) (x -> y))
@ -594,20 +678,23 @@ Various common pieces of code that both the client and server need to access
;; tree-apply : (... -> tst) tree -> listof tst ;; tree-apply : (... -> tst) tree -> listof tst
;; applies f to every path from root to leaf and ;; applies f to every path from root to leaf and
;; accumulates all results in a list ;; accumulates all results in a list
(define tree-apply (define (tree-apply f t [depth 0])
(lambda (f t [depth 0]) (let loop ((t t)
(let loop ((t t) (priors '())
(priors '()) (curr-depth 0))
(curr-depth 0)) (cond
(cond [(null? (branch-children t))
[(null? (branch-children t)) (if (> curr-depth depth)
(if (> curr-depth depth) (let ([args (reverse (cons (branch-node t) priors))])
(list (apply f (reverse (cons (branch-node t) priors)))) (if (procedure-arity-includes? f (length args))
'())] (list (apply f args))
[else '()))
(let ((args (cons (branch-node t) priors))) '())]
(apply append [else
(map (lambda (x) (loop x args (add1 curr-depth))) (branch-children t))))])))) (let ((args (cons (branch-node t) priors)))
(apply append
(map (λ (x) (loop x args (add1 curr-depth)))
(branch-children t))))])))
;; tree->list : tree[x] -> sexp-tree[x] ;; tree->list : tree[x] -> sexp-tree[x]
(define (tree->list tree) (define (tree->list tree)
@ -624,3 +711,92 @@ Various common pieces of code that both the client and server need to access
(not (regexp-match? #rx"/(?:[.]git.*|[.]svn|CVS)$" (path->string x)))) (not (regexp-match? #rx"/(?:[.]git.*|[.]svn|CVS)$" (path->string x))))
4) 4)
(list id id id string->number string->number))) (list id id id string->number string->number)))
;; try-make-directory* : path[directory] -> void
;; tries multiple times to make the directory 'dir'
;; we only expect the second (or later) attempt to succeed
;; when two calls to try-make-directory* happen in parallel
;; (in separate places); this is here to avoid having to use
;; a lock
(define (try-make-directory* dir)
(let loop ([n 10])
(cond
[(zero? n)
(make-directory* dir)]
[else
(with-handlers ((exn:fail:filesystem? (λ (x) (loop (- n 1)))))
(make-directory* dir))])))
;
;
;
;
; ;;; ; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;; ;;;; ;;;; ;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;; ;; ;;;
; ;;; ;;;;;;; ;;; ;; ;;;; ;;;;;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;; ;;; ;;; ;;;;;;; ;;;;;;;
; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;;;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;;; ;;; ;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;;;;;; ;;; ;;; ;;; ;;; ;;;
; ;;; ;;; ;;; ;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;;
; ;;; ;;; ;;; ;;;; ;;; ;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;; ;;;
; ;;;
; ;;;;;;
;
;
;; check/take-installation-lock : path -> (or/c port #f)
;; if this function returns #t, then it successfully
;; optained the installation lock.
;; if it returns #f, then we tried to grab the lock, but someone
;; else already had it, so we waited until that installation finished
(define (check/take-installation-lock dir)
(define lf (dir->lock-file dir))
;; make sure the lock file exists
(with-handlers ((exn:fail:filesystem:exists? void))
(call-with-output-file lf void))
(define p (open-output-file lf #:exists 'truncate))
(cond
[(port-try-file-lock? p 'exclusive)
;; we got the lock; keep the file open
p]
[else
;; we didn't get the lock; poll for the SUCCESS FILE
(planet-log "waiting for someone else to finish installation in ~s" dir)
(let loop ()
(cond
[(file-exists? (dir->successful-installation-file dir))
(planet-log "continuing; someone else finished installation in ~s" dir)
#f]
[else
(sleep 2)
(loop)]))]))
;; release-installation-lock : port -> void
;; call this function when check/take-intallation-lock returns #t
;; (and the installation has finished)
;; SIDE-EFFECT: creates the SUCCESS file (before releasing the lock)
(define (release-installation-lock port)
(close-output-port port))
(define (installed-successfully? dir)
(file-exists? (dir->successful-installation-file dir)))
(define (dir->successful-installation-file dir)
(define-values (base name dir?) (split-path dir))
(build-path base (bytes->path (bytes-append (path->bytes name) #".SUCCESS"))))
(define (dir->lock-file dir)
(define-values (base name dir?) (split-path dir))
(build-path base (bytes->path (bytes-append (path->bytes name) #".LOCK"))))
(define (dir->metadata-files dir)
(list (dir->lock-file dir)
(dir->successful-installation-file dir)))

150
collects/planet/private/resolver.rkt
View File

@ -27,7 +27,7 @@ FILE-NAME ::= string
PKG-SPEC ::= string | (FILE-PATH ... PKG-NAME) PKG-SPEC ::= string | (FILE-PATH ... PKG-NAME)
| (FILE-PATH ... PKG-NAME VER-SPEC) | (FILE-PATH ... PKG-NAME VER-SPEC)
VER-SPEC ::= Nat | (Nat MINOR) VER-SPEC ::= Nat | (Nat MINOR)
MINOR ::= Nat | (Nat Nat) | (= Nat) | (+ Nat) | (- Nat) MINOR ::= Nat | (Nat Nat) | (= Nat) | (+ Nat) | (- Nat)
FILE-PATH ::= string FILE-PATH ::= string
PKG-NAME ::= string PKG-NAME ::= string
OWNER-NAME ::= string OWNER-NAME ::= string
@ -172,8 +172,8 @@ subdirectory.
[(name) (void)] [(name) (void)]
[(spec module-path stx load? orig-paramz) [(spec module-path stx load? orig-paramz)
;; ensure these directories exist ;; ensure these directories exist
(make-directory* (PLANET-DIR)) (try-make-directory* (PLANET-DIR))
(make-directory* (CACHE-DIR)) (try-make-directory* (CACHE-DIR))
(establish-diamond-property-monitor) (establish-diamond-property-monitor)
(planet-resolve spec (planet-resolve spec
(current-module-declare-name) (current-module-declare-name)
@ -303,8 +303,9 @@ subdirectory.
stx stx
(make-exn:fail (make-exn:fail
(format (format
"Package ~a loaded twice with multiple incompatible versions: (string-append
~a attempted to load version ~a.~a while version ~a.~a was already loaded by ~a" "Package ~a loaded twice with multiple incompatible versions:\n"
"~a attempted to load version ~a.~a while version ~a.~a was already loaded by ~a")
(pkg-name pkg) (pkg-name pkg)
(stx->origin-string stx) (stx->origin-string stx)
(pkg-maj pkg) (pkg-maj pkg)
@ -420,7 +421,7 @@ subdirectory.
;; get/installed-cache : pkg-getter ;; get/installed-cache : pkg-getter
(define (get/installed-cache _ pkg-spec success-k failure-k) (define (get/installed-cache _ pkg-spec success-k failure-k)
(let ([p (lookup-package pkg-spec)]) (let ([p (lookup-package pkg-spec #:check-success? #t)])
(if p (success-k p) (failure-k void void (λ (x) x))))) (if p (success-k p) (failure-k void void (λ (x) x)))))
;; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f ;; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f
@ -453,7 +454,7 @@ subdirectory.
pkg-spec pkg-spec
(pkg-maj p) (pkg-maj p)
(pkg-min p)))) (pkg-min p))))
(failure-k void void (λ (x) x))))) (failure-k void void (λ (x) x)))))
;; save-to-uninstalled-pkg-cache! : uninstalled-pkg -> path[file] ;; save-to-uninstalled-pkg-cache! : uninstalled-pkg -> path[file]
;; copies the given uninstalled package into the uninstalled-package cache, ;; copies the given uninstalled package into the uninstalled-package cache,
@ -471,11 +472,17 @@ subdirectory.
(number->string maj) (number->string maj)
(number->string min))] (number->string min))]
[full-pkg-path (build-path dir name)]) [full-pkg-path (build-path dir name)])
(make-directory* dir) (try-make-directory* dir)
(unless (equal? (normalize-path (uninstalled-pkg-path uninst-p)) (unless (equal? (normalize-path (uninstalled-pkg-path uninst-p))
(normalize-path full-pkg-path)) (normalize-path full-pkg-path))
(when (file-exists? full-pkg-path) (delete-file full-pkg-path)) (call-with-file-lock/timeout
(copy-file (uninstalled-pkg-path uninst-p) full-pkg-path)) full-pkg-path
'exclusive
(λ ()
(when (file-exists? full-pkg-path) (delete-file full-pkg-path))
(copy-file (uninstalled-pkg-path uninst-p) full-pkg-path))
(λ ()
(log-error (format "planet/resolver.rkt: unable to save the planet package ~a" full-pkg-path)))))
full-pkg-path)) full-pkg-path))
;; ============================================================================= ;; =============================================================================
@ -546,53 +553,67 @@ subdirectory.
;; install the given pkg to the planet cache and return a PKG representing the ;; install the given pkg to the planet cache and return a PKG representing the
;; installed file ;; installed file
(define (install-pkg pkg path maj min) (define (install-pkg pkg path maj min)
(let ([pkg-path (pkg-spec-path pkg)] (define pkg-path (pkg-spec-path pkg))
[pkg-name (pkg-spec-name pkg)] (define pkg-name (pkg-spec-name pkg))
[pkg-string (pkg-spec->string pkg)]) (define pkg-string (pkg-spec->string pkg))
(unless (install?) (unless (install?)
(raise (make-exn:fail:planet (raise (make-exn:fail:planet
(format (format
"PLaneT error: cannot install package ~s since the install? parameter is set to #f" "PLaneT error: cannot install package ~s since the install? parameter is set to #f"
(list (car pkg-path) pkg-name maj min)) (list (car pkg-path) pkg-name maj min))
(current-continuation-marks)))) (current-continuation-marks))))
(let* ([owner (car pkg-path)] (define owner (car pkg-path))
[extra-path (cdr pkg-path)] (define extra-path (cdr pkg-path))
[the-dir (define the-dir
(apply build-path (CACHE-DIR) (apply build-path (CACHE-DIR)
(append pkg-path (list pkg-name (append pkg-path (list pkg-name
(number->string maj) (number->string maj)
(number->string min))))] (number->string min)))))
[was-nested? (planet-nested-install)]) (define was-nested? (planet-nested-install))
(if (directory-exists? the-dir)
(raise (make-exn:fail (try-make-directory* the-dir)
"PLaneT error: trying to install already-installed package"
(current-continuation-marks))) (when (file-exists? (dir->successful-installation-file the-dir))
(parameterize ([planet-nested-install #t]) (raise (make-exn:fail
(planet-terse-log 'install pkg-string) "PLaneT error: trying to install already-installed package"
(with-logging (current-continuation-marks))))
(LOG-FILE)
(lambda () (parameterize ([planet-nested-install #t])
(printf "\n============= Installing ~a on ~a =============\n" (planet-terse-log 'install pkg-string)
pkg-name (with-logging
(current-time)) (LOG-FILE)
;; oh man is this a bad hack! (lambda ()
(parameterize ([current-namespace (make-base-namespace)])
(let ([ipp (dynamic-require 'setup/plt-single-installer (define lock/f #f)
'install-planet-package)] (dynamic-wind
[rud (dynamic-require 'setup/plt-single-installer void
'reindex-user-documentation)] (λ ()
[msfh (dynamic-require 'compiler/cm 'manager-skip-file-handler)]) (set! lock/f (check/take-installation-lock the-dir))
(parameterize ([msfh (manager-skip-file-handler)] (when lock/f
[use-compiled-file-paths (list (string->path "compiled"))]) (printf "\n============= Installing ~a on ~a =============\n"
(ipp path the-dir (list owner pkg-name pkg-name
extra-path maj min)) (current-time))
(unless was-nested? ;; oh man is this a bad hack!
(planet-terse-log 'docs-build pkg-string) (parameterize ([current-namespace (make-base-namespace)])
(printf "------------- Rebuilding documentation index -------------\n") (let ([ipp (dynamic-require 'setup/plt-single-installer
(rud))))))) 'install-planet-package)]
(planet-terse-log 'finish pkg-string) [rud (dynamic-require 'setup/plt-single-installer
(make-pkg pkg-name pkg-path 'reindex-user-documentation)]
maj min the-dir 'normal)))))) [msfh (dynamic-require 'compiler/cm 'manager-skip-file-handler)])
(parameterize ([msfh (manager-skip-file-handler)]
[use-compiled-file-paths (list (string->path "compiled"))])
(ipp path the-dir (list owner pkg-name
extra-path maj min))
(unless was-nested?
(planet-terse-log 'docs-build pkg-string)
(printf "------------- Rebuilding documentation index -------------\n")
(rud)))))
(call-with-output-file (dir->successful-installation-file the-dir) void)))
(λ () (when lock/f
(release-installation-lock lock/f))))))
(planet-terse-log 'finish pkg-string)
(make-pkg pkg-name pkg-path
maj min the-dir 'normal)))
;; download-package : FULL-PKG-SPEC -> RESPONSE ;; download-package : FULL-PKG-SPEC -> RESPONSE
;; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat) ;; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat)
@ -603,12 +624,11 @@ subdirectory.
;; raises an exception if some protocol failure occurs in the download process ;; raises an exception if some protocol failure occurs in the download process
(define (download-package/planet pkg) (define (download-package/planet pkg)
(define stupid-internal-define-syntax (let ([msg (format "downloading ~a from ~a via planet protocol"
(let ([msg (format "downloading ~a from ~a via planet protocol" (pkg-spec->string pkg)
(pkg-spec->string pkg) (PLANET-SERVER-NAME))])
(PLANET-SERVER-NAME))]) (planet-terse-log 'download (pkg-spec->string pkg))
(planet-terse-log 'download (pkg-spec->string pkg)) (planet-log msg))
(planet-log msg)))
(define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT))) (define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))
@ -795,9 +815,9 @@ subdirectory.
(make-parameter (make-parameter
(list get/linkage (list get/linkage
get/installed-cache get/installed-cache
get/uninstalled-cache
get/uninstalled-cache-dummy get/uninstalled-cache-dummy
get/server get/server)))
get/uninstalled-cache)))
;; ============================================================ ;; ============================================================
;; UTILITY ;; UTILITY

7
collects/planet/private/util.scrbl
View File

@ -337,7 +337,7 @@ into the given directory (creating that path if necessary).}
[maj natural-number/c] [maj natural-number/c]
[min natural-number/c]) [min natural-number/c])
any]{ any]{
Removes the specified package from the local planet cache. Removes the specified package from the local planet cache, deleting the installed files.
} }
@defproc[(erase-pkg [owner string?] @defproc[(erase-pkg [owner string?]
@ -345,8 +345,9 @@ Removes the specified package from the local planet cache.
[maj natural-number/c] [maj natural-number/c]
[min natural-number/c]) [min natural-number/c])
any]{ any]{
Removes the specified package from the local planet cache and deletes Like @racket[remove-pkg], removes the specified package from the local planet cache and deletes
all of the files corresponding to the package. all of the files corresponding to the package, but also deletes the cached @filepath{.plt} file
(so it will be redownloaded later).
} }
@defproc[(display-plt-file-structure [plt-file (or/c path-string? path?)]) @defproc[(display-plt-file-structure [plt-file (or/c path-string? path?)])

88
collects/planet/util.rkt
View File

@ -130,7 +130,10 @@
(clean-planet-package path (list owner name '() maj min)))) (clean-planet-package path (list owner name '() maj min))))
(planet-log "Erasing metadata") (planet-log "Erasing metadata")
(erase-metadata p) (erase-metadata p)
(planet-log "Deleting files in ~a" (path->string path)) (planet-log "Deleting metadata and files in ~a" (path->string path))
(for ([file (in-list (dir->metadata-files path))])
(with-handlers ((exn:fail:filesystem? void))
(delete-file file)))
(delete-directory/files path) (delete-directory/files path)
(planet-log "Trimming empty directories") (planet-log "Trimming empty directories")
(trim-directory (CACHE-DIR) path) (trim-directory (CACHE-DIR) path)
@ -248,19 +251,6 @@
(loop (cdr dirs))] (loop (cdr dirs))]
[else (void)])))) [else (void)]))))
;; current-linkage : -> ((symbol (package-name nat nat) ...) ...)
;; gives the current "linkage table"; a table that links modules to particular versions
;; of planet requires that satisfy those linkages
(define (current-linkage)
(let* ((links
(if (file-exists? (LINKAGE-FILE))
(with-input-from-file (LINKAGE-FILE) read-all)
'()))
(buckets (categorize caar links)))
(map
(lambda (x) (cons (car x) (map (lambda (y) (drop-last (cadr y))) (cdr x))))
buckets)))
;; regexp->filter : (string | regexp) -> (path -> bool) ;; regexp->filter : (string | regexp) -> (path -> bool)
;; computes a filter that accepts paths that match the given regexps and rejects other paths ;; computes a filter that accepts paths that match the given regexps and rejects other paths
(define (regexp->filter re-s) (define (regexp->filter re-s)
@ -397,7 +387,9 @@
(cons (format "Error generating scribble documentation: ~a" (render-exn e)) (cons (format "Error generating scribble documentation: ~a" (render-exn e))
critical-errors)))]) critical-errors)))])
(unless (list? scribble-files) (unless (list? scribble-files)
(error (format "malformed scribblings field; expected (listof (list string (listof symbol))), received ~e" (error (format (string-append
"malformed scribblings field; expected"
" (listof (list string (listof symbol))), received ~e")
scribble-files))) scribble-files)))
(for ([entry scribble-files]) (for ([entry scribble-files])
(unless (scribble-entry? entry) (unless (scribble-entry? entry)
@ -407,7 +399,9 @@
(unless (and (relative-path? filename) (unless (and (relative-path? filename)
(subpath? abs-dir filename) (subpath? abs-dir filename)
(bytes=? (filename-extension filename) #"scrbl")) (bytes=? (filename-extension filename) #"scrbl"))
(error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory")) (error (string-append
"illegal scribblings file ~a (must be a file with"
" extension .scrbl in the package directory or a subdirectory")))
(unless (file-exists? (build-path abs-dir filename)) (unless (file-exists? (build-path abs-dir filename))
(error (format "scribblings file ~a not found" filename))) (error (format "scribblings file ~a not found" filename)))
(printf "Building: ~a\n" filename) (printf "Building: ~a\n" filename)
@ -611,7 +605,9 @@
(let ([i* (get-info/full dir)]) (let ([i* (get-info/full dir)])
(cond (cond
[(not i*) [(not i*)
(warn "Package has no info.rkt file. This means it will not have a description or documentation on the PLaneT web site.")] (warn (string-append
"Package has no info.rkt file. This means it will not have"
" a description or documentation on the PLaneT web site."))]
[else [else
(let ([i (λ (field) (i* field (λ () #f)))]) (let ([i (λ (field) (i* field (λ () #f)))])
(checkinfo i fail (checkinfo i fail
@ -624,62 +620,94 @@
(λ (b) (and (list? b) (andmap xexpr? b))) (λ (b) (and (list? b) (andmap xexpr? b)))
(announce "Package blurb: ~s\n" blurb) (announce "Package blurb: ~s\n" blurb)
(unless blurb (unless blurb
(warn "Package's info.rkt does not contain a blurb field. Without a blurb field, the package will have no description on planet.racket-lang.org."))] (warn
(string-append
"Package's info.rkt does not contain a blurb field."
" Without a blurb field, the package will have no description on planet.racket-lang.org.")))]
[release-notes [release-notes
(λ (b) (and (list? b) (andmap xexpr? b))) (λ (b) (and (list? b) (andmap xexpr? b)))
(announce "Release notes: ~s\n" release-notes) (announce "Release notes: ~s\n" release-notes)
(unless release-notes (unless release-notes
(warn "Package's info.rkt does not contain a release-notes field. Without a release-notes field, the package will not have any listed release information on planet.racket-lang.org beyond the contents of the blurb field."))] (warn
(string-append
"Package's info.rkt does not contain a release-notes field. Without a release-notes"
" field, the package will not have any listed release information on"
" planet.racket-lang.org beyond the contents of the blurb field.")))]
[categories [categories
(λ (s) (and (list? s) (andmap symbol? s))) (λ (s) (and (list? s) (andmap symbol? s)))
(cond (cond
[(ormap illegal-category categories) [(ormap illegal-category categories)
=> =>
(λ (bad-cat) (λ (bad-cat)
(fail (format "Package's info.rkt file contains illegal category \"~a\". The legal categories are: ~a\n" (fail (format (string-append
"Package's info.rkt file contains illegal category \"~a\"."
" The legal categories are: ~a\n")
bad-cat bad-cat
legal-categories)))] legal-categories)))]
[else (announce "Categories: ~a\n" categories)]) [else (announce "Categories: ~a\n" categories)])
(unless categories (unless categories
(warn "Package's info.rkt file does not contain a category listing. It will be placed in the Miscellaneous category."))] (warn (string-append
"Package's info.rkt file does not contain a category listing."
" It will be placed in the Miscellaneous category.")))]
[doc.txt [doc.txt
string? string?
(announce "doc.txt file: ~a\n" doc.txt) (announce "doc.txt file: ~a\n" doc.txt)
(when doc.txt (when doc.txt
(warn "Package's info.rkt contains a doc.txt entry, which is now considered deprecated. The preferred method of documentation for PLaneT packages is now Scribble (see the Scribble documentation included in the Racket distribution for more information)."))] (warn
(string-append
"Package's info.rkt contains a doc.txt entry, which is now considered deprecated."
" The preferred method of documentation for PLaneT packages is now Scribble"
" (see the Scribble documentation included in the Racket distribution for"
" more information).")))]
[html-docs [html-docs
(lambda (s) (and (list? s) (andmap string? s))) (lambda (s) (and (list? s) (andmap string? s)))
(warn "Package specifies an html-docs entry. The preferred method of documentation for PLaneT packages is now Scribble (see the Scribble documentation included in the Racket distribution for more information).")] (warn (string-append
"Package specifies an html-docs entry. The preferred method of documentation"
" for PLaneT packages is now Scribble (see the Scribble documentation included"
" in the Racket distribution for more information)."))]
[scribblings [scribblings
(lambda (s) (lambda (s)
(and (list? s) (and (list? s)
(andmap scribble-entry? s))) (andmap scribble-entry? s)))
(void) (void)
(unless scribblings (unless scribblings
(warn "Package does not specify a scribblings field. Without a scribblings field, the package will not have browsable online documentation."))] (warn (string-append
"Package does not specify a scribblings field. Without a scribblings field,"
" the package will not have browsable online documentation.")))]
[homepage [homepage
string? string?
(cond (cond
[(url-string? homepage) [(url-string? homepage)
(announce "Home page: ~a\n" homepage)] (announce "Home page: ~a\n" homepage)]
[else [else
(fail (format "The value of the package's info.rkt homepage field, ~s, does not appear to be a legal URL." homepage))])] (fail (format (string-append
"The value of the package's info.rkt homepage field, ~s, "
"does not appear to be a legal URL.")
homepage))])]
[primary-file [primary-file
(λ (x) (or (string? x) (and (list? x) (andmap string? x)))) (λ (x) (or (string? x) (and (list? x) (andmap string? x))))
(begin (begin
(cond (cond
[(string? primary-file) [(string? primary-file)
(unless (file-in-current-directory? primary-file) (unless (file-in-current-directory? primary-file)
(warn (format "Package's info.rkt primary-file field is ~s, a file that does not exist in the package." (warn (format (string-append
"Package's info.rkt primary-file field is ~s, a file that"
" does not exist in the package.")
primary-file)))] primary-file)))]
[(pair? primary-file) [(pair? primary-file)
(let ([bad-files (filter (λ (f) (not (file-in-current-directory? f))) primary-file)]) (let ([bad-files (filter (λ (f) (not (file-in-current-directory? f))) primary-file)])
(unless (null? bad-files) (unless (null? bad-files)
(warn (format "Package's info.rkt primary-file field is ~s, which contains non-existant files ~s." (warn (format (string-append
"Package's info.rkt primary-file field is ~s, which contains"
" non-existant files ~s.")
primary-file bad-files))))]) primary-file bad-files))))])
(announce "Primary file: ~a\n" primary-file)) (announce "Primary file: ~a\n" primary-file))
(unless primary-file (unless primary-file
(warn "Package's info.rkt does not contain a primary-file field. The package's listing on planet.racket-lang.org will not have a valid require line for your package."))] (warn
(string-append
"Package's info.rkt does not contain a primary-file field."
" The package's listing on planet.racket-lang.org will not have a"
" valid require line for your package.")))]
[required-core-version [required-core-version
core-version? core-version?
(announce "Required racket version: ~a\n" required-core-version)] (announce "Required racket version: ~a\n" required-core-version)]
@ -687,7 +715,9 @@
(λ (x) (and (list? x) (λ (x) (and (list? x)
(srfi1:lset<= equal? x '("3xx" "4.x")))) (srfi1:lset<= equal? x '("3xx" "4.x"))))
(announce "Repositories: ~s\n" repositories) (announce "Repositories: ~s\n" repositories)
(warn "Package's info.rkt does not contain a repositories field. The package will be listed in all repositories by default.")] (warn (string-append
"Package's info.rkt does not contain a repositories field."
" The package will be listed in all repositories by default."))]
[version [version
string? string?
(announce "Version description: ~a\n" version)]))]) (announce "Version description: ~a\n" version)]))])

4
collects/tests/planet/cmdline-tool.rkt
View File

@ -11,6 +11,8 @@ using 'system' to call out to the tool and then reading its results, etc.
planet/config planet/config
net/url) net/url)
(define debug? #f)
(define planet-bin-path (define planet-bin-path
(simplify-path (build-path (collection-path "racket") 'up 'up (simplify-path (build-path (collection-path "racket") 'up 'up
(if (eq? (system-type) 'windows) (if (eq? (system-type) 'windows)
@ -24,8 +26,6 @@ using 'system' to call out to the tool and then reading its results, etc.
(append test-connection-spec (append test-connection-spec
(list (list-ref test-connection-spec 1))))) (list (list-ref test-connection-spec 1)))))
(define debug? #f)
(define (call-planet . args) (define (call-planet . args)
(when debug? (printf "~s\n" (cons 'call-planet args))) (when debug? (printf "~s\n" (cons 'call-planet args)))
(let ([sp (open-output-string)]) (let ([sp (open-output-string)])

108
collects/tests/planet/thread-safe-resolver.rkt Normal file
View File

@ -0,0 +1,108 @@
#lang racket/base
(require planet/util
rackunit
racket/port)
(define debug? #f)
(define (install-one package-spec key)
(define op (open-output-string))
(parameterize ([current-output-port op]
[current-namespace (make-base-namespace)])
(dynamic-require package-spec #f))
(unless (regexp-match #rx"working properly" (get-output-string op))
(error 'install-one "installation failed; key ~s" key)))
(define (find-test-connection-dir package-spec)
(define-values (base name dir?)
(split-path
(resolved-module-path-name
((current-module-name-resolver)
package-spec
#f #f #f))))
(define-values (base2 name2 dir?2)
(split-path base))
base2)
(define (dir-tree-and-sizes path)
(let loop ([path path]
[inside-compiled? #f])
(define-values (base name dir?) (split-path path))
(define s-name (path->string name))
(cond
[(directory-exists? path)
(cons s-name
(map (λ (x) (loop (build-path path x)
(or inside-compiled?
(equal? "compiled" s-name))))
(directory-list path)))]
[(file-exists? path)
(list s-name (if inside-compiled?
'ignore-sizes-inside-compiled-dirs
(file-size path)))]
[else
(list s-name #f)])))
(define lr (make-log-receiver (current-logger) 'info))
(define docs-build-chan (make-channel))
;; get-docs-build-count : -> number
;; effect: aborts the loop that watches the docs build counting
(define (get-docs-build-count)
(define new-chan (make-channel))
(channel-put docs-build-chan new-chan)
(channel-get new-chan))
(void
(thread
(λ ()
(let loop ([num 0])
(sync
(handle-evt
lr
(λ (vec)
(when debug?
(printf "~a\n" (vector-ref vec 1)))
(loop
(if (regexp-match #rx"raco setup: --- building documentation ---"
(vector-ref vec 1))
(+ num 1)
num))))
(handle-evt
docs-build-chan
(λ (return)
(channel-put return num))))))))
(let ([package-spec '(planet "test-connection-mzscheme.scm" ("planet" "test-connection.plt" 1 (= 0)))])
(printf "installing for the first time\n")
(install-one package-spec 'seq1)
(define test-connection-dir (find-test-connection-dir package-spec))
(define non-parallel-install-sizes (dir-tree-and-sizes test-connection-dir))
(printf "removing the first one\n")
(parameterize ([current-output-port (if debug?
(current-output-port)
(open-output-nowhere))])
(remove-pkg "planet" "test-connection.plt" 1 0))
(printf "installing in parallel\n")
(define thds
(for/list ([x (in-range 0 10)])
(thread (λ () (install-one package-spec 'par1)))))
(for ([thd (in-list thds)])
(thread-wait thd))
(define parallel-install-sizes (dir-tree-and-sizes test-connection-dir))
(check-equal? parallel-install-sizes
non-parallel-install-sizes)
(printf "removing the parallel one\n")
(parameterize ([current-output-port (if debug?
(current-output-port)
(open-output-nowhere))])
(remove-pkg "planet" "test-connection.plt" 1 0))
(check-equal? (get-docs-build-count)
4))