From e23db50e0674546040797255991fd82708a9f0bf Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 31 May 2010 08:59:15 -0500 Subject: [PATCH] Rackety planet command line tool --- collects/planet/info.rkt | 4 +- collects/planet/planet.rkt | 316 +---------------------- collects/planet/private/cmdline-tool.rkt | 303 ++++++++++++++++++++++ collects/planet/private/command.rkt | 15 +- collects/planet/raco.rkt | 8 + 5 files changed, 328 insertions(+), 318 deletions(-) create mode 100644 collects/planet/private/cmdline-tool.rkt create mode 100644 collects/planet/raco.rkt diff --git a/collects/planet/info.rkt b/collects/planet/info.rkt index b27175645e..1866cf8ade 100644 --- a/collects/planet/info.rkt +++ b/collects/planet/info.rkt @@ -2,7 +2,7 @@ (define name "PLaneT") (define mzscheme-launcher-names '("planet")) -(define mzscheme-launcher-libraries '("planet.ss")) +(define mzscheme-launcher-libraries '("planet.rkt")) (define scribblings '(("planet.scrbl" (multi-page) (tool)))) -(define raco-commands '(("planet" planet/planet "manage Planet package installations" 80))) +(define raco-commands '(("planet" planet/raco "manage Planet package installations" 80))) diff --git a/collects/planet/planet.rkt b/collects/planet/planet.rkt index 5b48d991bf..9018f1fc79 100644 --- a/collects/planet/planet.rkt +++ b/collects/planet/planet.rkt @@ -1,310 +1,8 @@ -(module planet mzscheme - #| -This module contains code that implements the `planet' command-line tool. - -PLANNED FEATURES: -* Disable a package without removing it (disabling meaning - that if it's a tool it won't start w/ DrRacket, etc) -|# - (require mzlib/string - mzlib/file - (only mzlib/list sort) - net/url - mzlib/match - raco/command-name - - "config.rkt" - "private/planet-shared.rkt" - "private/command.rkt" - "util.rkt") - - (define erase? (make-parameter #f)) - (define displayer (make-parameter (λ () (show-installed-packages)))) - - (define (start) +#lang scheme/base +(require "private/cmdline-tool.rkt") - (make-directory* (PLANET-DIR)) - (make-directory* (CACHE-DIR)) - (planet-logging-to-stdout #t) - - (svn-style-command-line - #:program (short-program+command-name) - #:argv (current-command-line-arguments) - "PLT Scheme PLaneT command-line tool. Provides commands to help you manipulate your local planet cache." - ["create" "create a PLaneT archive from a directory" - "\nCreate a PLaneT archive in the current directory whose contents are the directory ." - #:once-each - [("-f" "--force") ("force a package to be created even if its info.rkt file contains" - "errors.") - (force-package-building? #t)] - #:args (path) - (do-archive path)] - ["install" "download and install a given package" - " -Download and install the package that - (require (planet \"file.rkt\" ( ))) -would install" - #:args (owner pkg maj min) - (begin - (verify-package-name pkg) - (download/install owner pkg maj min))] - ["remove" "remove the specified package from the local cache" - " -Remove the specified package from the local cache, optionally also removing its distribution file" - #:once-each - [("-e" "--erase") - ("also remove the package's distribution file from the" - "uninstalled-package cache") - (erase? #t)] - #:args (owner pkg maj min) - ((if (erase?) erase remove) owner pkg maj min)] - ["show" "list the packages installed in the local cache" - "\nList the packages installed in the local cache" - #:once-any - [("-p" "--packages") "show packages only (default)" (displayer show-installed-packages)] - [("-l" "--linkage") "show linkage table only" (displayer show-linkage)] - [("-a" "--all") "show packages and linkage" (displayer (λ () (show-installed-packages) (newline) (show-linkage)))] - #:args () - ((displayer))] - ["clearlinks" "clear the linkage table, allowing upgrades" - "\nClear the linkage table, allowing upgrades" - #:args () - (unlink-all)] - ["fileinject" "install a local file to the planet cache" - " -Install local file into the planet cache as though it had been downloaded from the planet server. The installed package has path - (planet ( ))" - #:args (owner plt-file maj min) - (install-plt-file plt-file owner maj min)] - ["link" "create a development link" - "\nCreate a development link between the specified package specifier and the specified directory name" - #:args (owner pkg maj min path) - (begin - (verify-package-name pkg) - (add-hard-link-cmd owner pkg maj min path))] - ["unlink" "remove development link associated with the given package" - "\nRemove development link associated with the given package" - #:args (owner pkg maj min) - (begin - (verify-package-name pkg) - (remove-hard-link-cmd owner pkg maj min))] - ["fetch" "download a package file without installing it" - "\nDownload the given package file without installing it" - #:args (owner pkg maj min) - (begin - (verify-package-name pkg) - (download/no-install owner pkg maj min))] - ["url" "get a URL for the given package" - " -Get a URL for the given package. -This is not necessary for normal use of planet, but may be helpful in some circumstances for retrieving packages." - #:args (owner pkg maj min) - (begin - (verify-package-name pkg) - (get-download-url owner pkg maj min))] - ["open" "unpack the contents of the given package" - " -Unpack the contents of the given package into the given directory without installing. -This command is not necessary for normal use of planet. It is intended to allow you to inspect package contents offline without needing to install the package." - #:args (plt-file target) - (do-unpack plt-file target)] - - ["structure" "display the structure of a given .plt archive" - "\nPrint the structure of the PLaneT archive named by to the standard output port. -This command does not unpack or install the named .plt file." - #:args (plt-file) - (do-structure plt-file)] - - ["print" "display a file within of the given .plt archive" - "\nPrint the contents of the file named by , which must be a relative path within the PLaneT archive named by , to the standard output port. -This command does not unpack or install the named .plt file." - #:args (plt-file path) - (do-display plt-file path)] - - ;; unimplemented so far: - #;(("-u" "--unlink") - module - "Remove all linkage the given module has, forcing it to upgrade" - ...))) - - (define (verify-package-name pkg) - (unless (regexp-match #rx"\\.plt$" pkg) - (fprintf (current-error-port) "Expected package name to end with '.plt', got: ~a\n" pkg) - (exit 1))) - - - ;; ============================================================ - ;; FEATURE IMPLEMENTATIONS - - (define (fail s . args) - (raise (make-exn:fail (apply format s args) (current-continuation-marks)))) - (define (warn s . args) - (apply printf s args) - (newline)) - - (define (download/install owner name majstr minstr) - (let* ([maj (read-from-string majstr)] - [min (read-from-string minstr)] - [full-pkg-spec (get-package-spec owner name maj min)]) - (if (get-package-from-cache full-pkg-spec) - (warn "No package installed (cache already contains a matching package)") - (unless (download/install-pkg owner name maj min) - (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 (get-package-spec owner pkg maj min)]) - (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")]))) - - ;; 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")) - (let* ([fullspec (get-package-spec ownerstr pkgstr 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) - (fail "No such directory: ~a" p)) - (make-planet-archive (normalize-path p))) - - (define (remove owner pkg 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")) - (with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))]) - (remove-pkg owner pkg maj min)))) - - (define (erase owner pkg 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")) - (with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))]) - (erase-pkg owner pkg maj min)))) - - (define (show-installed-packages) - (let ([normal-packages (get-installed-planet-archives)] - [devel-link-packages (get-hard-linked-packages)]) - - (define (show-normals) - (printf "Normally-installed packages:\n") - (for-each - (lambda (l) (apply printf " ~a\t~a\t~a ~a\n" l)) - (sort-by-criteria - (map (lambda (x) (match x [(_ owner pkg _ maj min) (list owner pkg maj min)])) normal-packages) - (list string ~a\n" l)) - (sort-by-criteria - (map - (lambda (x) (match x [(dir owner pkg _ maj min) (list owner pkg maj min (path->string dir))])) - devel-link-packages) - (list stringpath pathstr)]) - (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0)) - (fail "Invalid major/minor version")) - (add-hard-link ownerstr pkgstr maj min path))) - - (define (remove-hard-link-cmd ownerstr pkgstr majstr minstr) - (let* ([maj (read-from-string majstr)] - [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))))) - - (define (do-unpack plt-file target) - (unless (file-exists? plt-file) - (fail (format "The specified file (~a) does not exist" plt-file))) - (let ([file (normalize-path plt-file)]) - (unpack-planet-archive file target))) - - (define (do-structure plt-file) - (unless (file-exists? plt-file) - (fail (format "The specified file (~a) does not exist" plt-file))) - (let ([file (normalize-path plt-file)]) - (display-plt-file-structure file))) - - (define (do-display plt-file file-to-print) - (unless (file-exists? plt-file) - (fail (format "The specified file (~a) does not exist" plt-file))) - (let ([file (normalize-path plt-file)]) - (display-plt-archived-file file file-to-print))) - - ;; ------------------------------------------------------------ - ;; Utility - - (define (sort-by-criteria l . criteria) - (sort l - (lambda (a b) - (let loop ((a a) (b b) (c criteria)) - (cond - [(null? a) #f] - [((caar c) (car a) (car b)) #t] - [(not ((cadar c) (car a) (car b))) #f] - [else (loop (cdr a) (cdr b) (cdr c))]))))) - - ;; ============================================================ - ;; start the program - - (with-handlers ([exn:fail? - (lambda (e) - ((error-display-handler) (exn-message e) e) - (exit 1))]) - (start))) +(with-handlers ([exn:fail? + (lambda (e) + ((error-display-handler) (exn-message e) e) + (exit 1))]) + (start #f)) \ No newline at end of file diff --git a/collects/planet/private/cmdline-tool.rkt b/collects/planet/private/cmdline-tool.rkt new file mode 100644 index 0000000000..0c97b9eec4 --- /dev/null +++ b/collects/planet/private/cmdline-tool.rkt @@ -0,0 +1,303 @@ +(module planet mzscheme + #| +This module contains code that implements the `planet' command-line tool. + +PLANNED FEATURES: +* Disable a package without removing it (disabling meaning + that if it's a tool it won't start w/ DrRacket, etc) +|# + (require mzlib/string + mzlib/file + (only mzlib/list sort) + net/url + mzlib/match + raco/command-name + + "../config.rkt" + "planet-shared.rkt" + "command.rkt" + "../util.rkt") + (provide start) + + (define erase? (make-parameter #f)) + (define displayer (make-parameter (λ () (show-installed-packages)))) + + (define (start raco?) + + (make-directory* (PLANET-DIR)) + (make-directory* (CACHE-DIR)) + (planet-logging-to-stdout #t) + + (svn-style-command-line + #:program (short-program+command-name) + #:argv (current-command-line-arguments) + #:prefix (if raco? "raco " "") + "The Racket command-line tool for manipulating packages installed by PLaneT." + ["create" "create a PLaneT archive from a directory" + "\nCreate a PLaneT archive in the current directory whose contents are the directory ." + #:once-each + [("-f" "--force") ("force a package to be created even if its info.rkt file contains" + "errors.") + (force-package-building? #t)] + #:args (path) + (do-archive path)] + ["install" "download and install a given package" + " +Download and install the package that + (require (planet \"file.rkt\" ( ))) +would install" + #:args (owner pkg maj min) + (begin + (verify-package-name pkg) + (download/install owner pkg maj min))] + ["remove" "remove the specified package from the local cache" + " +Remove the specified package from the local cache, optionally also removing its distribution file" + #:once-each + [("-e" "--erase") + ("also remove the package's distribution file from the" + "uninstalled-package cache") + (erase? #t)] + #:args (owner pkg maj min) + ((if (erase?) erase remove) owner pkg maj min)] + ["show" "list the packages installed in the local cache" + "\nList the packages installed in the local cache" + #:once-any + [("-p" "--packages") "show packages only (default)" (displayer show-installed-packages)] + [("-l" "--linkage") "show linkage table only" (displayer show-linkage)] + [("-a" "--all") "show packages and linkage" (displayer (λ () (show-installed-packages) (newline) (show-linkage)))] + #:args () + ((displayer))] + ["clearlinks" "clear the linkage table, allowing upgrades" + "\nClear the linkage table, allowing upgrades" + #:args () + (unlink-all)] + ["fileinject" "install a local file to the planet cache" + " +Install local file into the planet cache as though it had been downloaded from the planet server. The installed package has path + (planet ( ))" + #:args (owner plt-file maj min) + (install-plt-file plt-file owner maj min)] + ["link" "create a development link" + "\nCreate a development link between the specified package specifier and the specified directory name" + #:args (owner pkg maj min path) + (begin + (verify-package-name pkg) + (add-hard-link-cmd owner pkg maj min path))] + ["unlink" "remove development link associated with the given package" + "\nRemove development link associated with the given package" + #:args (owner pkg maj min) + (begin + (verify-package-name pkg) + (remove-hard-link-cmd owner pkg maj min))] + ["fetch" "download a package file without installing it" + "\nDownload the given package file without installing it" + #:args (owner pkg maj min) + (begin + (verify-package-name pkg) + (download/no-install owner pkg maj min))] + ["url" "get a URL for the given package" + " +Get a URL for the given package. +This is not necessary for normal use of planet, but may be helpful in some circumstances for retrieving packages." + #:args (owner pkg maj min) + (begin + (verify-package-name pkg) + (get-download-url owner pkg maj min))] + ["open" "unpack the contents of the given package" + " +Unpack the contents of the given package into the given directory without installing. +This command is not necessary for normal use of planet. It is intended to allow you to inspect package contents offline without needing to install the package." + #:args (plt-file target) + (do-unpack plt-file target)] + + ["structure" "display the structure of a given .plt archive" + "\nPrint the structure of the PLaneT archive named by to the standard output port. +This command does not unpack or install the named .plt file." + #:args (plt-file) + (do-structure plt-file)] + + ["print" "display a file within of the given .plt archive" + "\nPrint the contents of the file named by , which must be a relative path within the PLaneT archive named by , to the standard output port. +This command does not unpack or install the named .plt file." + #:args (plt-file path) + (do-display plt-file path)] + + ;; unimplemented so far: + #;(("-u" "--unlink") + module + "Remove all linkage the given module has, forcing it to upgrade" + ...))) + + (define (verify-package-name pkg) + (unless (regexp-match #rx"\\.plt$" pkg) + (fprintf (current-error-port) "Expected package name to end with '.plt', got: ~a\n" pkg) + (exit 1))) + + + ;; ============================================================ + ;; FEATURE IMPLEMENTATIONS + + (define (fail s . args) + (raise (make-exn:fail (apply format s args) (current-continuation-marks)))) + (define (warn s . args) + (apply printf s args) + (newline)) + + (define (download/install owner name majstr minstr) + (let* ([maj (read-from-string majstr)] + [min (read-from-string minstr)] + [full-pkg-spec (get-package-spec owner name maj min)]) + (if (get-package-from-cache full-pkg-spec) + (warn "No package installed (cache already contains a matching package)") + (unless (download/install-pkg owner name maj min) + (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 (get-package-spec owner pkg maj min)]) + (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")]))) + + ;; 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")) + (let* ([fullspec (get-package-spec ownerstr pkgstr 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) + (fail "No such directory: ~a" p)) + (make-planet-archive (normalize-path p))) + + (define (remove owner pkg 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")) + (with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))]) + (remove-pkg owner pkg maj min)))) + + (define (erase owner pkg 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")) + (with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))]) + (erase-pkg owner pkg maj min)))) + + (define (show-installed-packages) + (let ([normal-packages (get-installed-planet-archives)] + [devel-link-packages (get-hard-linked-packages)]) + + (define (show-normals) + (printf "Normally-installed packages:\n") + (for-each + (lambda (l) (apply printf " ~a\t~a\t~a ~a\n" l)) + (sort-by-criteria + (map (lambda (x) (match x [(_ owner pkg _ maj min) (list owner pkg maj min)])) normal-packages) + (list string ~a\n" l)) + (sort-by-criteria + (map + (lambda (x) (match x [(dir owner pkg _ maj min) (list owner pkg maj min (path->string dir))])) + devel-link-packages) + (list stringpath pathstr)]) + (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0)) + (fail "Invalid major/minor version")) + (add-hard-link ownerstr pkgstr maj min path))) + + (define (remove-hard-link-cmd ownerstr pkgstr majstr minstr) + (let* ([maj (read-from-string majstr)] + [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))))) + + (define (do-unpack plt-file target) + (unless (file-exists? plt-file) + (fail (format "The specified file (~a) does not exist" plt-file))) + (let ([file (normalize-path plt-file)]) + (unpack-planet-archive file target))) + + (define (do-structure plt-file) + (unless (file-exists? plt-file) + (fail (format "The specified file (~a) does not exist" plt-file))) + (let ([file (normalize-path plt-file)]) + (display-plt-file-structure file))) + + (define (do-display plt-file file-to-print) + (unless (file-exists? plt-file) + (fail (format "The specified file (~a) does not exist" plt-file))) + (let ([file (normalize-path plt-file)]) + (display-plt-archived-file file file-to-print))) + + ;; ------------------------------------------------------------ + ;; Utility + + (define (sort-by-criteria l . criteria) + (sort l + (lambda (a b) + (let loop ((a a) (b b) (c criteria)) + (cond + [(null? a) #f] + [((caar c) (car a) (car b)) #t] + [(not ((cadar c) (car a) (car b))) #f] + [else (loop (cdr a) (cdr b) (cdr c))])))))) diff --git a/collects/planet/private/command.rkt b/collects/planet/private/command.rkt index 44d19e4711..65ddcc799d 100644 --- a/collects/planet/private/command.rkt +++ b/collects/planet/private/command.rkt @@ -35,17 +35,19 @@ (syntax-case stx () [(_ #:program prog #:argv args + #:prefix pfx-e general-description [name description long-description body ... #:args formals final-expr] ...) (with-syntax ([(n ...) (generate-temporaries #'(name ...))]) - #'(let* ([p prog] + #'(let* ([pfx-x pfx-e] + [p prog] [a args] [n name] ... [argslist (cond [(list? a) a] [(vector? a) (vector->list a)] [else (error 'command "expected a vector or list for arguments, received ~e" a)])] - [help (λ () (display-help-message p general-description `((name description) ...)))]) + [help (λ () (display-help-message p pfx-x general-description `((name description) ...)))]) (let-values ([(the-command remainder) (if (null? argslist) (values "help" '()) @@ -71,20 +73,19 @@ ;; display-help-message : string (listof (list string string)) -> void ;; prints out the help message -(define (display-help-message prog general-description commands) +(define (display-help-message prog prefix general-description commands) (let* ([maxlen (apply max (map (λ (p) (string-length (car p))) commands))] [message-lines `(,(format "Usage: ~a [option ...] " prog) - "[note: you can name a subcommand by typing any unambiguous prefix of it.]" + ,(format "[note: you can name a ~a subcommand by typing any unambiguous prefix of it.]" prog) "" ,@(wrap-to-count general-description 80) "" - "For help on a particular subcommand, type 'planet --help'" - "Available subcommands:" + ,(format "For help on a particular subcommand, type '~aplanet --help'" prefix) ,@(map (λ (command) (let* ([padded-name (pad (car command) maxlen)] [desc (cadr command)] - [msg (format " ~a ~a" padded-name desc)]) + [msg (format " ~aplanet ~a ~a" prefix padded-name desc)]) msg)) commands))]) (for-each (λ (line) (display line) (newline)) message-lines))) diff --git a/collects/planet/raco.rkt b/collects/planet/raco.rkt new file mode 100644 index 0000000000..a32da7c522 --- /dev/null +++ b/collects/planet/raco.rkt @@ -0,0 +1,8 @@ +#lang scheme/base +(require "private/cmdline-tool.rkt") + +(with-handlers ([exn:fail? + (lambda (e) + ((error-display-handler) (exn-message e) e) + (exit 1))]) + (start #t)) \ No newline at end of file