diff --git a/collects/planet/private/linkage.rkt b/collects/planet/private/linkage.rkt index 6067ef7560..0be421b9ba 100644 --- a/collects/planet/private/linkage.rkt +++ b/collects/planet/private/linkage.rkt @@ -1,178 +1,141 @@ -#lang racket/base +(module linkage mzscheme + (require "planet-shared.rkt" + "../config.rkt" + mzlib/match) -(require "planet-shared.rkt" - "../config.rkt" - racket/match - racket/file) + (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. + ; ========================================================================================== -(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 + ;; 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!) (with-output-to-file (LINKAGE-FILE) - (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)))) + (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)))) + + ; 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 c7904ddbff..9cf19b3518 100644 --- a/collects/planet/private/planet-shared.rkt +++ b/collects/planet/private/planet-shared.rkt @@ -13,68 +13,8 @@ Various common pieces of code that both the client and server need to access "../config.rkt" "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) + (provide (all-defined-out) + (all-from-out "data.rkt")) ; ========================================================================================== ; CACHE LOGIC @@ -108,14 +48,6 @@ 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. @@ -142,6 +74,13 @@ 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 '()) @@ -199,41 +138,21 @@ 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!) - (define hlf (HARD-LINK-FILE)) - (unless (and (absolute-path? hlf) (path-only hlf)) + (unless (and (absolute-path? (HARD-LINK-FILE)) (path-only (HARD-LINK-FILE))) (raise (make-exn:fail:contract (format "The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s" - hlf) + (HARD-LINK-FILE)) (current-continuation-marks))))) - ;; get-hard-link-table/internal : -> assoc-table - (define (get-hard-link-table/internal) + ;; get-hard-link-table : -> assoc-table + (define (get-hard-link-table) (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) @@ -252,9 +171,10 @@ 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 "") @@ -268,29 +188,23 @@ 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) - (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)))))) + (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)))) ;; 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) - (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)) + (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))) ;; update-element : number (x -> y) (listof any [x in position number]) -> (listof any [y in position number]) (define (update-element n f l) @@ -309,6 +223,10 @@ 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) @@ -705,20 +623,3 @@ 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 17160ecc76..f6262b6501 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 - (try-make-directory* (PLANET-DIR)) - (try-make-directory* (CACHE-DIR)) + (make-directory* (PLANET-DIR)) + (make-directory* (CACHE-DIR)) (establish-diamond-property-monitor) (planet-resolve spec (current-module-declare-name) @@ -303,9 +303,8 @@ subdirectory. stx (make-exn:fail (format - (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") + "Package ~a loaded twice with multiple incompatible versions: +~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) @@ -472,18 +471,11 @@ subdirectory. (number->string maj) (number->string min))] [full-pkg-path (build-path dir name)]) - (try-make-directory* dir) + (make-directory* dir) (unless (equal? (normalize-path (uninstalled-pkg-path uninst-p)) (normalize-path full-pkg-path)) - (call-with-file-lock/timeout - full-pkg-path - 'exclusive - (λ () - (when (file-exists? full-pkg-path) (delete-file full-pkg-path)) - (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))))) + (when (file-exists? full-pkg-path) (delete-file full-pkg-path)) + (copy-file (uninstalled-pkg-path uninst-p) full-pkg-path)) full-pkg-path)) ;; ============================================================================= @@ -611,11 +603,12 @@ subdirectory. ;; raises an exception if some protocol failure occurs in the download process (define (download-package/planet pkg) - (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 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))) (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 8981448da7..c5b11a5c6d 100644 --- a/collects/planet/util.rkt +++ b/collects/planet/util.rkt @@ -248,6 +248,19 @@ (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)