diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss index 2363543f45..046459c047 100644 --- a/collects/planet/planet.ss +++ b/collects/planet/planet.ss @@ -13,9 +13,11 @@ PLANNED FEATURES: (lib "string.ss") (lib "file.ss") (only (lib "list.ss") sort) + (lib "url.ss" "net") (lib "match.ss") "config.ss" + "private/planet-shared.ss" "resolver.ss" ;; the code I need should be pulled out into a common library "util.ss") @@ -85,7 +87,12 @@ PLANNED FEATURES: "" "Remove any development link associated with the specified package" (set! actions (cons (lambda () (remove-hard-link-cmd owner pkg maj min)) actions))) - + + (("--url") + owner pkg maj min + "Get a URL for the given package" + (set! actions (cons (lambda () (get-download-url owner pkg maj min)) actions))) + ;; unimplemented so far: #;(("-u" "--unlink") module @@ -122,19 +129,24 @@ PLANNED FEATURES: [_ (fail "Could not find matching package")]))) - - (define (install-plt-file filestr owner majstr minstr) + ;; params->full-pkg-spec : string string string string -> pkg + ;; gets a full package specifier for the given specification + (define (params->full-pkg-spec ownerstr pkgstr 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 "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)] + (let* ([spec (list ownerstr pkgstr maj min)] [fullspec (pkg-spec->full-pkg-spec spec #f)]) - (unless spec (fail "invalid spec: ~a" spec)) - (install-pkg fullspec file maj min)))) + (unless fullspec (fail "invalid spec: ~a" fullspec)) + fullspec))) + + (define (install-plt-file filestr owner majstr minstr) + (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))] + [fullspec (params->full-pkg-spec owner name majstr minstr)]) + (install-pkg fullspec file (pkg-spec-maj fullspec) (pkg-spec-minor-lo fullspec)))) (define (do-archive p) (unless (directory-exists? p) @@ -212,6 +224,10 @@ PLANNED FEATURES: [min (read-from-string minstr)]) (remove-hard-link ownerstr pkgstr maj min))) + (define (get-download-url ownerstr pkgstr majstr minstr) + (let ([fps (params->full-pkg-spec ownerstr pkgstr majstr minstr)]) + (printf "~a\n" (url->string (pkg->download-url fps))))) + ;; ------------------------------------------------------------ ;; Utility diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index afecd1e7b2..65d8eb083d 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -164,6 +164,7 @@ an appropriate subdirectory. get-package-from-cache get-package-from-server download-package + pkg->download-url install-pkg get-planet-module-path/pkg) @@ -500,6 +501,12 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" (let ((parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header))) (and parsed (cadr parsed)))) + ;; pkg->download-url : FULL-PKG-SPEC -> url + ;; gets the download url for the given package + (define (pkg->download-url pkg) + (copy-struct url (string->url (HTTP-DOWNLOAD-SERVLET-URL)) (url-query (pkg->servlet-args pkg)))) + + ;; download-package/http : FULL-PKG-SPEC -> RESPONSE ;; a drop-in replacement for download-package that uses HTTP rather than the planet protocol. ;; The HTTP protocol does not allow any kind of complicated negotiation, but it appears that @@ -511,8 +518,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" "Download failed too many times (possibly due to an unreliable network connection)" (current-continuation-marks)))) - (let* ((args (pkg->servlet-args pkg)) - (target (copy-struct url (string->url (HTTP-DOWNLOAD-SERVLET-URL)) (url-query args))) + (let* ((target (pkg->download-url pkg)) (ip (get-impure-port target)) (head (purify-port ip)) (response-code/str (get-http-response-code head)) diff --git a/collects/planet/util.ss b/collects/planet/util.ss index 6b2522db07..300f697540 100644 --- a/collects/planet/util.ss +++ b/collects/planet/util.ss @@ -5,7 +5,7 @@ "private/planet-shared.ss" "private/linkage.ss" - + (lib "url.ss" "net") (lib "pack.ss" "setup") (lib "contract.ss") (lib "file.ss")