(module archive-contents-git-to-db ()

(import scheme)
(import (chicken base))
(import (chicken format))
(import (chicken irregex))
(import (chicken port))
(import (chicken process-context))
(import (chicken string))
(import (chicken time posix))
(import (srfi 1))
(import scsh-process)
(import sql-de-lite)

(define stderr (current-error-port))

(define (string-starts-with? s prefix)
  (and (irregex-search `(: bol ,(irregex-quote prefix)) s) #t))

;;; time

(define time/seconds 0)
(define time/minutes 1)
(define time/hours 2)

(define duration/day (* 24 60 60))

(define (adjust-date date amount)
  (seconds->utc-time (+ (utc-time->seconds date) amount)))

(define (copy-date date)
  (adjust-date date 0))

(define (adjust-date-to-end-of-day! date)
  (vector-set! date time/seconds 59)
  (vector-set! date time/minutes 59)
  (vector-set! date time/hours 23))

(define (make-comparator comp key)
  (lambda (a b) (comp (key a) (key b))))

(define (time->git-string date) (time->string date "%Y-%m-%d %H:%M:%S %z"))

(define (time->date-string date) (time->string date "%Y-%m-%d"))

(define date>=? (make-comparator string>=? time->date-string))
(define date>? (make-comparator string>? time->date-string))

;;; git

(define (repo-from-date path)
  (let ((commit (run/sexp (git -C ,path rev-list --max-parents=0 HEAD))))
    (seconds->utc-time
     (run/sexp (git -C ,path show --no-patch --pretty=format:%ct ,commit)))))

(define (repo-to-date path)
  (seconds->utc-time
   (run/sexp (git -C ,path log --pretty=format:%ct -n 1))))

(define (git-commit-for repo-path commit file)
  (run/string (git -C ,repo-path show ,(format "~a:~a" commit file))))

(define (repo-dirs-at path commit)
  (let* ((lines (run/strings (git -C ,path ls-tree ,commit)))
         (dir-lines (filter (lambda (line) (string-starts-with? line "040000"))
                            lines)))
    (map (lambda (line) (cadr (string-split line "\t"))) dir-lines)))

(define (repo-file-at repo-path commit file)
  (run/string (git -C ,repo-path show ,(format "~a:~a" commit file))))

(define (repo-rev-list repo-path from to)
  (let ((from-arg (format "--after=~a" (time->git-string from)))
        (to-arg (format "--before=~a" (time->git-string to))))
    (map (lambda (line)
           (let ((parts (string-split line)))
             (cons (seconds->utc-time (string->number (car parts)))
                   (cadr parts))))
         (run/strings (git -C ,repo-path rev-list "--pretty=format:%ct %H"
                           --first-parent ,from-arg ,to-arg
                           --no-commit-header @)))))

(define (repo-rev-list-loop proc repo-path from to)
  (let loop ((date (copy-date to))
             (revs (repo-rev-list repo-path from to)))
    (adjust-date-to-end-of-day! date)
    (let ((revs (find-tail (lambda (rev) (date>=? date (car rev))) revs)))
      (when revs
        (proc date (car revs))
        (when (date>? date from)
          (loop (adjust-date date (- duration/day)) revs))))))

;;; stats

(define (archive-count archive-contents)
  (length (cdr (call-with-input-string archive-contents read))))

(define (archive-count-for db archive date-label)
  (query fetch-value
         (sql db "SELECT package_count
                    FROM archive_counts
                   WHERE archive = ? AND date = ?")
         archive date-label))

(define (insert-archive-count! db archive date-label count)
  (exec (sql db "INSERT INTO archive_counts(archive, date, package_count)
                 VALUES(?, ?, ?)")
        archive date-label count))

(define main
  (case-lambda
   ((repo-path db-path)
    (call-with-database db-path
      (lambda (db)
        (with-transaction db
          (lambda ()
            (repo-rev-list-loop
             (lambda (date rev)
               (let ((commit (cdr rev)))
                 (for-each
                  (lambda (archive)
                    (let ((date-label (time->string date "%Y-%m-%d" date)))
                      (when (not (archive-count-for db archive date-label))
                        (let* ((path (format "~a/archive-contents" archive))
                               (contents (repo-file-at repo-path commit path))
                               (count (archive-count contents)))
                          (insert-archive-count! db archive date-label count)
                          (printf "~a ~a: ~a\n" date-label archive count)))))
                  (repo-dirs-at repo-path commit))))
             repo-path
             (repo-from-date repo-path)
             (repo-to-date repo-path))
            'commit)))))
   (_
    (fprintf stderr "usage: ~a <repo> <db>\n" (program-name))
    (exit 1))))

(apply main (command-line-arguments))

)