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

.

Browse Source 
svn: r2887
This commit is contained in:
Jacob Matthews 2006-05-09 16:51:55 +00:00
parent e1f0989933
commit 92838554ff
3 changed files with 176 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/planet/doc.txt
View File

@ -363,6 +363,46 @@ ignored. If you put no legal symbols in the categories field or do not
include this field in your info.ss file, your package will be
categorized as "Miscellaneous."
The _'can-be-loaded-with field_
If present, the can-be-loaded-with field should be a quoted datum of
one of the following forms:
can-be-loaded-with = 'all
| 'none
| (list 'all-except VER-SPEC ...)
| (list 'only VER-SPEC ...)
where VER-SPEC is a quoted instance of the VER-SPEC form defined at the
beginning of this document.
Depending on your package's behavior, it may or may not be okay for
multiple versions of the same package to be loaded at one time on the
entire system --- for instance, if your package relies on writing to a
particular file and assumes that nothing else writes to that same
file, then multiple versions of the same package being loaded
simultaneously may be a problem. This field allows you to specify
whether your package can be loaded simultaneously with older versions
of itself. If its value is 'all, then the package may be loaded with
any older version. If it is 'none, then it may not be loaded with
older versions at all. If it is (list 'all-except VER-SPEC ...) then
any package except those that match one of the given VER-SPEC forms
may be loaded with this package; if it is (list 'only VER-SPEC ...)
then only packages that match one of the given VER-SPEC forms may be
loaded with this package.
When checking to see if a package may be loaded, PLaneT compares it to
all other currently-loaded instances of the same package with any
version: for each comparison, it checks to see if the newer package's
can-be-loaded-with field allows the older package to be loaded. If all
such comparisons succeed then the new package may be loaded; otherwise
PLaneT signals an error.
The default for this field is 'none as a conservative protection
measure. For many packages it is safe to set this field to
'any.
The _'doc.txt field_
If present, the doc.txt field should be a string corresponding to the

24
collects/planet/private/planet-shared.ss
View File

@ -219,6 +219,19 @@ Various common pieces of code that both the client and server need to access
(and (= (mz-version-major a) (mz-version-major b))
(<= (mz-version-minor a) (mz-version-minor b)))))
;; pkg< : pkg pkg -> boolean
;; determines if a is an earlier version than b
;; [only sensical if a and b are versions of the same package]
(define (pkg< a b)
(or (< (pkg-maj a) (pkg-maj b))
(and (= (pkg-maj a) (pkg-maj b))
(< (pkg-min a) (pkg-min b)))))
(define (pkg> a b)
(pkg< b a))
(define (pkg= a b)
(not (or (pkg< a b) (pkg> a b))))
;; compatible-version? : assoc-table-row FULL-PKG-SPEC -> boolean
;; determines if the given package constrint verstr can support the given package
(define (compatible-version? row spec)
@ -266,7 +279,7 @@ Various common pieces of code that both the client and server need to access
; FULL-PKG-SPEC : (make-pkg-spec string (Nat | #f) (Nat | #f) (Nat | #f) (listof string) (syntax | #f)) string
(define-struct pkg-spec (name maj minor-lo minor-hi path stx core-version) (make-inspector))
; PKG : string Nat Nat path
; PKG : string (listof string) Nat Nat path
(define-struct pkg (name route maj min path))
; ==========================================================================================
@ -392,6 +405,15 @@ Various common pieces of code that both the client and server need to access
(parameterize ([current-output-port outport])
(f))))
;; pkg->info : PKG -> (symbol (-> TST) -> TST)
;; get an info.ss thunk for the given package
(define (pkg->info p)
(or
(with-handlers ([exn:fail? (lambda (e) #f)])
(get-info/full (pkg-path p)))
(lambda (s thunk) (thunk))))
;; ============================================================
;; TREE STUFF
;; ============================================================

158
collects/planet/resolver.ss
View File

@ -158,7 +158,7 @@ an appropriate subdirectory.
"config.ss"
"private/planet-shared.ss"
"private/linkage.ss")
(provide (rename resolver planet-module-name-resolver)
pkg-spec->full-pkg-spec
get-package-from-cache
@ -166,9 +166,9 @@ an appropriate subdirectory.
download-package
install-pkg
get-planet-module-path/pkg)
(define install? (make-parameter #t)) ;; if #f, will not install packages and instead give an error
(define (resolver spec module-path stx)
;; ensure these directories exist
(make-directory* (PLANET-DIR))
@ -188,30 +188,80 @@ an appropriate subdirectory.
(unless VER-CACHE-NAME (set! VER-CACHE-NAME (gensym)))
(unless (namespace-variable-value VER-CACHE-NAME #t (lambda () #f))
(namespace-set-variable-value! VER-CACHE-NAME (make-hash-table 'equal))))
(define (the-version-cache) (namespace-variable-value VER-CACHE-NAME))
(define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg)))
(define (pkg-matches-bounds? pkg bound-info)
(match-let ([(maj lo hi) bound-info])
(and (= maj (pkg-maj pkg))
(or (not lo) (>= (pkg-min pkg) lo))
(or (not hi) (<= (pkg-min pkg) hi)))))
;; COMPAT ::= 'none | 'all | `(all-except ,VER-SPEC ...) | `(only ,VER-SPEC ...)
;; build-compatibility-fn : COMPAT -> PKG -> bool
(define (build-compatibility-fn compat-data)
(define pre-fn
(match compat-data
[`none (lambda (_) #f)]
[`all (lambda (_) #t)]
[`(all-except ,vspec ...)
(let ((bounders (map version->bounds vspec)))
(if (andmap (lambda (x) x) bounders)
(lambda (v)
(not
(ormap
(lambda (bounder)
(pkg-matches-bounds? v bounder))
bounders)))
#f))]
[`(only ,vspec ...)
(let ((bounders (map version->bounds vspec)))
(if (andmap (lambda (x) x) bounders)
(lambda (v)
(andmap
(lambda (bounder)
(pkg-matches-bounds? v bounder))
bounders)))
#f)]
[_ #f]))
(or pre-fn (lambda (x) #f)))
;; can-be-loaded-together? : pkg pkg -> boolean
;; side constraint: pkg1 and pkg2 are versions of the same package
;; assumption: pkg1 and pkg2 are versions of the same package
;; determines if the two versions are side-by-side compatible
(define (can-be-loaded-together? pkg1 pkg2)
(cond
[(pkg> pkg1 pkg2) (can-be-loaded-together? pkg2 pkg1)]
[(pkg= pkg1 pkg2) #t]
[(pkg< pkg1 pkg2)
(let* ([info (pkg->info pkg2)]
[compat? (build-compatibility-fn (info 'can-be-loaded-with (lambda () 'none)))])
(compat? pkg1))]))
(define (add-pkg-to-diamond-registry! pkg)
(let ((orig (hash-table-get (the-version-cache)
(pkg->diamond-key pkg)
(lambda () #f))))
(cond
[(not orig) (hash-table-put! (the-version-cache) (pkg->diamond-key pkg) pkg)]
[(and (eq? (pkg-maj pkg) (pkg-maj orig))
(eq? (pkg-min pkg) (pkg-min orig)))
(void)]
[else (raise (make-exn:fail (string->immutable-string
(format
"Package ~a loaded twice with multiple versions:
(let ((loaded-packages (hash-table-get (the-version-cache)
(pkg->diamond-key pkg)
(lambda () '()))))
(begin
(for-each
(lambda (already-loaded-pkg)
(unless (can-be-loaded-together? pkg already-loaded-pkg)
(raise (make-exn:fail (string->immutable-string
(format
"Package ~a loaded twice with multiple incompatible versions:
attempted to load version ~a.~a while version ~a.~a was already loaded"
(pkg-name pkg)
(pkg-maj pkg)
(pkg-min pkg)
(pkg-maj orig)
(pkg-min orig)))
(current-continuation-marks)))])))
(pkg-name pkg)
(pkg-maj pkg)
(pkg-min pkg)
(pkg-maj already-loaded-pkg)
(pkg-min already-loaded-pkg)))
(current-continuation-marks)))))
loaded-packages)
(hash-table-put! (the-version-cache) (pkg->diamond-key pkg) (cons pkg loaded-packages)))))
; ==========================================================================================
; MAIN LOGIC
; Handles the overall functioning of the resolver
@ -258,24 +308,42 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
; pkg-spec->full-pkg-spec : PKG-SPEC syntax -> FULL-PKG-SPEC
(define (pkg-spec->full-pkg-spec spec stx)
(define (pkg name maj lo hi path) (make-pkg-spec name maj lo hi path stx (version)))
(define (fail)
(raise-syntax-error 'require (format "Invalid PLaneT package specifier: ~e" spec) stx))
(match spec
[((? string? path) ...) (pkg (last path) #f 0 #f (drop-last path))]
[((? string? path) ... (? number? maj)) (pkg (last path) maj 0 #f (drop-last path))]
[((? string? path) ... (? number? maj) min-spec)
(let ((pkg (lambda (min max) (pkg (last path) maj min max (drop-last path)))))
[((? string? path) ... ver-spec ...)
(match (version->bounds ver-spec)
[(maj min-lo min-hi)
(pkg (last path) maj min-lo min-hi (drop-last path))]
[#f (fail)])]
[_ (fail)]))
;; version->bounds : VER-SPEC -> (list (number | #f) number (number | #f)) | #f
;; determines the bounds for a given version-specifier
;; [technically this handles a slightly extended version of VER-SPEC where MAJ may
;; be in a list by itself, because that's slightly more convenient for the above fn]
(define (version->bounds spec-list)
(match spec-list
[() (list #f 0 #f)]
[(? number? maj) (version->bounds (list maj))]
[((? number? maj)) (list maj 0 #f)]
[((? number? maj) min-spec)
(let ((pkg (lambda (min max) (list maj min max))))
(match min-spec
[(? number? min) (pkg min #f)]
[((? number? lo) (? number? hi)) (pkg lo hi)]
[('= (? number? min)) (pkg min min)]
[('+ (? number? min)) (pkg min #f)]
[('- (? number? min)) (pkg 0 min)]))]
[_ (raise-syntax-error 'require (format "Invalid PLaneT package specifier: ~e" spec) stx)]))
[_ #f]))
; ==========================================================================================
; PHASE 2: CACHE SEARCH
; If there's no linkage, there might still be an appropriate cached module.
; ==========================================================================================
; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f
(define (get-package-from-cache pkg-spec)
(lookup-package pkg-spec))
@ -284,7 +352,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
; PHASE 3: SERVER RETRIEVAL
; Ask the PLaneT server for an appropriate package if we don't have one locally.
; ==========================================================================================
; get-package-from-server : FULL-PKG-SPEC -> PKG | #f
; downloads and installs the given package from the PLaneT server and installs it in the cache,
; then returns a path to it
@ -343,7 +411,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
((dynamic-require '(lib "plt-single-installer.ss" "setup") 'install-planet-package)
path the-dir (list owner (pkg-spec-name pkg) extra-path maj min)))))
(make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg) maj min the-dir)))))
; download-package : FULL-PKG-SPEC -> RESPONSE
; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat)
; downloads the given package and returns (list bool string): if bool is #t,
@ -351,9 +419,9 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
; didn't exist and the string is the server's informative message.
; raises an exception if some protocol failure occurs in the download process
(define (download-package/planet pkg)
(define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))
(define (close-ports)
(close-input-port ip)
(close-output-port op))
@ -361,13 +429,13 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
(define (request-pkg-list pkgs)
(for-each/n (lambda (pkg seqno)
(write-line (list* seqno 'get
(DEFAULT-PACKAGE-LANGUAGE)
(pkg-spec-name pkg)
(pkg-spec-maj pkg)
(pkg-spec-minor-lo pkg)
(pkg-spec-minor-hi pkg)
(pkg-spec-path pkg))
op))
(DEFAULT-PACKAGE-LANGUAGE)
(pkg-spec-name pkg)
(pkg-spec-maj pkg)
(pkg-spec-minor-lo pkg)
(pkg-spec-minor-hi pkg)
(pkg-spec-path pkg))
op))
pkgs)
(write-line 'end op)
(flush-output op))
@ -379,11 +447,11 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
['ok (state:send-pkg-request)]
[('invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))]
[bad-msg (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))]))
(define (state:send-pkg-request)
(request-pkg-list (list pkg))
(state:receive-package))
(define (state:receive-package)
(match (read ip)
[(_ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes))
@ -483,7 +551,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
[else (list* line "\n" (loop))]))))))]
[else
(abort (format "Internal error (unknown HTTP response code ~a)" response-code))])))
; ==========================================================================================
; MODULE MANAGEMENT
; Handles interaction with the module system
@ -497,11 +565,11 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
file-path
module-path
stx)))
; ============================================================
; UTILITY
; A few small utility functions
(define (last l) (car (last-pair l)))
;; make-directory*/paths : path -> (listof path)