;; -*- mode: scheme -*-
(import (only chicken.platform repository-path include-path)
        (only chicken.io read-line read-string read-list)
        (only chicken.process process-run process-wait)
        (only chicken.process-context command-line-arguments)
        (only chicken.string string-intersperse string-split ->string)
        (only chicken.file directory)
        (only chicken.pathname make-pathname pathname-file pathname-extension)
        (only chicken.condition condition-case print-error-message)
        (only chicken.irregex
              string->irregex
              irregex-search
              irregex-split
              irregex-extract)
        (only chicken.condition handle-exceptions print-error-message)
        (only chicken.port with-output-to-port)
        (only srfi-1 filter append-map lset-union)
        (only http-client call-with-input-request)
        (only uri-common uri-reference)
        (only getopt-long getopt-long usage))

(cond-expand
  ((not chicken-5)
   (import (only (scheme base) make-parameter)))
  (else))

(define upstream-egg-list-uri
  (cond-expand
    (chicken-5
     "https://eggs.call-cc.org/rss-5.xml")
    (chicken-6
     "https://eggs.call-cc.org/rss-6.xml")))

(define options
  (make-parameter '()))

(define opts
  `((help "print usage"
          (required #f)
          (single-char #\h))
    (pin "pin eggs matching REGEX"
         (required #f)
         (value (required REGEX)))
    (upstream-egg-list-uri "location of the eg list RSS feed, by default https://eggs.call-cc.org/rss-5.xml"
                           (required #f))
    (unknown "try updating eggs with unknown version"
             (required #f))))

(define (chicken-update-usage status)
  (print "Usage: chicken-update [OPTION ...]")
  (print (usage opts))
  (exit status))

;; (define (location-upstream-eggs)
;;   (let* ((setup.defaults (call-with-input-file (make-pathname (include-path) "setup.defaults") read-list))
;;          (locations (append-map cdr (filter (lambda (kv) (eqv? (car kv) 'location)) setup.defaults))))
;;     (for-each print locations)
;;     (if (null? locations) locations
;;         (append-map
;;          (lambda (dir)
;;            (let ((eggs (directory dir)))
;;              (map (lambda (egg)
;;                     (cons egg (car (sort (directory (make-pathname dir egg)) version>=?))))
;;                   eggs)))
;;          locations))))

(define (try-get-rss-xml)
  (let loop ((count 1)
             (exn #f))
    (if (= count 3)
        (with-output-to-port (current-error-port)
          (begin
            (display "Unable to fetch eggs after 3 tries" (current-error-port))
            (print-error-message exn (current-error-port))
            (exit 1)))
        (condition-case
            (call-with-input-request
             (uri-reference (or (alist-ref 'upstream-egg-list-uri (options))
                                upstream-egg-list-uri))
             #f
             (cut read-string #f <>))
          [exn (exn i/o net) (loop (+ count 1) exn)]
          ))))

(define (rss-upstream-eggs)
  (let ((raw-titles (cdr (irregex-extract "<title>[^<]+" (try-get-rss-xml)))))
    (map
     (lambda (s)
       (let ((parts (string-split s "> ")))
         (cons (cadr parts) (caddr parts))))
     raw-titles)))

;; (define (upstream-eggs)
;;   (let* ((local-upstream (location-upstream-eggs))
;;          (rss-upstream (if (assv '--local-only (options))
;;                               '()
;;                               (rss-upstream-eggs))))
;;     (lset-union (lambda (a b) (equal? (car a) (car b)))
;;                 local-upstream
;;                 rss-upstream)))

(define (installed-eggs)
  (define (is-egginfo? f)
    (let ((ext (pathname-extension f)))
      (and ext (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 (outdated-eggs)
  (let ((try-unknown? (alist-ref 'unknown (options))))
    (define (try-update-egg? egg)
      (let ((pin (alist-ref 'pin (options))))
        (and (if try-unknown? #t (cdr egg))
             (if pin (not (irregex-search pin (car egg))) #t))))
    (let* ((installed (filter try-update-egg? (installed-eggs)))
           (upstream (rss-upstream-eggs)))
      (apply
       values
       (let loop ((installed installed)
                  (outdated '())
                  (not-upstream '()))
         (if (null? installed)
             (list outdated not-upstream)
             (let* ((egg (car installed))
                    (upstream-egg (assoc (car egg) upstream))
                    (egg-outdated? (and upstream-egg
                                        (or (and try-unknown? (not (cdr egg)))
                                            (not (version>=? (cdr egg) (cdr upstream-egg)))))))
               (loop (cdr installed)
                     (if egg-outdated?
                         (cons (list (car egg) (cdr egg) (cdr upstream-egg)) outdated)
                         outdated)
                     (if upstream-egg
                         not-upstream
                         (cons (car egg) 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-table rows column-spacing)
  (let* ((width-info (let loop ((rows rows)
                                (max-lengths '(0 0 0))
                                (collect '()))
                       (if (null? rows)
                           (cons max-lengths collect)
                           (let* ((row (car rows))
                                  (lengths (map string-length row))
                                  (max-lengths (map max max-lengths lengths)))
                             (loop (cdr rows)
                                   max-lengths
                                   (cons (map cons row lengths) collect))))))
         (widths (car width-info))
         (rows (cdr width-info)))
    (for-each (lambda (row)
                (let loop ((widths widths)
                           (cells row))
                  (if (null? widths)
                      #t
                      (begin
                        (display (caar cells))
                        (display (make-string (- (car widths) (cdar cells) (- column-spacing)) #\space))
                        (loop (cdr widths) (cdr cells)))))
                (newline))
              (reverse rows))))

(define (print-outdated-eggs eggs)
  (let* ((num-eggs (length eggs))
         (eggs (cons `(,(string-append "Eggs (" (number->string num-eggs) ")")
                       "Old Version"
                       "New Version")
                     eggs)))
    (print-table eggs 2)))

(define (main args)
  (options (getopt-long (command-line-arguments) opts
                        #:unkwown-option-handler (lambda (c) (chicken-update-usage 1))))
  (when (alist-ref 'help (options))
    (chicken-update-usage 0))
  (receive (to-update not-upstream) (outdated-eggs)
    (when (not (null? not-upstream))
      (print "The following eggs were not found upstream:")
      (newline)
      (print "  " (string-intersperse not-upstream " "))
      (newline))
    (if (null? to-update)
        (print "Nothing to update.")
        (begin
          (print-outdated-eggs to-update)
          (display "Proceed? [y/n]: ")
          (when (string=? (read-string 1) "y")
            (run-chicken-install (append (alist-ref '@ (options)) (map car to-update))))))))

(main (command-line-arguments))