#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/config
planet/private/planet-shared)))
(require net/url xml)
(require mzlib/pregexp)
(provide get-all-planet-packages
get-all-installed-packages
install-planet-package
uninstall-planet-package
documentation-url
(struct-out planet-package)
installed?)
(permissive? #t)
(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))
(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 ...))
(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 ...))))
(read-packages 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 (documentation-url package)
(define (remove-extension str)
(pregexp-replace #rx"(.*)\\..*" str (lambda (all x) x)))
(let ([pkg (planet:get-installed-package
(planet-package-owner package)
(planet-package-name package)
#f #f)])
(path->string
(build-path (planet:CACHE-DIR)
(planet-package-owner package)
(planet-package-name package)
(number->string (planet:pkg-maj pkg))
(number->string (planet:pkg-min pkg))
"planet-docs"
(remove-extension
(planet-package-name package))
"index.html"))))
(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))))