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
get-linkage
add-linkage!
remove-linkage-to!
remove-all-linkage!)
; ==========================================================================================
; PHASE 1: LINKAGE
; The first check is to see if there is a valid linkage for the module.
; ==========================================================================================
(require "planet-shared.rkt"
"../config.rkt"
racket/match
racket/file)
;; get/linkage : pkg-getter [see ../resolver.rkt]
;; getter for the linkage table
(define (get/linkage rmp pkg-specifier success-k failure-k)
(let ([linked-pkg (get-linkage rmp pkg-specifier)])
(if linked-pkg
(success-k linked-pkg)
(failure-k
void
(λ (pkg) (add-linkage! rmp pkg-specifier pkg))
(λ (x) x)))))
;; 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
;; to the pkg-spec constructor; this is done to facilitate reading the data from disk but
;; 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.
; LINKAGE-TABLE ::= hash-table[LINKAGE-KEY -> PKG-LOCATION]
(define LT #f)
; 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))
(unless LT (set! LT (build-hash-table (with-input-from-file (LINKAGE-FILE) read-all))))
LT)
; 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
; with the last in the linkage table. Returns the given package-location
(define (add-linkage! rmp pkg-spec pkg)
(when rmp
(let ((key (get-key rmp pkg-spec)))
(hash-table-get
(get-linkage-table)
key
(lambda ()
(let ((plist (pkg-as-list pkg)))
(begin
(hash-table-put! (get-linkage-table) key plist)
(with-output-to-file (LINKAGE-FILE)
(lambda () (write (list key plist)))
'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-table-for-each
l
(lambda (k v)
(match v
[(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-table-remove! l k))]
[_ (void)])))
;; now write the new table out to disk to keep it in sync
(with-output-to-file (LINKAGE-FILE)
(lambda ()
(printf "\n")
(hash-table-for-each
l
(lambda (k v) (write (list k v)))))
'truncate/replace)))
;; kill the whole linkage-table
(define (remove-all-linkage!)
(provide get/linkage
get-linkage
add-linkage!
remove-linkage-to!
remove-all-linkage!
current-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]
;; getter for the linkage table
(define (get/linkage rmp pkg-specifier success-k failure-k)
(let ([linked-pkg (get-linkage rmp pkg-specifier)])
(if linked-pkg
(success-k linked-pkg)
(failure-k
void
(λ (pkg) (add-linkage! rmp pkg-specifier pkg))
(λ (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
;; 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
;; 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.
; LINKAGE-TABLE ::= hash-table[LINKAGE-KEY -> PKG-LOCATION]
(define LT #f)
; 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))
(unless LT (set! LT (build-hash-table (with-input-from-file (LINKAGE-FILE) read-all))))
LT)
; 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
; with the last in the linkage table. Returns the given package-location
(define (add-linkage! rmp pkg-spec pkg)
(when rmp
(let ((key (get-key rmp pkg-spec)))
(hash-ref
(get-linkage-table)
key
(lambda ()
(let ((plist (pkg-as-list pkg)))
(begin
(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)
(lambda () (printf "\n"))
'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))))
(lambda ()
(printf "\n")
(hash-for-each
l
(lambda (k v) (write (list k v)))))
#:exists 'truncate/replace)))
;; kill the whole linkage-table
(define (remove-all-linkage!)
(with-output-to-file (LINKAGE-FILE)
(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"
"data.rkt")
(provide (all-defined-out)
(all-from-out "data.rkt"))
(provide (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
@ -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
; 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
(define lookup-package
(case-lambda
[(pkg) (lookup-package pkg (CACHE-DIR))]
[(pkg dir)
(let* ((at (build-assoc-table pkg dir)))
(get-best-match at pkg))]))
(define (lookup-package pkg [dir (CACHE-DIR)] #:check-success? [check-success? #f])
(define at (build-assoc-table pkg dir check-success?))
(get-best-match at pkg))
; 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 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
;; 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)))
; 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))
(define empty-table '())
@ -95,10 +158,10 @@ Various common pieces of code that both the client and server need to access
#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
; 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 (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)
(let* ((the-path (build-path path majs mins))
(min-core-version (get-min-core-version the-path)))
(make-assoc-table-row
(pkg-spec-name pkg)
(pkg-spec-path pkg)
maj min
the-path
min-core-version
'normal))
(and (or (not check-success?)
(installed-successfully? the-path))
(make-assoc-table-row
(pkg-spec-name pkg)
(pkg-spec-path pkg)
maj min
the-path
min-core-version
'normal)))
#f)))
(if (directory-exists? path)
(filter
(λ (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
;; pitches a fit if the hard link table parameter isn't set right
(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
(format
"The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s"
(HARD-LINK-FILE))
hlf)
(current-continuation-marks)))))
;; get-hard-link-table : -> assoc-table
(define (get-hard-link-table)
;; get-hard-link-table/internal : -> assoc-table
(define (get-hard-link-table/internal)
(verify-well-formed-hard-link-parameter!)
(if (file-exists? (HARD-LINK-FILE))
(map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item)))
(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
;; determines if the row associates the given package with a dir
(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
;; 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)
(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
(lambda ()
(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
;; for the same package
(define (add-hard-link! name path maj min dir)
(let ([complete-dir (path->complete-path dir)])
(let* ([original-table (get-hard-link-table)]
[new-table (cons
(make-assoc-table-row name path maj min complete-dir #f 'development-link)
(filter
(lambda (row) (not (points-to? row name path maj min)))
original-table))])
(save-hard-link-table new-table))))
(with-hard-link-lock
(λ ()
(let ([complete-dir (path->complete-path dir)])
(let* ([original-table (get-hard-link-table/internal)]
[new-table (cons
(make-assoc-table-row name path maj min complete-dir #f 'development-link)
(filter
(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
;; 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
;; the removed links
(define (filter-link-table! f on-delete)
(let-values ([(in-links out-links) (srfi1:partition f (get-hard-link-table))])
(for-each on-delete out-links)
(save-hard-link-table in-links)))
(define out-links
(with-hard-link-lock
(λ ()
(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])
(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))]
[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) ...)
;; returns n list selectors for the first n elements of a list
;; (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))
;; directory->tree : directory (string -> bool) [nat | bool] [path->X] -> tree[X] | #f
(define directory->tree
(lambda (directory valid-dir? [max-depth #f] [path->x path->string])
(unless (directory-exists? directory)
(raise (make-exn:fail:filesystem:no-directory
"Directory ~s does not exist"
(current-continuation-marks)
directory)))
(let-values ([(path name _) (split-path directory)])
(let* ((files (directory-list directory))
(files (map (lambda (d) (build-path directory d)) files))
(files (filter (lambda (d) (and (directory-exists? d) (valid-dir? d))) files)))
(make-branch
(path->x name)
;; NOTE: the above line should not use path->string. I don't have time to track this down though
(if (equal? max-depth 0)
'()
(let ((next-depth (if max-depth (sub1 max-depth) #f)))
(map (lambda (d) (directory->tree d valid-dir? next-depth)) files))))))))
(define (directory->tree directory valid-dir? [max-depth #f] [path->x path->string])
(unless (directory-exists? directory)
(raise (make-exn:fail:filesystem:no-directory
"Directory ~s does not exist"
(current-continuation-marks)
directory)))
(let-values ([(path name _) (split-path directory)])
(let* ((files (directory-list directory))
(files (map (lambda (d) (build-path directory d)) files))
(files (filter (lambda (d) (and (directory-exists? d) (valid-dir? d))) files)))
(make-branch
(path->x name)
;; NOTE: the above line should not use path->string. I don't have time to track this down though
(if (equal? max-depth 0)
'()
(let ((next-depth (if max-depth (sub1 max-depth) #f)))
(map (lambda (d) (directory->tree d valid-dir? next-depth)) files)))))))
;; filter-pattern : (listof pattern-term)
;; 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
;; applies f to every path from root to leaf and
;; accumulates all results in a list
(define tree-apply
(lambda (f t [depth 0])
(let loop ((t t)
(priors '())
(curr-depth 0))
(cond
[(null? (branch-children t))
(if (> curr-depth depth)
(list (apply f (reverse (cons (branch-node t) priors))))
'())]
[else
(let ((args (cons (branch-node t) priors)))
(apply append
(map (lambda (x) (loop x args (add1 curr-depth))) (branch-children t))))]))))
(define (tree-apply f t [depth 0])
(let loop ((t t)
(priors '())
(curr-depth 0))
(cond
[(null? (branch-children t))
(if (> curr-depth depth)
(let ([args (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
(map (λ (x) (loop x args (add1 curr-depth)))
(branch-children t))))])))
;; tree->list : tree[x] -> sexp-tree[x]
(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))))
4)
(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)
| (FILE-PATH ... PKG-NAME VER-SPEC)
VER-SPEC ::= Nat | (Nat MINOR)
MINOR ::= Nat | (Nat Nat) | (= Nat) | (+ Nat) | (- Nat)
MINOR ::= Nat | (Nat Nat) | (= Nat) | (+ Nat) | (- Nat)
FILE-PATH ::= string
PKG-NAME ::= string
OWNER-NAME ::= string
@ -172,8 +172,8 @@ subdirectory.
[(name) (void)]
[(spec module-path stx load? orig-paramz)
;; ensure these directories exist
(make-directory* (PLANET-DIR))
(make-directory* (CACHE-DIR))
(try-make-directory* (PLANET-DIR))
(try-make-directory* (CACHE-DIR))
(establish-diamond-property-monitor)
(planet-resolve spec
(current-module-declare-name)
@ -303,8 +303,9 @@ subdirectory.
stx
(make-exn:fail
(format
"Package ~a loaded twice with multiple incompatible versions:
~a attempted to load version ~a.~a while version ~a.~a was already loaded by ~a"
(string-append
"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)
(stx->origin-string stx)
(pkg-maj pkg)
@ -420,7 +421,7 @@ subdirectory.
;; get/installed-cache : pkg-getter
(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)))))
;; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f
@ -453,7 +454,7 @@ subdirectory.
pkg-spec
(pkg-maj 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]
;; copies the given uninstalled package into the uninstalled-package cache,
@ -471,11 +472,17 @@ subdirectory.
(number->string maj)
(number->string min))]
[full-pkg-path (build-path dir name)])
(make-directory* dir)
(try-make-directory* dir)
(unless (equal? (normalize-path (uninstalled-pkg-path uninst-p))
(normalize-path full-pkg-path))
(when (file-exists? full-pkg-path) (delete-file full-pkg-path))
(copy-file (uninstalled-pkg-path uninst-p) full-pkg-path))
(call-with-file-lock/timeout
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))
;; =============================================================================
@ -546,53 +553,67 @@ subdirectory.
;; install the given pkg to the planet cache and return a PKG representing the
;; installed file
(define (install-pkg pkg path maj min)
(let ([pkg-path (pkg-spec-path pkg)]
[pkg-name (pkg-spec-name pkg)]
[pkg-string (pkg-spec->string pkg)])
(unless (install?)
(raise (make-exn:fail:planet
(format
"PLaneT error: cannot install package ~s since the install? parameter is set to #f"
(list (car pkg-path) pkg-name maj min))
(current-continuation-marks))))
(let* ([owner (car pkg-path)]
[extra-path (cdr pkg-path)]
[the-dir
(apply build-path (CACHE-DIR)
(append pkg-path (list pkg-name
(number->string maj)
(number->string min))))]
[was-nested? (planet-nested-install)])
(if (directory-exists? the-dir)
(raise (make-exn:fail
"PLaneT error: trying to install already-installed package"
(current-continuation-marks)))
(parameterize ([planet-nested-install #t])
(planet-terse-log 'install pkg-string)
(with-logging
(LOG-FILE)
(lambda ()
(printf "\n============= Installing ~a on ~a =============\n"
pkg-name
(current-time))
;; oh man is this a bad hack!
(parameterize ([current-namespace (make-base-namespace)])
(let ([ipp (dynamic-require 'setup/plt-single-installer
'install-planet-package)]
[rud (dynamic-require 'setup/plt-single-installer
'reindex-user-documentation)]
[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)))))))
(planet-terse-log 'finish pkg-string)
(make-pkg pkg-name pkg-path
maj min the-dir 'normal))))))
(define pkg-path (pkg-spec-path pkg))
(define pkg-name (pkg-spec-name pkg))
(define pkg-string (pkg-spec->string pkg))
(unless (install?)
(raise (make-exn:fail:planet
(format
"PLaneT error: cannot install package ~s since the install? parameter is set to #f"
(list (car pkg-path) pkg-name maj min))
(current-continuation-marks))))
(define owner (car pkg-path))
(define extra-path (cdr pkg-path))
(define the-dir
(apply build-path (CACHE-DIR)
(append pkg-path (list pkg-name
(number->string maj)
(number->string min)))))
(define was-nested? (planet-nested-install))
(try-make-directory* the-dir)
(when (file-exists? (dir->successful-installation-file the-dir))
(raise (make-exn:fail
"PLaneT error: trying to install already-installed package"
(current-continuation-marks))))
(parameterize ([planet-nested-install #t])
(planet-terse-log 'install pkg-string)
(with-logging
(LOG-FILE)
(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"
pkg-name
(current-time))
;; oh man is this a bad hack!
(parameterize ([current-namespace (make-base-namespace)])
(let ([ipp (dynamic-require 'setup/plt-single-installer
'install-planet-package)]
[rud (dynamic-require 'setup/plt-single-installer
'reindex-user-documentation)]
[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
;; 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
(define (download-package/planet pkg)
(define stupid-internal-define-syntax
(let ([msg (format "downloading ~a from ~a via planet protocol"
(pkg-spec->string pkg)
(PLANET-SERVER-NAME))])
(planet-terse-log 'download (pkg-spec->string pkg))
(planet-log msg)))
(let ([msg (format "downloading ~a from ~a via planet protocol"
(pkg-spec->string pkg)
(PLANET-SERVER-NAME))])
(planet-terse-log 'download (pkg-spec->string pkg))
(planet-log msg))
(define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))
@ -795,9 +815,9 @@ subdirectory.
(make-parameter
(list get/linkage
get/installed-cache
get/uninstalled-cache
get/uninstalled-cache-dummy
get/server
get/uninstalled-cache)))
get/server)))
;; ============================================================
;; 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]
[min natural-number/c])
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?]
@ -345,8 +345,9 @@ Removes the specified package from the local planet cache.
[maj natural-number/c]
[min natural-number/c])
any]{
Removes the specified package from the local planet cache and deletes
all of the files corresponding to the package.
Like @racket[remove-pkg], removes the specified package from the local planet cache and deletes
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?)])

88
collects/planet/util.rkt
View File

@ -130,7 +130,10 @@
(clean-planet-package path (list owner name '() maj min))))
(planet-log "Erasing metadata")
(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)
(planet-log "Trimming empty directories")
(trim-directory (CACHE-DIR) path)
@ -248,19 +251,6 @@
(loop (cdr dirs))]
[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)
;; computes a filter that accepts paths that match the given regexps and rejects other paths
(define (regexp->filter re-s)
@ -397,7 +387,9 @@
(cons (format "Error generating scribble documentation: ~a" (render-exn e))
critical-errors)))])
(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)))
(for ([entry scribble-files])
(unless (scribble-entry? entry)
@ -407,7 +399,9 @@
(unless (and (relative-path? filename)
(subpath? abs-dir filename)
(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))
(error (format "scribblings file ~a not found" filename)))
(printf "Building: ~a\n" filename)
@ -611,7 +605,9 @@
(let ([i* (get-info/full dir)])
(cond
[(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
(let ([i (λ (field) (i* field (λ () #f)))])
(checkinfo i fail
@ -624,62 +620,94 @@
(λ (b) (and (list? b) (andmap xexpr? b)))
(announce "Package blurb: ~s\n" 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
(λ (b) (and (list? b) (andmap xexpr? b)))
(announce "Release notes: ~s\n" 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
(λ (s) (and (list? s) (andmap symbol? s)))
(cond
[(ormap illegal-category categories)
=>
(λ (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
legal-categories)))]
[else (announce "Categories: ~a\n" 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
string?
(announce "doc.txt file: ~a\n" 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
(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
(lambda (s)
(and (list? s)
(andmap scribble-entry? s)))
(void)
(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
string?
(cond
[(url-string? homepage)
(announce "Home page: ~a\n" homepage)]
[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
(λ (x) (or (string? x) (and (list? x) (andmap string? x))))
(begin
(cond
[(string? 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)))]
[(pair? primary-file)
(let ([bad-files (filter (λ (f) (not (file-in-current-directory? f))) primary-file)])
(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))))])
(announce "Primary file: ~a\n" 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
core-version?
(announce "Required racket version: ~a\n" required-core-version)]
@ -687,7 +715,9 @@
(λ (x) (and (list? x)
(srfi1:lset<= equal? x '("3xx" "4.x"))))
(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
string?
(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
net/url)
(define debug? #f)
(define planet-bin-path
(simplify-path (build-path (collection-path "racket") 'up 'up
(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
(list (list-ref test-connection-spec 1)))))
(define debug? #f)
(define (call-planet . args)
(when debug? (printf "~s\n" (cons 'call-planet args)))
(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))