(module melpa-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))

;;; 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 (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 (make-comparator comp key)
  (lambda (a b) (comp (key a) (key b))))

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

;;; git

(define (repo-files-at path commit dir)
  (run/strings (git -C ,path ls-tree --name-only ,commit ,dir)))

(define (count-matching-files files irx)
  (count (lambda (file) (irregex-search irx file)) files))

(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 path)
  (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 @ -- ,path)))))

(define (repo-rev-list-loop proc repo-path from to path)
  (let loop ((date (copy-date to))
             (revs (repo-rev-list repo-path from to path)))
    (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 "melpa")

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

(define (archive-count-for db 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 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)
        ;; 20120405-20120121: recipes were stored as one sexp in pkglist
        (with-transaction db
          (lambda ()
            (repo-rev-list-loop
             (lambda (date rev)
               (let ((date-label (time->string date "%Y-%m-%d"))
                     (commit (cdr rev)))
                 (when (not (archive-count-for db date-label))
                   (let* ((contents (repo-file-at repo-path commit "pkglist"))
                          (count (pkglist-count contents)))
                     (insert-archive-count! db date-label count)
                     (printf "~a ~a: ~a\n" date-label archive count)))))
             repo-path
             (string->time "2012-01-21" "%Y-%m-%d")
             (string->time "2012-04-05" "%Y-%m-%d")
             "pkglist")
            'commit))

        ;; now-20120406: recipes/*
        (with-transaction db
          (lambda ()
            (repo-rev-list-loop
             (lambda (date rev)
               (let ((date-label (time->string date "%Y-%m-%d"))
                     (commit (cdr rev)))
                 (when (not (archive-count-for db date-label))
                   (let* ((files (repo-files-at repo-path commit "recipes/"))
                          (count (count-matching-files files "recipes/[^.]")))
                     (insert-archive-count! db date-label count)
                     (printf "~a ~a: ~a\n" date-label archive count)))))
             repo-path
             (string->time "2012-04-06" "%Y-%m-%d")
             (seconds->utc-time)
             "recipes/")
            'commit)))))
   (_
    (fprintf stderr "usage: ~a <melpa.git> <db>\n" (program-name))
    (exit 1))))

(apply main (command-line-arguments))

)