;; -*- 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 optimism parse-command-line))

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

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

(define pin-regex
  (make-parameter #f (lambda (param) (and param (string->irregex param)))))

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

(define opts
  `((-h)
    ((--help -h))
    (--pin . ,pin-regex)
    (--upstream-egg-list-uri . ,upstream-egg-list-uri)
    (--local-only)
    (--unknown)))

(define (usage status)
  (print "Usage: chicken-update [OPTION ...]")
  (print "All other options are passed directly to chicken-install.")
  (print "
      --unknown                  try updating eggs with unknown version
      --upstream-egg-list-uri    location of the egg list RSS feed, by default
                                   https://eggs.call-cc.org/rss-5.xml
      --pin=REGEX                pin eggs matching REGEX
  -h, --help                     Display this text")
      ;; --local-only               skip the network check, use only local directories
      ;;                              specified in setup.defaults
  (cond-expand
    ((or chicken-script compiling)
     (exit status))
    (else)))

;; (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 (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? (assv '--unknown (options))))
    (define (try-update-egg? egg)
      (let ((pin (pin-regex)))
        (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 (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))
  (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))