(module db-feeds-to-atom ()

(import scheme)
(import (chicken base))
(import (chicken condition))
(import (chicken format))
(import (chicken process-context))
(import (chicken string))
(import (chicken tcp))
(import (chicken time))
(import (srfi 1))
(import atom)
(import http-client)
(import matchable)
(import openssl)
(import rfc3339)
(import sql-de-lite)
(import sxml-serializer)
(import uri-common)

(define ssl-verify? (make-parameter #t))
(client-software '(("Mozilla" "5.0" "compatible; +https://elpa.brause.cc")))

;; adapted from http-client.scm
(define (http-server-connector uri proxy)
  (let ((remote-end (or proxy uri)))
    (case (uri-scheme remote-end)
      ((#f http) (tcp-connect (uri-host remote-end) (uri-port remote-end)))
      ((https) (ssl-connect* hostname: (uri-host remote-end)
                             port: (uri-port remote-end)
                             sni-name: #t
                             verify?: (ssl-verify?)))
      (else (error "This shouldn't happen")))))

(server-connector http-server-connector)

(define (fetch-archive-contents archive meta)
  (let* ((meta-data (alist-ref archive meta))
         (contents (alist-ref 'archive-contents meta-data)))
    (condition-case (with-input-from-request contents #f read)
      ((exn i/o net) #f))))

(define (package-permalink package archive meta)
  (let* ((meta-data (alist-ref archive meta))
         (permalink (alist-ref 'permalink meta-data)))
    (format permalink package)))

(define (archive-home-page archive meta)
  (let ((meta-data (alist-ref archive meta)))
    (alist-ref 'home-page meta-data)))

(define (archive-title archive meta)
  (let ((meta-data (alist-ref archive meta)))
    (alist-ref 'title meta-data)))

(define (string-prefix? prefix string)
  (let ((index (substring-index prefix string)))
    (and index (zero? index))))

(define (fixup-url url)
  (if (or (string-prefix? "http://" url)
          (string-prefix? "https://" url))
      url
      (string-append "http://" url)))

(define (archive-item->list archive-item)
  ;; FIXME this will bite me once negative numbers for version parts
  ;; come into use...
  (define (concat seq sep)
    (string-intersperse (map ->string seq) sep))
  (match-let* (((name version _ desc _ . rest) archive-item)
               (meta-data (match rest
                            (((_ . _)) (car rest))
                            (else '())))
               (url (alist-ref ':url meta-data))
               (url (and url (fixup-url url)))
               (keywords (alist-ref ':keywords meta-data)))
    (list (symbol->string name) (concat version ".") desc url
          (and keywords (not (null? keywords))
               (concat keywords ", ")))))

(define (transform-archive-contents archive-contents)
  (match-let (((_ . packages) archive-contents))
    (map archive-item->list packages)))

(define (fetch-known-packages db archive)
  (query fetch-column
         (sql db "SELECT name FROM packages WHERE archive = ?")
         (symbol->string archive)))

(define (insert-package! db archive name version desc url keywords added permalink)
  (exec (sql db "INSERT INTO packages(archive, name, version, desc, url, keywords, added, permalink)
                        VALUES(?, ?, ?, ?, ?, ?, ?, ?)")
        (symbol->string archive) name version desc
        (or url "") (or keywords "") added permalink))

(define (insert-packages! db archive archive-contents meta)
  (let* ((timestamp (current-seconds))
         (known-packages (fetch-known-packages db archive))
         (archive-packages (transform-archive-contents archive-contents))
         (unknown-packages (remove (lambda (package)
                                     (member (car package) known-packages))
                                   archive-packages)))
    (with-transaction db
      (lambda ()
        (for-each
         (match-lambda
          ((name version desc url keywords)
           (let ((permalink (package-permalink name archive meta)))
             (insert-package! db archive name version desc url
                              keywords timestamp permalink))))
         unknown-packages)))))

(define (updated-at packages)
  (match-let (((_ _ _ _ _ added _) (car packages)))
    added))

(define (latest-packages db archive limit)
  (query fetch-all
         (sql db "SELECT name, version, desc, url, keywords, added, permalink FROM packages WHERE archive = ? ORDER BY added DESC LIMIT ?")
         (symbol->string archive) limit))

(define (unix->datetime seconds)
  (rfc3339->string (seconds->rfc3339 seconds)))

(define (atom-feed-item name version desc url keywords)
  (serialize-sxml
   `(div
     "Name: " ,name (br)
     "Version: " ,version (br)
     "Description: " ,desc (br)
     "URL: " (a (@ (href ,url)) ,url) (br)
     "Keywords: " ,keywords (br))))

(define (atom-feed db archive file packages meta)
  (write-atom-doc
   (make-atom-doc
    (make-feed
     title: (make-title (format "~a Packages" (archive-title archive meta)))
     id: (format "https://elpa.brause.cc/~a" file)
     updated: (unix->datetime (updated-at packages))
     authors: (list (make-author name: (symbol->string archive)))
     links: (list (make-link uri: (archive-home-page archive meta)))
     entries: (map
               (match-lambda
                ((name version desc url keywords added permalink)
                 (make-entry
                  id: (format "~a:~a" archive permalink)
                  title: (make-title name)
                  updated: (unix->datetime added)
                  links: (list (make-link uri: permalink))
                  content: (make-content
                            (atom-feed-item name version desc url keywords)
                            type: 'html))))
               packages)))))

(define atom-limit 10)

(define (die message #!rest args)
  (apply fprintf (current-error-port) message args)
  (exit 1))

(define (main db-path meta-data-path archive outdir)
  (let ((archive (string->symbol archive))
        (elpa-meta-data (call-with-input-file meta-data-path read)))
    (when (not (alist-ref archive elpa-meta-data))
      (die "unknown archive: ~a\n" archive))
    (when (alist-ref 'disable-verification? (alist-ref archive elpa-meta-data))
      (ssl-verify? #f))
    (let ((archive-contents (fetch-archive-contents archive elpa-meta-data)))
      (when (not archive-contents)
        (die "failed to fetch packages for archive: ~a\n" archive))
      (call-with-database db-path
        (lambda (db)
          (insert-packages! db archive archive-contents elpa-meta-data)
          (let* ((packages (latest-packages db archive atom-limit))
                 (file (format "~a.xml" archive)))
            (with-output-to-file (format "~a/~a" outdir file)
              (lambda () (atom-feed db archive file packages elpa-meta-data)))))))))

(when (not (= (length (command-line-arguments)) 4))
  (die "usage: ~a <db> archives.sexp <archive-name> <outdir>\n" (program-name)))

(apply main (command-line-arguments))

)