(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/ DrScheme, etc)
|#
  (require mzlib/string
           mzlib/file
           (only mzlib/list sort)
           net/url
           mzlib/match
           
           "config.ss"
           "private/planet-shared.ss"
           "private/command.ss"
           "util.ss") 
  
  (define erase? (make-parameter #f))
  (define displayer (make-parameter (λ () (show-installed-packages))))
  
  (define (start)

    (make-directory* (PLANET-DIR))
    (make-directory* (CACHE-DIR))
    (planet-logging-to-stdout #t)
    
    (svn-style-command-line
     #:program "planet"
     #: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 <path>."
      #:once-each
      [("-f" "--force") ("force a package to be created even if its info.ss 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.ss\" (<owner> <pkg> <maj> <min>)))
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 <plt-file> into the planet cache as though it had been downloaded from the planet server.  The installed package has path
  (planet (<owner> <plt-file's filename> <maj> <min>))"
       #: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 <plt-file> 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 <path>, which must be a relative path within the PLaneT archive named by <plt-file>, 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 (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)])
      (when (get-package-from-cache full-pkg-spec)
        (fail "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<? string=?)
          (list string<? string=?)
          (list < =)
          (list < =))))
      
      (define (show-devel-links)
        (printf "Development links:\n")
        (for-each 
         (lambda (l) (apply printf "  ~a\t~a\t~a ~a\n    --> ~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 string<? string=?)
          (list string<? string=?)
          (list < =)
          (list < =)
          (list string<? string=?))))
      
      (cond
        [(and (pair? normal-packages) (pair? devel-link-packages))
         (begin 
           (show-normals)
           (newline)
           (show-devel-links))]
        [(pair? normal-packages) (show-normals)]
        [(pair? devel-link-packages) (show-devel-links)]
        [else (printf "No packages installed.\n")])))
      
  
  (define (show-linkage)
    (for-each
     (lambda (module)
       (printf "  ~a:\n" (car module))
       (for-each 
        (lambda (link) (apply printf "    ~a\t~a\t~a ~a\n" link))
        (cdr module)))
     (sort (current-linkage) (lambda (a b) (string<? (car a) (car b))))))
  
  (define (add-hard-link-cmd ownerstr pkgstr majstr minstr pathstr)
    (let* ([maj (read-from-string majstr)]
           [min (read-from-string minstr)]
           [path (string->path 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)))