From cc4de51fb02dc7d61ab7b82333fec679d0bb5419 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 10 Aug 2011 12:45:47 -0500 Subject: [PATCH] - make the planet module resolver thread safe - 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 --- collects/planet/private/linkage.rkt | 305 +++++++++------- collects/planet/private/planet-shared.rkt | 332 ++++++++++++++---- collects/planet/private/resolver.rkt | 150 ++++---- collects/planet/private/util.scrbl | 7 +- collects/planet/util.rkt | 88 +++-- collects/tests/planet/cmdline-tool.rkt | 4 +- .../tests/planet/thread-safe-resolver.rkt | 108 ++++++ 7 files changed, 683 insertions(+), 311 deletions(-) create mode 100644 collects/tests/planet/thread-safe-resolver.rkt diff --git a/collects/planet/private/linkage.rkt b/collects/planet/private/linkage.rkt index 0be421b9ba..6067ef7560 100644 --- a/collects/planet/private/linkage.rkt +++ b/collects/planet/private/linkage.rkt @@ -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))) +|# \ No newline at end of file diff --git a/collects/planet/private/planet-shared.rkt b/collects/planet/private/planet-shared.rkt index 5dccc6c53b..c705c50f2b 100644 --- a/collects/planet/private/planet-shared.rkt +++ b/collects/planet/private/planet-shared.rkt @@ -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))) + \ No newline at end of file diff --git a/collects/planet/private/resolver.rkt b/collects/planet/private/resolver.rkt index f6262b6501..edd8e93133 100644 --- a/collects/planet/private/resolver.rkt +++ b/collects/planet/private/resolver.rkt @@ -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 diff --git a/collects/planet/private/util.scrbl b/collects/planet/private/util.scrbl index 407ecf3806..529cb34e5a 100644 --- a/collects/planet/private/util.scrbl +++ b/collects/planet/private/util.scrbl @@ -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?)]) diff --git a/collects/planet/util.rkt b/collects/planet/util.rkt index c5b11a5c6d..c5d0c4be86 100644 --- a/collects/planet/util.rkt +++ b/collects/planet/util.rkt @@ -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)]))]) diff --git a/collects/tests/planet/cmdline-tool.rkt b/collects/tests/planet/cmdline-tool.rkt index 2c66441a35..b07d012b6d 100644 --- a/collects/tests/planet/cmdline-tool.rkt +++ b/collects/tests/planet/cmdline-tool.rkt @@ -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)]) diff --git a/collects/tests/planet/thread-safe-resolver.rkt b/collects/tests/planet/thread-safe-resolver.rkt new file mode 100644 index 0000000000..d02e3ae278 --- /dev/null +++ b/collects/tests/planet/thread-safe-resolver.rkt @@ -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)) +