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

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

@ -1,15 +1,17 @@
(module linkage mzscheme #lang racket/base
(require "planet-shared.rkt" (require "planet-shared.rkt"
"../config.rkt" "../config.rkt"
mzlib/match) racket/match
racket/file)
(provide get/linkage (provide get/linkage
get-linkage get-linkage
add-linkage! add-linkage!
remove-linkage-to! remove-linkage-to!
remove-all-linkage!
remove-all-linkage!) current-linkage)
; ========================================================================================== ; ==========================================================================================
; PHASE 1: LINKAGE ; PHASE 1: LINKAGE
@ -28,6 +30,28 @@
(λ (x) x))))) (λ (x) x)))))
(define (get-linkage rmp pkg-specifier) #f)
(define (add-linkage! rmp pkg-specifier pkg) pkg)
(define (remove-linkage-to! pkg) (void))
(define (remove-all-linkage!) (void))
(define (current-linkage) '())
;; The linkage stuff is completely broken.
;; See get-linkage below for why.
;;
;; Since it has been completely broken since
;; sometime in late 2005 or early 2006, the
;; above 5 functions are a substite for the
;; below that just do nothing
;;
;; In addition to the noted problem below, this
;; code is not thread safe, which is why is now
;; being replaced by code that actually does
;; nothing (and thus is thread safe).
#|
;; NOTE :: right now we have a nasty situation with the linkage-table: it doesn't associate ;; NOTE :: right now we have a nasty situation with the linkage-table: it doesn't associate
;; keys to packages, which it seems it should. Instead it associates keys to the arguments ;; keys to packages, which it seems it should. Instead it associates keys to the arguments
;; to the pkg-spec constructor; this is done to facilitate reading the data from disk but ;; to the pkg-spec constructor; this is done to facilitate reading the data from disk but
@ -50,16 +74,16 @@
(define (add-linkage! rmp pkg-spec pkg) (define (add-linkage! rmp pkg-spec pkg)
(when rmp (when rmp
(let ((key (get-key rmp pkg-spec))) (let ((key (get-key rmp pkg-spec)))
(hash-table-get (hash-ref
(get-linkage-table) (get-linkage-table)
key key
(lambda () (lambda ()
(let ((plist (pkg-as-list pkg))) (let ((plist (pkg-as-list pkg)))
(begin (begin
(hash-table-put! (get-linkage-table) key plist) (hash-set! (get-linkage-table) key plist)
(with-output-to-file (LINKAGE-FILE) (with-output-to-file (LINKAGE-FILE)
(lambda () (write (list key plist))) (lambda () (write (list key plist)))
'append))))))) #:exists 'append)))))))
pkg) pkg)
;; remove-linkage! pkg-spec -> void ;; remove-linkage! pkg-spec -> void
@ -68,32 +92,32 @@
(let ((l (get-linkage-table))) (let ((l (get-linkage-table)))
;; first remove bad entries from the in-memory hash table ;; first remove bad entries from the in-memory hash table
(hash-table-for-each (hash-for-each
l l
(lambda (k v) (lambda (k v)
(match v (match v
[(name route maj min _) [(list name route maj min _)
(when (and (equal? name (pkg-name pkg)) (when (and (equal? name (pkg-name pkg))
(equal? route (pkg-route pkg)) (equal? route (pkg-route pkg))
(= maj (pkg-maj pkg)) (= maj (pkg-maj pkg))
(= min (pkg-min pkg))) (= min (pkg-min pkg)))
(hash-table-remove! l k))] (hash-remove! l k))]
[_ (void)]))) [_ (void)])))
;; now write the new table out to disk to keep it in sync ;; 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 () (lambda ()
(printf "\n") (printf "\n")
(hash-table-for-each (hash-for-each
l l
(lambda (k v) (write (list k v))))) (lambda (k v) (write (list k v)))))
'truncate/replace))) #:exists 'truncate/replace)))
;; kill the whole linkage-table ;; kill the whole linkage-table
(define (remove-all-linkage!) (define (remove-all-linkage!)
(with-output-to-file (LINKAGE-FILE) (with-output-to-file (LINKAGE-FILE)
(lambda () (printf "\n")) (lambda () (printf "\n"))
'truncate/replace) #:exists 'truncate/replace)
(set! LT #f)) (set! LT #f))
;; pkg-as-list : PKG -> (list string string nat nat bytes[path]) ;; pkg-as-list : PKG -> (list string string nat nat bytes[path])
@ -111,13 +135,15 @@
(define (get-linkage rmp pkg-specifier) (define (get-linkage rmp pkg-specifier)
(cond (cond
[rmp [rmp
(let ((pkg-fields (hash-table-get (let ((pkg-fields (hash-ref
(get-linkage-table) (get-linkage-table)
(get-key rmp pkg-specifier) (get-key rmp pkg-specifier)
(lambda () #f)))) (lambda () #f))))
(if pkg-fields (if pkg-fields
(with-handlers ([exn:fail? (lambda (e) #f)]) (with-handlers ([exn:fail? (lambda (e) #f)])
(match-let ([(name route maj min pathbytes) pkg-fields]) (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)))) (make-pkg name route maj min (bytes->path pathbytes))))
#f))] #f))]
[else #f])) [else #f]))
@ -137,5 +163,16 @@
(define (get-module-id rmp) (define (get-module-id rmp)
(path->string (resolved-module-path-name 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)))
|#

258
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)))
(and (or (not check-success?)
(installed-successfully? the-path))
(make-assoc-table-row (make-assoc-table-row
(pkg-spec-name pkg) (pkg-spec-name pkg)
(pkg-spec-path pkg) (pkg-spec-path pkg)
maj min maj min
the-path the-path
min-core-version min-core-version
'normal)) '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)
(with-hard-link-lock
(λ ()
(let ([complete-dir (path->complete-path dir)]) (let ([complete-dir (path->complete-path dir)])
(let* ([original-table (get-hard-link-table)] (let* ([original-table (get-hard-link-table/internal)]
[new-table (cons [new-table (cons
(make-assoc-table-row name path maj min complete-dir #f 'development-link) (make-assoc-table-row name path maj min complete-dir #f 'development-link)
(filter (filter
(lambda (row) (not (points-to? row name path maj min))) (lambda (row) (not (points-to? row name path maj min)))
original-table))]) original-table))])
(save-hard-link-table new-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,8 +632,7 @@ 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"
@ -564,7 +648,7 @@ Various common pieces of code that both the client and server need to access
(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)
(list (apply f (reverse (cons (branch-node t) priors)))) (let ([args (reverse (cons (branch-node t) priors))])
(if (procedure-arity-includes? f (length args))
(list (apply f args))
'()))
'())] '())]
[else [else
(let ((args (cons (branch-node t) priors))) (let ((args (cons (branch-node t) priors)))
(apply append (apply append
(map (lambda (x) (loop x args (add1 curr-depth))) (branch-children t))))])))) (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)))

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

@ -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
@ -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))
(call-with-file-lock/timeout
full-pkg-path
'exclusive
(λ ()
(when (file-exists? full-pkg-path) (delete-file full-pkg-path)) (when (file-exists? full-pkg-path) (delete-file full-pkg-path))
(copy-file (uninstalled-pkg-path uninst-p) 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,32 +553,43 @@ 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)
(try-make-directory* the-dir)
(when (file-exists? (dir->successful-installation-file the-dir))
(raise (make-exn:fail (raise (make-exn:fail
"PLaneT error: trying to install already-installed package" "PLaneT error: trying to install already-installed package"
(current-continuation-marks))) (current-continuation-marks))))
(parameterize ([planet-nested-install #t]) (parameterize ([planet-nested-install #t])
(planet-terse-log 'install pkg-string) (planet-terse-log 'install pkg-string)
(with-logging (with-logging
(LOG-FILE) (LOG-FILE)
(lambda () (lambda ()
(define lock/f #f)
(dynamic-wind
void
(λ ()
(set! lock/f (check/take-installation-lock the-dir))
(when lock/f
(printf "\n============= Installing ~a on ~a =============\n" (printf "\n============= Installing ~a on ~a =============\n"
pkg-name pkg-name
(current-time)) (current-time))
@ -589,10 +607,13 @@ subdirectory.
(unless was-nested? (unless was-nested?
(planet-terse-log 'docs-build pkg-string) (planet-terse-log 'docs-build pkg-string)
(printf "------------- Rebuilding documentation index -------------\n") (printf "------------- Rebuilding documentation index -------------\n")
(rud))))))) (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) (planet-terse-log 'finish pkg-string)
(make-pkg pkg-name pkg-path (make-pkg pkg-name pkg-path
maj min the-dir 'normal)))))) 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))