;; -*- mode: scheme -*- (import (only chicken.platform repository-path) (only chicken.io read-line read-string) (only chicken.process process-run process-wait) (only chicken.process-context command-line-arguments) (only chicken.string string-split) (only chicken.file directory) (only chicken.pathname make-pathname pathname-file pathname-extension) (only chicken.irregex string->irregex irregex-search) (only srfi-1 filter lset-difference) (only srfi-13 string-join) (only fmt fmt dsp fmt-join tabular) (only fmt-color fmt-bold) (only fmt-unicode fmt-unicode) (only ssax ssax:xml->sxml) (only sxpath-lolevel sxml:text) (only sxpath sxpath) (only http-client call-with-input-request) (only uri-common uri-reference) args) (define opts (list (args:make-option (u unknown) #:none "try updating packages with unknown version") (args:make-option (p pin) (#:required "REGEX") "pin packages matching REGEX" (set! arg (string->irregex arg))) (args:make-option (s sudo) #:none "pass -sudo option to chicken-install") (args:make-option (h help) #:none "Display this text" (usage)))) (define (usage) (print "Usage: chicken-update [OPTION ...]") (newline) (print (args:usage opts)) (exit 1)) (define (upstream-egg-list) (let* ((sxml (call-with-input-request (uri-reference "http://eggs.call-cc.org/rss-5.xml") #f (cut ssax:xml->sxml <> '()))) (titles ((sxpath `(// channel item ((title ,(lambda (nodeset var-binding) (sxml:text nodeset)))))) sxml))) (map (lambda (s) (let ((parts (string-split s))) (cons (car parts) (cadr parts)))) titles))) (define (installed-egg-list) (define (is-egginfo? f) (string=? (pathname-extension f) "egg-info")) (define (get-egginfo-abspath d) (map (cut make-pathname d <> ) (filter is-egginfo? (directory d)))) (define (egginfo-version f) (and-let* ((version (alist-ref 'version (call-with-input-file f read) eqv?))) (car version))) (let* ((egginfo-files (join (map get-egginfo-abspath (repository-path)))) (egg-names (map pathname-file egginfo-files)) (egg-versions (map egginfo-version egginfo-files))) (map cons egg-names egg-versions))) (define (updateable-egg-list upstream options) (define (try-update-egg? egg) (let ((unknown (alist-ref 'unknown options)) (pin (alist-ref 'pin options))) (and (if pin (not (irregex-search pin (car egg))) #t) (if unknown #t (cdr egg))))) (let* ((installed (filter try-update-egg? (installed-egg-list))) (not-upstream (lset-difference (lambda (a b) (string=? (car a) (car b))) installed upstream)) (eggs (lset-difference equal? installed upstream not-upstream))) (values eggs (map car not-upstream)))) (define (run-chicken-install eggs options) (let* ((args (if (alist-ref 'sudo options) (append eggs '("-s")) eggs)) (pid (process-run "chicken-install" args))) (receive (pid normal-exit exit-status) (process-wait pid) (if (not (zero? exit-status)) (begin (display "chicken-install finished with a non-zero exit status.\n" (current-error-port)) (exit 1)) (print "Done updating eggs."))))) (define (print-updateable-eggs eggs old-versions new-versions) (fmt #t (fmt-unicode (tabular (fmt-join dsp (append (list (fmt-bold "Eggs (" (length eggs) ")") "") eggs) "\n") " " (fmt-join dsp (append (list "Old Version" "") old-versions) "\n") " " (fmt-join dsp (append (list "New Version" "") new-versions) "\n"))))) (define (main args) (receive (options operands) (args:parse args opts) (let* ((upstream-eggs (upstream-egg-list))) (receive (to-update not-upstream) (updateable-egg-list upstream-eggs options) (when (not (null? not-upstream)) (print "The following eggs were not found upstream:") (newline) (print " " (string-join not-upstream " ")) (newline)) (if (null? to-update) (print "Nothing to update.") (let ((eggs (map car to-update)) (old-versions (map cdr to-update)) (new-versions (map (lambda (x) (cdr (assoc (car x) upstream-eggs))) to-update))) (print-updateable-eggs eggs old-versions new-versions) (display "Proceed? [y/n]: ") (when (string=? (read-string 1) "y") (run-chicken-install eggs options)))))))) (main (command-line-arguments))