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 9cf19b3518..c7904ddbff 100644 --- a/collects/planet/private/planet-shared.rkt +++ b/collects/planet/private/planet-shared.rkt @@ -13,8 +13,68 @@ 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 + pkg->assoc-table + 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) ; ========================================================================================== ; CACHE LOGIC @@ -48,6 +108,14 @@ Various common pieces of code that both the client and server need to access (let* ((at (build-assoc-table pkg dir))) (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) + (append + (pkg->assoc-table pkg dir) + (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, ;; package name, major and (exact) minor version. @@ -74,13 +142,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 '()) @@ -138,21 +199,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 +252,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 +268,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 +309,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) @@ -623,3 +705,20 @@ 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))]))) + + diff --git a/collects/planet/private/resolver.rkt b/collects/planet/private/resolver.rkt index f6262b6501..17160ecc76 100644 --- a/collects/planet/private/resolver.rkt +++ b/collects/planet/private/resolver.rkt @@ -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) @@ -471,11 +472,18 @@ 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)) + (λ () + (error 'ack!) + (log-error (format "planet/resolver.rkt: unable to save the planet package ~a" full-pkg-path))))) full-pkg-path)) ;; ============================================================================= @@ -603,12 +611,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))) diff --git a/collects/planet/util.rkt b/collects/planet/util.rkt index c5b11a5c6d..8981448da7 100644 --- a/collects/planet/util.rkt +++ b/collects/planet/util.rkt @@ -248,19 +248,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)