Added --url option to planet command-line tool

svn: r3733

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

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

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