suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Revert "start making planet thread safe" -- didn't mean to push that one. Whoops, sorry.

Browse Source 
This reverts commit 5bd969693c.
This commit is contained in:
Robby Findler 2011-08-10 12:36:40 -05:00
parent 4d1651645a
commit 708ca63c34
4 changed files with 190 additions and 320 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)))
|#

159
collects/planet/private/planet-shared.rkt
View File

@ -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))])))

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

@ -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)))

13
collects/planet/util.rkt
View File

@ -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)