;; -*- 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 ->string)
        (only chicken.file directory)
        (only chicken.pathname make-pathname pathname-file pathname-extension)
        (only chicken.irregex
              string->irregex
              irregex-search
              irregex-split)
        (only chicken.condition handle-exceptions print-error-message)
        (only chicken.port with-output-to-port)
        (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)
        (only optimism parse-command-line))

(define opts
  `((-h)
    (--help)
    (--pin . ,string->irregex)
    (--unknown)))

(define (usage status)
  (print "Usage: chicken-update [OPTION ...]")
  (print "All other options are passed directly to chicken-install.")
  (print "
      --unknown            try updating packages with unknown version
      --pin=REGEX          pin packages matching REGEX
  -h, --help               Display this text")
  (cond-expand
    ((or chicken-script compiling)
     (exit status))
    (else)))

(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 (version>=? v1 v2)
  (define (version->list v)
    (map (lambda (x) (or (string->number x) x))
	 (irregex-split "[-\\._]" (->string v))))
  (let loop ((p1 (version->list v1))
	     (p2 (version->list v2)))
    (cond ((null? p1) (null? p2))
	  ((null? p2))
	  ((number? (car p1))
	   (and (number? (car p2))
		(or (> (car p1) (car p2))
		    (and (= (car p1) (car p2))
			 (loop (cdr p1) (cdr p2))))))
	  ((number? (car p2)))
	  ((string>? (car p1) (car p2)))
	  (else
	   (and (string=? (car p1) (car p2))
		(loop (cdr p1) (cdr p2)))))))

(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 (lambda (a b)
                                  (and (string=? (car a) (car b))
                                       (version>=? (cdr a) (cdr b))))
                                installed upstream not-upstream)))
    (values eggs (map car not-upstream))))

(define (run-chicken-install args)
  (let* ((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)
  (let ((options (handle-exceptions exn
                     (begin
                       (print-error-message exn (current-error-port))
                       (newline (current-error-port))
                       (usage 1))
                   (parse-command-line args opts))))
    (when (or (assv '--help options)
              (assv '-h options))
      (usage 0))
    (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 (append (alist-ref '-- options) eggs)))))))))

(main (command-line-arguments))