#lang scheme

(require (prefix-in planet: (combine-in planet/planet-archives
                                        planet/util
                                        (only-in planet/resolver pkg-spec->full-pkg-spec
                                                 get-package-from-server
                                                 pkg-promise->pkg)
                                        planet/private/data
                                        planet/private/planet-shared)))

(require net/url xml)

(provide get-all-planet-packages
         get-all-installed-packages
         install-planet-package
         uninstall-planet-package
         (struct-out planet-package)
         installed?)

(permissive? #t)

;; string -> sxml
(define (retrieve-html url)
  #;
  (with-input-from-file "index.html"
                        (lambda ()
                          (read-xml)))
  (read-xml (get-pure-port (string->url url))))

(define-struct planet-package (url name owner major minor))

;; html / body / div class=planet / div class=description / 2nd table

(define (planet-content xexpr)
  (define (read-packages rows)
    (let ([categories (make-hash)])
      (let loop ([rows rows]
                 [current-name ""]
                 [packages (list)])
        (if (null? rows)
          (begin
            (hash-set! categories current-name packages)
            categories)
        (match (car rows)
               [(list 'tr _ (list 'td _
                                  (list 'table _ (list 'tr _ (list 'td _ (list 'b _
                                                                               (list 'font _ _ name)))))))
                (when (not (string=? current-name ""))
                  (hash-set! categories current-name packages))
                (loop (cdr rows) name '())]

               [(list 'tr
                      (list (list 'class "filledin"))
                      (list 'td _ _ (list 'a (list (list 'href url)) package-name))
                      (list 'td _ planet-version ...)
                      (list 'td _ external-version)
                      (list 'td _ (list 'a _ owner))
                      (list 'td _ description))
                (loop (cdr rows) current-name (cons (make-planet-package url package-name owner #f #f) packages))]

               [else (loop (cdr rows) current-name packages)])))))
  (match xexpr
         #;
         [(list 'html _ x ...) x]
         [(list 'html _ ... (list 'body attributes body-stuff ...))
          ;; (pretty-print body-stuff)
          (match body-stuff
                 [(list _ ... (list 'div _ ... (list (list 'class "content")) x ...) _ ...)
                  (match x
                         [(list _ ... (list 'div _ ... (list (list 'class "planet")) _ ...)
                                _ ... (list 'div _ ... (list (list 'class "planet")) _ ...
                                            (list 'div _ ... (list (list 'class "description")) _ ... (list 'table _ ...) (list 'table attributes x ...))))
                          ;; (printf "\n\n\n")
                          ;; (pretty-print x)
                          (read-packages x)])])]
          ;; (list 'div _ ... (list (list 'class 'planet)) x ...))) x]
         #;
         [(list 'html _ ... (list 'body _ ... (list 'div _ ... (list 'class 'planet) _ ... (list 'div _ ... (list 'class 'description) _ ... (list 'table rows ...)))))
          rows]))

(define (get-all-planet-packages)
  (let ([raw-html (xml->xexpr (document-element (retrieve-html "http://planet.plt-scheme.org")))])
    (planet-content raw-html)))

(define (get-all-installed-packages)
  (planet:get-all-planet-packages))

(define (install-planet-package planet-package)
  (let ([pkg (planet:get-package-from-server
               (planet:pkg-spec->full-pkg-spec
                 (list (planet-package-owner planet-package)
                       (planet-package-name planet-package))
                 #f))])
    (when (planet:uninstalled-pkg? pkg)
      (planet:pkg-promise->pkg pkg))))

(define (uninstall-planet-package planet-package)
  (let ([pkg (planet:get-installed-package
               (planet-package-owner planet-package)
               (planet-package-name planet-package)
               #f #f)])
    (planet:remove-pkg (planet-package-owner planet-package)
                       (planet-package-name planet-package)
                       (planet:pkg-maj pkg)
                       (planet:pkg-min pkg))))

(define (installed? planet-package)
  (not (not (planet:get-installed-package (planet-package-owner planet-package)
                                          (planet-package-name planet-package)
                                          #f #f))))