diff --git a/collects/planet/doc.txt b/collects/planet/doc.txt index ebaf7d3e21..8e55573fe6 100644 --- a/collects/planet/doc.txt +++ b/collects/planet/doc.txt @@ -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 diff --git a/collects/planet/private/planet-shared.ss b/collects/planet/private/planet-shared.ss index 09024988c7..a2bee5d882 100644 --- a/collects/planet/private/planet-shared.ss +++ b/collects/planet/private/planet-shared.ss @@ -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 ;; ============================================================ diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index c857bb4a01..a974a1e858 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -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)