diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss index fcf0766fe1..bfa7eaf6df 100644 --- a/collects/planet/planet.ss +++ b/collects/planet/planet.ss @@ -50,6 +50,11 @@ PLANNED FEATURES: " (require (planet \"file.ss\" ( )))" "would install" (set! actions (cons (lambda () (download/install owner pkg maj min)) actions))) + (("-d" "--download") + owner pkg maj min + "" + "Download the given package file without installing it" + (set! actions (cons (lambda () (download/no-install owner pkg maj min)) actions))) (("-r" "--remove") owner pkg maj min "" @@ -67,7 +72,6 @@ PLANNED FEATURES: "" "List the current linkage table" (set! actions (cons show-linkage actions))) - ;; unimplemented so far: #;(("-u" "--unlink") module @@ -79,7 +83,8 @@ PLANNED FEATURES: ;; ============================================================ ;; FEATURE IMPLEMENTATIONS - (define (fail s) (raise (make-exn:fail s (current-continuation-marks)))) + (define (fail s . args) + (raise (make-exn:fail (string->immutable-string (apply format s args)) (current-continuation-marks)))) (define (download/install owner pkg majstr minstr) (let* ([maj (read-from-string majstr)] @@ -90,12 +95,26 @@ PLANNED FEATURES: (unless (get-package-from-server full-pkg-spec) (fail "Could not find matching package")))) + (define (download/no-install owner pkg majstr minstr) + (let* ([maj (read-from-string majstr)] + [min (read-from-string minstr)] + [full-pkg-spec (pkg-spec->full-pkg-spec (list owner pkg maj min) #f)]) + (when (file-exists? pkg) + (fail "Cannot download, there is a file named ~a in the way" pkg)) + (match (download-package full-pkg-spec) + [(#t path maj min) + (copy-file path pkg) + (printf "Downloaded ~a package version ~a.~a\n" pkg maj min)] + [_ + (fail "Could not find matching package")]))) + + (define (install-plt-file filestr owner majstr minstr) (let ((maj (string->number majstr)) (min (string->number minstr))) (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0)) (fail "Invalid major/minor version")) - (unless (file-exists? filestr) (fail (format "File does not exist: ~a" filestr))) + (unless (file-exists? filestr) (fail "File does not exist: ~a" filestr)) (let* ([file (normalize-path filestr)] [name (let-values ([(base name dir?) (split-path file)]) (path->string name))] [spec (list owner name maj min)] @@ -105,7 +124,7 @@ PLANNED FEATURES: (define (do-archive p) (unless (directory-exists? p) - (fail (format "No such directory: ~a" p))) + (fail "No such directory: ~a" p)) (make-planet-archive (normalize-path p))) (define (remove owner pkg majstr minstr) diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 6d50cf7f09..1cad4c2374 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -160,6 +160,7 @@ an appropriate subdirectory. pkg-spec->full-pkg-spec get-package-from-cache get-package-from-server + download-package install-pkg get-planet-module-path/pkg) @@ -287,11 +288,15 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" "Error downloading module from PLaneT server: ~a" (exn-message e))) (exn-continuation-marks e))))]) - (let ((download (if (USE-HTTP-DOWNLOADS?) download-package/http download-package))) - (match (download pkg) - [(#t path maj min) (install-pkg pkg path maj min)] - [(#f str) #f])))) + (match (download-package pkg) + [(#t path maj min) (install-pkg pkg path maj min)] + [(#f str) #f]))) + (define (download-package pkg) + ((if (USE-HTTP-DOWNLOADS?) + download-package/http + download-package/planet) + pkg)) (define (current-time) (let ((date (seconds->date (current-seconds)))) @@ -336,7 +341,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" ; the path is to a file that contains the package. If bool is #f, the package ; 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 pkg) + (define (download-package/planet pkg) (define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))