kabonky/feeds.scm

(import chicken scheme srfi-1 srfi-13 srfi-14)
(use rss html-parser srfi-19 http-client postgresql md5 message-digest
     anaphora uri-common general-utils matchable posix coops coops-utils
     args irregex sxml-transforms intarweb sxpath message-digest-bv
     srfi-18 log5scm numbers medea
     (prefix utf8 utf8:) (prefix utf8-srfi-13 utf8:)
     (only sort-combinators group/key) atom rfc3339)

(client-software
 '(("Mozilla/5.0" "44.0" "(X11; Linux x86_64; rv:44.0) Gecko/20100101")))

(define *program-config* (with-input-from-file "news.conf" read))

;; (use debug-utils box)
;; (breakpoint-accessor _)

(define-category debug)
(define-category info)
(define-category warn)
(define-category error)

(define-category debug+ (or debug info warn error))
(define-category info+ (or info warn error))
(define-category warn+ (or warn error))

(define-category fetch-feed)
(define-category fetch-media)
(define-category import)
(define-category rank)
(define-category update-article-view)

(define-output <standard-out
  (conc "[" (current-category) "] "
        "[" (date->string (current-date) "~D ~T") "]"
        (if (current-context) (conc (current-context) " - ") "")
        " - " (current-message)))

;; Making this a macro removes one spurious stack trace relative to a
;; function element.
(define-syntax log-error
  (syntax-rules ()
    ((_ exn)
     (log-error exn #f #f #f))
    ((_ exn str)
     (log-error exn str #f #f))
    ((_ exn str default)
     (log-error exn str default #f))
    ((_ exn str default call-chain)
     (let* ((_chain (if call-chain call-chain (get-call-chain)))
            (chain (with-output-to-string (lambda () (newline) (pp (drop-right _chain 2)))))
            (cpa condition-property-accessor)
            (exn-message (cpa 'exn 'message "(no message)"))
            (exn-location (cpa 'exn 'location "*ERROR LOCATION UNKNOWN*"))
            (exn-arguments (cpa 'exn 'arguments '()))
            (exn? (condition-predicate 'exn)))
       (log-for (error)
               (with-output-to-string
                 (lambda ()
                   (print (exn-location exn))
                   (print (exn-message exn))
                   (print (exn-arguments exn))
                   (print chain)
                   (when str (print str)))))
       default))))

;; if exception occurs ignore and return a indicator.
(define-syntax exn*
  (syntax-rules ()
    ((_ exp)
     (handle-exceptions
         exn
       'exception-occured
       exp))))

(define (md5-hash s) (message-digest-string (md5-primitive) s))
(define skip-log-condition (make-property-condition 'skip-log))
(define skip-log-condition-predicate (condition-predicate 'skip-log))

(define (string-atom-date->date s)
  (seconds->date
   (rfc3339->seconds
    (time->rfc3339
     (rfc3339->local-time
      (string->rfc3339 s))))))

;; A normalized string->date conversion to help out SRFI-19.
(define (string->date* s)
  ;; SRFI-19 can't handle string timezones so try to convert them to
  ;; numeric timezones.
  (handle-exceptions
      exn
      (begin (log-for (warn) (conc "broken string->date* for: " s))
             (signal skip-log-condition))
    (let* ((d* (let ((possible-time-zone (string-take-right s 3))
                     (timezone-maps '(("GMT" . "-0800")
                                      ("PDT" . "-0000")
                                      ("PST" . "-0000")
                                      (" UT" . " -0800")
                                      ("EDT" . "-0300")
                                      ("EST" . "-0300")
                                      ("CST" . "-0200")))
                     (timezone-offset-map '(("+0000" . "-0800")))
                     (possible-timezone-offset (string-take-right s 5))
                     (possible-non-english-day (string-take s 3))
                     ;; Dom, Seg, Ter, Qua, Qui, Sex, Sab
                     (non-english-day-maps '(("Ter" . "Tue")
                                             ("Qui" . "Thu")))
                     (s* (string-copy s)))
                 ;; MUST COME FIRST
                 (set! s*
                   (aif (assoc possible-timezone-offset timezone-offset-map equal?)
                        (++ (string-take s* (- (string-length s*) 5)) (cdr it))
                        s*))
                 (set! s*
                   (aif (assoc possible-time-zone timezone-maps equal?)
                        (++ (string-take s* (- (string-length s*) 3)) (cdr it))
                        s*))
                 (set! s*
                   (aif (assoc possible-non-english-day non-english-day-maps equal?)
                        (++ (cdr it) (string-drop s* 3))
                        s*))
                 s*))
           (d (handle-exceptions exn
                  (string->date d* "~a, ~d ~B ~Y ~H:~M:~S ~z")
                (string->date d* "~a, ~d ~b ~Y ~H:~M:~S ~z"))))

      (date-add-duration d (make-duration hours: (if (= (date-zone-offset d) 0)
                                                     0
                                                     (fx/ (date-zone-offset d) 3600)))))))

;; Make the current date compatible with the output of the
;; string->date* function.
(define (current-date*)
  (let ((date (current-date)))
    (string->date (conc (date-day date) " " (date-month date) " "
                        (date-year date) " -0000")
                  "~e ~m ~Y ~z")))

(define (strip-html html)
  (filter (cut irregex-search '(: (* whitespace) (+ (or alnum punct))) <>)
       (flatten
        (pre-post-order
         (html->sxml html)
         `((@ . ,(lambda x '()))
           (*default* . ,(lambda (tag . body) body))
           (*text* . ,(lambda (tag string) (or-default string? string ""))))))))

(define (strip-tags-from-sxml sxml)
  (utf8:string-trim-both
   (irregex-replace/all
    "\n\t"
    (apply
     conc
     (flatten
      (pre-post-order*
       sxml
       `((span . ,(lambda (tag body) (if (> (length body) 1) (cdr body) "")))
         (p . ,(lambda (tag body) (if (> (length body) 1) (cdr body) "")))
         (em . ,(lambda (tag body) body))
         (a . ,(lambda (tag body) (if (> (length body) 1) (cdr body) "")))
         (img . ,(lambda (tag body) '()))
         (*text* . ,(lambda (tag str) str))
         (*default* . ,(lambda (tag str) str))
         (*TOP* . ,(lambda (tag str) str))))))
    " ")))

(define-class <media-item> ()
  ((media-item accessor: media-item-media-item)
   (url)
   (type)
   (file-extension)))

(define-class <feed-item> ()
  ((feed-item accessor: feed-item-feed-item)
   (title)
   (guid)
   (link)
   (source accessor: feed-item-source)
   (medias accessor: feed-item-medias)
   (description)
   (author)
   (authors)
   (date)
   (tags accessor: feed-item-tags)))

(define-class <rss-feed-item> (<feed-item>))
(define-class <atom-feed-item> (<feed-item>))

(define-class <los-angeles-times-item> (<rss-feed-item>)
  ((source "Los Angeles Times")))
(define-class <new-york-times-item> (<rss-feed-item>)
  ((source "New York Times")))
(define-class <san-francisco-chronicle-item> (<rss-feed-item>)
  ((source "San Francisco Chronicle")))
(define-class <wall-street-journal-item> (<rss-feed-item>)
  ((source "San Francisco Chronicle")))
(define-class <hacker-news-item> (<rss-feed-item>)
  ((source "Hacker News")))
(define-class <lambda-the-ultimate-item> (<rss-feed-item>)
  ((source "Lambda the Ultimate")))
(define-class <planet-scheme-item> (<atom-feed-item>)
  ((source "Planet Scheme")))
(define-class <planet-haskell-item> (<atom-feed-item>)
  ((source "Planet Haskell")))
(define-class <fox-news-item> (<rss-feed-item>)
  ((source "Fox News")))
(define-class <xkcd-item> (<atom-feed-item>)
  ((source "XKCD")))
(define-class <christianity-today-item> (<rss-feed-item>)
  ((source "Christianity Today")))
(define-class <techcrunch-item> (<rss-feed-item>)
  ((source "TechCrunch")))
(define-class <engadget-item> (<rss-feed-item>)
  ((source "Engadget")))
(define-class <npr-item> (<rss-feed-item>)
  ((source "NPR")))
(define-class <eff-item> (<rss-feed-item>)
  ((source "EFF")))
(define-class <common-dreams-item> (<rss-feed-item>)
  ((source "Common Dreams")))
(define-class <raw-story-item> (<rss-feed-item>)
  ((source "Raw Story")))
(define-class <reddit-item> (<atom-feed-item>)
  ((source "Reddit")))
(define-class <think-progress-item> (<rss-feed-item>)
  ((source "Think Progress")))


(define-class <los-angeles-times-media-item> (<media-item>) ())
(define-class <new-york-times-media-item> (<media-item>) ())
(define-class <san-francisco-chronicle-media-item> (<media-item>) ())
(define-class <wall-street-journal-media-item> (<media-item>) ())
(define-class <hacker-news-media-item> (<media-item>) ())
(define-class <lambda-the-ultimate-media-item> (<media-item>) ())
(define-class <xkcd-media-item> (<media-item>) ())
(define-class <url-media-item> (<media-item>) ())
(define-class <png-media-item> (<media-item>) ())
(define-class <url-png-media-item> (<url-media-item> <png-media-item>) ())

(define-method (feed-item-title (feed-item <rss-feed-item>))
  (rss:item-title (feed-item-feed-item feed-item)))
(define-method (feed-item-title (feed-item <atom-feed-item>))
  (match (entry-title (feed-item-feed-item feed-item))
    ((atom:title ('@ ('type "text")) x) x)
    ((atom:title x) x)
    ((atom:title ('@ ('xml:lang "en-US")) x) x)
    ((atom:title ('@ ('xml:lang "en")) x) x)
    (x (error (conc "title type not supported: "
                    (entry-title (feed-item-feed-item feed-item)))))))
(define-method (feed-item-title (feed-item <hacker-news-item>))
  (alist-ref 'title (feed-item-feed-item feed-item)))

(define-method (feed-item-link (feed-item <rss-feed-item>))
  (rss:item-link (feed-item-feed-item feed-item)))
(define-method (feed-item-link (feed-item <atom-feed-item>))
  (let ((links (entry-links (feed-item-feed-item feed-item))))
    (if (null? links)
        (error "feed item has no link")
        (let rec ((sxml (car links)))
          (match sxml
            (('atom:link x) (rec x))
            (('@ x ...)
             (let ((href-list (filter identity (map rec x))))
               (if (null? href-list)
                   (error (conc "link not found: "
                                (entry-links (feed-item-feed-item feed-item))))
                   (car href-list))))
            (('href x) x)
            (_ #f))))))
(define-method (feed-item-link (feed-item <hacker-news-item>))
  (conc "https://news.ycombinator.com/item?id="
        (alist-ref 'id (feed-item-feed-item feed-item))))

(define-method (feed-item-guid (feed-item <rss-feed-item>))
  (alist-ref 'guid (rss:item-attributes (feed-item-feed-item feed-item))))
(define-method (feed-item-guid (feed-item <atom-feed-item>))
  (entry-id (feed-item-feed-item feed-item)))
(define-method (feed-item-guid (feed-item <los-angeles-times-item>))
  ;; TODO figure out a better GUID that won't clash with future
  ;; articles with the same title or articles with the same title from
  ;; a different source.
  (last (utf8:string-split (feed-item-link feed-item) "/")))
(define-method (feed-item-guid (feed-item <new-york-times-item>))
  (or (alist-ref 'guid (rss:item-attributes (feed-item-feed-item feed-item)))
      (rss:item-link (feed-item-feed-item feed-item))))
(define-method (feed-item-guid (feed-item <hacker-news-item>))
  (conc "hacker-news-" (alist-ref 'id (feed-item-feed-item feed-item))))
(define-method (feed-item-guid (feed-item <lambda-the-ultimate-item>))
  (rss:item-link (feed-item-feed-item feed-item)))
(define-method (feed-item-guid (feed-item <fox-news-item>))
  (or (alist-ref 'guid (rss:item-attributes (feed-item-feed-item feed-item)))
      (rss:item-link (feed-item-feed-item feed-item))))
(define-method (feed-item-guid (feed-item <christianity-today-item>))
  ;; TODO figure out a better GUID that won't clash with future
  ;; articles with the same title or articles with the same title from
  ;; a different source.
  (last (utf8:string-split (feed-item-link feed-item) "/")))
(define-method (feed-item-guid (feed-item <npr-item>))
  (apply
   conc
   (uri-path
    (uri-reference (rss:item-link (feed-item-feed-item feed-item))))))

(define-method (feed-item-description (feed-item <rss-feed-item>))
  (rss:item-description (feed-item-feed-item feed-item)))
(define-method (feed-item-description (feed-item <atom-feed-item>))
  (match (entry-content (feed-item-feed-item feed-item))
    (('atom:content ('@ ('type "html")) x)
     (let ((body (strip-html x)))
       (if (null? body)
           ""
           (car body))))
    (('atom:content ('@ ('type "text")) x) x)
    (_ "")))
(define-method (feed-item-description (feed-item <reddit-item>))
  "")
(define-method (feed-item-description (feed-item <new-york-times-item>))
  (or-default string?
              (cadr (html->sxml (rss:item-description (feed-item-feed-item feed-item))))
              ""))

(define-method (feed-item-description (feed-item <los-angeles-times-item>))
  (let ((d (rss:item-description (feed-item-feed-item feed-item))))
    (if (string? d)
        (utf8:string-trim-both (car (utf8:string-split d "\n")))
        "")))

(define-method (feed-item-description (feed-item <san-francisco-chronicle-item>))
  ;; Can contain nested <p> elements but doesn't have to so filter
  ;; them out.
  (let* ((d* (rss:item-description (feed-item-feed-item feed-item)))
         (d** (or d* ""))
         (d (strip-tags-from-sxml
             (html->sxml d**))))
    (cond ((and (string? d)
                (irregex-search "\\$\\(\"." d))
           "")
          ((string? d)
           (utf8:string-trim-both d))
          ((and (list? d) (not (null? d)) (not (null? (cdr d))))
           (utf8:string-trim-both (cadr d)))
          (else ""))))
(define-method (feed-item-description (feed-item <hacker-news-item>))
  "")
(define-method (feed-item-description (feed-item <lambda-the-ultimate-item>))
  (or-default string?
              (cadr (html->sxml (rss:item-description (feed-item-feed-item feed-item))))
              ""))
(define-method (feed-item-description (feed-item <fox-news-item>))
  (let ((d (rss:item-description (feed-item-feed-item feed-item))))
    (if d
        (if (string? d)
            (cadr (html->sxml d))
            "")
        "")))
(define-method (feed-item-description (feed-item <xkcd-item>))
  (let ((r ((sxpath '(// (img (@ src *text*))
                         // ((@ title *text*))))
            (html->sxml (summary-text
                         (entry-summary (feed-item-feed-item feed-item)))))))
    (if (null? r)
        ""
        (let ((r2 (car r)))
          (if (string? r2)
              r2
              "")))))
(define-method (feed-item-description (feed-item <christianity-today-item>))
  (strip-tags-from-sxml
   ((sxpath `(// (p (@ class ,(lambda (x y)
                                (if (not (null? x))
                                    (let ((class (cadar x)))
                                      (or (equal?  "text" class)
                                          (equal?  "deck" class)))
                                    #f))))))
    (html->sxml (rss:item-description (feed-item-feed-item feed-item))))))
(define-method (feed-item-description (feed-item <techcrunch-item>))
  (strip-tags-from-sxml
   (html->sxml (rss:item-description (feed-item-feed-item feed-item)))))
(define-method (feed-item-description (feed-item <engadget-item>))
  (strip-tags-from-sxml
   (html->sxml (rss:item-description (feed-item-feed-item feed-item)))))
(define-method (feed-item-description (feed-item <npr-item>))
  (strip-tags-from-sxml
   (html->sxml (rss:item-description (feed-item-feed-item feed-item)))))
(define-method (feed-item-description (feed-item <eff-item>))
  (apply conc (strip-html (rss:item-description (feed-item-feed-item feed-item)))))
(define-method (feed-item-description (feed-item <common-dreams-item>))
  (apply
   conc
   ((sxpath `(// (div (@ class ,(lambda (x y)
                                  (if (not (null? x))
                                      (let ((class (cadar x)))
                                        (string-contains
                                         class "field--type-text-with-summary")
                                        )
                                      #f))))
                 // p *text*))
    (html->sxml (rss:item-description (feed-item-feed-item feed-item))))))
(define-method (feed-item-description (feed-item <raw-story-item>))
  (apply conc (flatten (cdr (html->sxml
                             (rss:item-description (feed-item-feed-item feed-item)))))))
(define-method (feed-item-description (feed-item <think-progress-item>))
  (strip-tags-from-sxml
   (html->sxml (rss:item-description (feed-item-feed-item feed-item)))))

(define rgx:author-split (sre->irregex '(or " and " ", ") 'fast 'i))
(define-method (feed-item-author (feed-item <rss-feed-item>))
  (or (alist-ref 'dc:creator (rss:item-attributes (feed-item-feed-item feed-item)))
      ""))
(define-method (feed-item-author (feed-item <atom-feed-item>))
  ;; Kinda weird but not sure how to do it better.
  (string-intersperse
   (map author-name (entry-authors (feed-item-feed-item feed-item)))
   ","))
(define-method (feed-item-author (feed-item <reddit-item>))
  (cadr (string-split (author-name
                       (car (entry-authors (feed-item-feed-item feed-item)))) "/")))
(define-method (feed-item-author (feed-item <los-angeles-times-item>))
  (or (alist-ref 'author (rss:item-attributes (feed-item-feed-item feed-item)))
      (alist-ref 'dc:creator (rss:item-attributes (feed-item-feed-item feed-item)))
      ""))
(define-method (feed-item-author (feed-item <new-york-times-item>))
  (let ((author
         (or (alist-ref 'dc:creator
                        (rss:item-attributes (feed-item-feed-item feed-item)))
             (alist-ref 'author
                        (rss:item-attributes (feed-item-feed-item feed-item))))))
    (if (not (string? author))
        "New York Times"
        author)))
(define-method (feed-item-author (feed-item <san-francisco-chronicle-item>))
  (let ((a (alist-ref 'dc:creator
                      (rss:item-attributes (feed-item-feed-item feed-item)))))
    (if a (car (strip-html a)) "")))
(define-method (feed-item-author (feed-item <wall-street-journal-item>))
  "")
(define-method (feed-item-author (feed-item <hacker-news-item>))
  (alist-ref 'by (feed-item-feed-item feed-item)))
(define-method (feed-item-author (feed-item <lambda-the-ultimate-item>))
  "")
(define-method (feed-item-author (feed-item <fox-news-item>))
  (let ((author
         (or (alist-ref 'dc:creator
                        (rss:item-attributes (feed-item-feed-item feed-item)))
             (alist-ref 'author
                        (rss:item-attributes (feed-item-feed-item feed-item))))))
    (cond ((not (string? author)) "")
          ((string=? author "foxnewsonline@foxnews.com (Fox News Online) ")
           "")
          (else author))))
(define-method (feed-item-author (feed-item <christianity-today-item>))
  (let ((r (irregex-split
            ", guest writer"
            (or (alist-ref 'dc:creator
                           (rss:item-attributes (feed-item-feed-item feed-item)))
                (alist-ref 'author
                           (rss:item-attributes (feed-item-feed-item feed-item)))""))))
    (if (null? r)
        ""
        (car r))))
(define-method (feed-item-author (feed-item <eff-item>))
  (or (alist-ref 'dc:creator (rss:item-attributes (feed-item-feed-item feed-item)))
      ""))

(define-method (feed-item-authors (feed-item <atom-feed-item>))
  (map author-name (entry-authors (feed-item-feed-item feed-item))))
(define-method (feed-item-authors (feed-item <reddit-item>))
  (list
   (cadr (string-split (author-name
                        (car (entry-authors (feed-item-feed-item feed-item)))) "/"))))
(define-method (feed-item-authors (feed-item <rss-feed-item>))
  (list (feed-item-author feed-item)))
(define-method (feed-item-authors (feed-item <new-york-times-item>))
  (let ((author (feed-item-author feed-item)))
    (if author
        (map (lambda (s)
               (utf8:string-titlecase
                (utf8:string-trim-both
                 (cond ((string=? (utf8:string-downcase s) "first draft")
                        "The New York Times First Draft")
                       (else s)))))
             (flatten (map (cut irregex-split rgx:author-split <>)
              (irregex-split "By " author))))
        "New York Times")))
(define-method (feed-item-authors (feed-item <los-angeles-times-item>))
  (let ((author (feed-item-author feed-item)))
    (if author
        (if (equal? author "The Times editorial board")
            '("The Los Angeles Times editorial board")
            (irregex-split rgx:author-split author))
        (list "Los Angeles Times"))))
(define-method (feed-item-authors (feed-item <san-francisco-chronicle-item>))
  (let ((author (utf8:string-trim-both (feed-item-author feed-item))))
    (if author
        (flatten (map (cut irregex-split rgx:author-split <>)
                      (irregex-split "By " author)))
        (list ""))))
(define-method (feed-item-authors (feed-item <wall-street-journal-item>))
  (list ""))
(define-method (feed-item-authors (feed-item <hacker-news-item>))
  (list (feed-item-author feed-item)))
(define-method (feed-item-authors (feed-item <lambda-the-ultimate-item>))
  (list ""))
(define-method (feed-item-authors (feed-item <fox-news-item>))
  (list (feed-item-author feed-item)))
(define-method (feed-item-authors (feed-item <christianity-today-item>))
  (let ((author (feed-item-author feed-item)))
    (if author
        (irregex-split rgx:author-split author)
        (list ""))))
(define-method (feed-item-authors (feed-item <techcrunch-item>))
  (let ((author (feed-item-author feed-item)))
    (if author
        (irregex-split '(",") author)
        (list ""))))
(define-method (feed-item-authors (feed-item <engadget-item>))
  (let ((author (feed-item-author feed-item)))
    (if author
        (irregex-split rgx:author-split author)
        (list ""))))
(define-method (feed-item-authors (feed-item <eff-item>))
  (let ((author (feed-item-author feed-item)))
    (if author
        (irregex-split rgx:author-split author)
        (list ""))))

(define-method (feed-item-date (feed-item <rss-feed-item>))
  (string->date*
   (alist-ref 'pubDate (rss:item-attributes (feed-item-feed-item feed-item)))))
(define-method (feed-item-date (feed-item <atom-feed-item>))
  (let ((published (entry-published (feed-item-feed-item feed-item)))
        (updated (entry-updated (feed-item-feed-item feed-item))))
    (string-atom-date->date
     (if (and published (not (string=? published "")))
         published
         updated))))
(define-method (feed-item-date (feed-item <hacker-news-item>))
  (seconds->date (alist-ref 'time (feed-item-feed-item feed-item))))
(define-method (feed-item-date (feed-item <christianity-today-item>))
  (let ((d (alist-ref 'pubDate (rss:item-attributes (feed-item-feed-item feed-item)))))
    (if d (string->date* d) (current-date*))))

(define-method (media-item-type (media-item <media-item>)) 'jpg)
(define-method (media-item-type (media-item <xkcd-media-item>)) 'png)
(define-method (media-item-type (media-item <png-media-item>)) 'png)
(define-method (media-item-file-extension (media-item <media-item>)) "jpg")
(define-method (media-item-file-extension (media-item <xkcd-media-item>)) "png")
(define-method (media-item-file-extension (media-item <png-media-item>)) "png")
(define-method (media-item-relative-path (media-item <media-item>))
  (++ (message-digest-string (md5-primitive) (media-item-url media-item))
      "." (media-item-file-extension media-item)))
(define-method (media-item-filesystem-path (media-item <media-item>))
  (++ (filesystem-path-img-original) "/" (media-item-relative-path media-item)))

(define-method (media-item-url (media-item <media-item>))
  (rss:media-url (media-item-media-item media-item)))
(define-method (media-item-url (media-item <xkcd-media-item>))
  (let ((r ((sxpath '(// (img (@ src *text*))
                         // ((@ src *text*))))
            (html->sxml (summary-text (media-item-media-item media-item))))))
    (if (null? r)
        ""
        (let ((r2 (car r)))
          (if (string? r2)
              r2
              "")))))
(define-method (media-item-url (media-item <url-media-item>))
  (media-item-media-item media-item))

(define-method (print-object (item <feed-item>) #!optional (out (current-output-port)))
  (print "title: " (exn* (feed-item-title item)))
  (print "guid: " (exn* (feed-item-guid item)))
  (print "link: " (exn* (feed-item-link item)))
  (print "source: " (exn* (feed-item-source item)))
  (print "description: " (exn* (feed-item-description item)))
  (print "author: " (exn* (feed-item-author item)))
  (print "date: " (exn* (feed-item-date item)))
  (print "tags: " (exn* (feed-item-tags item))))

(define (rss-item-description-image-links rss-item)
  (let* ((links
          ((sxpath `(// (img (@ src *text*))
                        // ((@ src *text*))))
           (html->sxml (rss:item-description rss-item))))
         (useful-links (filter
                        (lambda (link)
                          (or (irregex-search ".jpg" link)
                              (irregex-search ".png" link)))
                        links)))
    useful-links))

(define (make-feed-item feed-item source tags type)
  (match source
    ("New York Times"
     (make <new-york-times-item>
       'feed-item feed-item 'source source 'tags tags
       'medias (map (lambda (i) (make <new-york-times-media-item>
                             'media-item i))
                    (rss:item-medias feed-item))))
    ("Los Angeles Times"
     (make <los-angeles-times-item>
       'feed-item feed-item 'source source 'tags tags
       'medias (map (lambda (i) (make <los-angeles-times-media-item>
                             'media-item i))
                    (rss:item-medias feed-item))))
    ("San Francisco Chronicle"
     (make <san-francisco-chronicle-item>
       'feed-item feed-item 'source source 'tags tags
       'medias (map (lambda (i) (make <san-francisco-chronicle-media-item>
                             'media-item i))
                    (rss:item-medias feed-item))))
    ("Wall Street Journal"
     (make <wall-street-journal-item>
       'feed-item feed-item 'source source 'tags tags
       'medias (map (lambda (i) (make <wall-street-journal-media-item>
                             'media-item i))
                    (rss:item-medias feed-item))))
    ("Hacker News"
     (make <hacker-news-item>
       'feed-item feed-item 'source source 'tags tags
       'medias '()))
    ("Lambda the Ultimate"
     (make <lambda-the-ultimate-item>
       'feed-item feed-item 'source source 'tags tags
       'medias '()))
    ("Planet Scheme"
     (make <planet-scheme-item>
       'feed-item feed-item 'source source 'tags tags 'medias '()))
    ("Planet Haskell"
     (make <planet-haskell-item>
       'feed-item feed-item 'source source 'tags tags 'medias '()))
    ("Fox News"
     (make <fox-news-item>
       'feed-item feed-item 'source source 'tags tags
       'medias (map (lambda (i) (make <media-item>
                             'media-item i))
                    (filter
                     (lambda (i) (rss:media? i))
                     (rss:item-medias feed-item)))))
    ("XKCD"
     (make <xkcd-item>
       'feed-item feed-item 'source source 'tags tags
       'medias `(,(make <xkcd-media-item> 'media-item (entry-summary feed-item)))))
    ("Christianity Today"
     (make <christianity-today-item>
       'feed-item feed-item 'source source 'tags tags
       'medias (map (lambda (link)
                      (make <url-media-item> 'media-item link))
                    (rss-item-description-image-links feed-item))))
    ("TechCrunch"
     (make <techcrunch-item>
       'feed-item feed-item 'source source 'tags tags
       'medias (map (lambda (link)
                      (make <url-media-item> 'media-item link))
                    (rss-item-description-image-links feed-item))))
    ("Engadget"
     (make <engadget-item>
       'feed-item feed-item 'source source 'tags tags
       'medias (map (lambda (link)
                      (make <url-png-media-item> 'media-item link))
                    (rss-item-description-image-links feed-item))))
    ("NPR"
     (make <npr-item>
       'feed-item feed-item 'source source 'tags tags
       'medias '()))
    ("EFF"
     (make <eff-item>
       'feed-item feed-item 'source source 'tags tags
       'medias '()))
    ("Common Dreams"
     (make <common-dreams-item>
       'feed-item feed-item 'source source 'tags tags
       'medias '()))
    ("Raw Story"
     (make <raw-story-item>
       'feed-item feed-item 'source source 'tags tags
       'medias '()))
    ("Reddit"
     (make <reddit-item>
       'feed-item feed-item 'source source 'tags tags
       'medias '()))
    ("Think Progress"
     (make <think-progress-item>
       'feed-item feed-item 'source source 'tags tags
       'medias '()))
    (_
     (case type
       ('rss
        (make <rss-feed-item>
          'feed-item feed-item 'source source 'tags tags 'medias '()))
       ('atom
        (make <atom-feed-item>
          'feed-item feed-item 'source source 'tags tags 'medias '()))
       (else (error "feed item type unknown"))))))

(include "global.scm")

(include "db.scm")
(import (prefix news-db db:))
(define with-db db:with-db)
(define with-db/transaction db:with-db/transaction)
(db:connection-spec (alist-ref 'db-connection-spec *program-config*))

(define *hacker-news-base-uri* "https://hacker-news.firebaseio.com/v0/")
(define *hacker-news-top-stories-uri* "topstories")
(define *hacker-news-item-uri* "item/")
(define *hacker-news-uri-suffix* ".json")

(define (guid->guid-hash guid)
  (message-digest-string (md5-primitive) guid))

(define (article-id-by-guid conn guid)
  (let ((r (db:get-article-id-by-guid conn (guid->guid-hash guid))))
    (if (> (row-count r) 0)
        (value-at r)
        #f)))

(define *sources* (with-input-from-file "feed-list.scm" read))

(define-class <feed-resource> ()
  ((content-type reader: feed-resource-content-type)
   (tags reader: feed-resource-tags)))
(define-class <uri-feed-resource> (<feed-resource>)
  ((uri reader: feed-resource-uri)))
(define-class <xml-feed-resource> (<feed-resource>)
  ((content-type initform: "xml" reader: feed-resource-content-type)))
(define-class <hacker-news-feed-resource> (<feed-resource>)
  ((content-type initform: "json" reader: feed-resource-content-type)
   (tags initform: '(hacker-news) reader: feed-resource-tags)))
(define-class <xml-uri-feed-resource> (<uri-feed-resource> <xml-feed-resource>))

(define-class <feed> ()
  ((name reader: feed-name)
   (resources reader: feed-resources)))
(define-class <atom-feed> (<feed>))
(define-class <rss-feed> (<feed>))
(define-class <json-feed> (<feed>))
(define-class <new-york-times-feed> (<rss-feed>))
(define-class <los-angeles-times-feed> (<rss-feed>))
(define-class <san-francisco-chronicle-feed> (<rss-feed>))
(define-class <wall-street-journal-feed> (<rss-feed>))
(define-class <hacker-news-feed> (<json-feed>))
(define-class <fox-news-feed> (<rss-feed>))
(define-class <christianity-today-feed> (<rss-feed>))
(define-class <techcrunch-feed> (<rss-feed>))
(define-class <engadget-feed> (<rss-feed>))
(define-class <npr-feed> (<rss-feed>))
(define-class <common-dreams-feed> (<rss-feed>))
(define-class <raw-story-feed> (<rss-feed>))
(define-class <reddit-feed> (<atom-feed>))

(define-class <chronological-order-ranking-feed> (<feed>))
(define-class <rss-chronological-order-ranking-feed>
  (<rss-feed> <chronological-order-ranking-feed>))
(define-class <atom-chronological-order-ranking-feed>
  (<atom-feed> <chronological-order-ranking-feed>))

(define-method (feed-resource-root-filepath
                (feed <feed>) (feed-resource <feed-resource>))
  (conc "feed-" (feed-resource-content-type feed-resource) "/"
        (string-intersperse (string-split (feed-name feed) "/") "-") "/"))

(define-method (feed-resource-filepath (feed <feed>) (resource <uri-feed-resource>))
  (conc (feed-resource-root-filepath feed resource)
        (md5-hash (feed-resource-uri resource)) "."
        (feed-resource-content-type resource)))

(define-method (fetch-feed-resource (resource <uri-feed-resource>))
  (with-input-from-request (feed-resource-uri resource) #f read-string))

(define-method (save-feed-resource-content (feed <feed>) (resource <uri-feed-resource>))
  (create-directory (feed-resource-root-filepath feed resource))
  (with-output-to-file (feed-resource-filepath feed resource)
    (lambda ()
      (write (fetch-feed-resource resource)))))

(define-method (fetch-feed-and-write-to-file (feed <feed>))
  (for-each
   (lambda (resource)
     (log-for (info) (conc "fetching: " (feed-name feed) " "
                           (feed-resource-tags resource)))
     (handle-exceptions exn
       (log-error exn)
       (save-feed-resource-content feed resource)))
   (feed-resources feed)))

(define-method (fetch-feed-and-write-to-file (feed <hacker-news-feed>))
  (let ((ids (fetch-hacker-news-top-stories-ids)))
    (write-hacker-news-items-to-file ids "top-stories-ids.json")
    (write-hacker-news-items-to-file (fetch-hacker-news-items ids) "top-stories.json")))

(define *mutex* (make-mutex 'foo))
(define-method (read-feed-resource-from-file
                (feed <feed>) (resource <uri-feed-resource>))
  (with-input-from-file (feed-resource-filepath feed resource) read))

(define (feed-xml->rss-items xml)
  (with-input-from-string xml
    (lambda ()
      (rss:feed-items (rss:read (current-input-port))))))

(define (feed-xml->atom-items xml)
  (with-input-from-string xml
    (lambda ()
      (feed-entries (read-atom-feed (current-input-port))))))

(define-method (feed-resource-items (feed <atom-feed>) (resource <feed-resource>))
  (feed-xml->atom-items (read-feed-resource-from-file feed resource)))

(define-method (feed-resource-items (feed <rss-feed>) (resource <feed-resource>))
  (feed-xml->rss-items (read-feed-resource-from-file feed resource)))

(define-method (feed-resource-items
                (feed <hacker-news-feed>) (resource <hacker-news-feed-resource>))
  (hacker-news-json-items->feed-items "top-stories.json"))

(define (handle-possible-ssax-parser-error exn _chain tags source)
  (let ((chain (drop-right _chain 1)))
    (if (and ((condition-predicate 'ssax) exn)
             ((condition-predicate 'parser-error) exn))
        (begin
          (log-for (warn) (conc "ssax parser error: "
                                ((condition-property-accessor 'exn 'message) exn)
                                " for: " source " - " tags))
          '())
        (log-error exn (with-output-to-string
                         (lambda ()
                           (newline) (newline)
                           (pp (condition->list exn))
                           (newline) (newline)))
                   '() chain))))

(define-method (feed-resource-feed-items (feed <rss-feed>) (resource <feed-resource>))
  (map
   (lambda (i) (make-feed-item i (feed-name feed) (feed-resource-tags resource) 'rss))
   (handle-exceptions
       exn
     (handle-possible-ssax-parser-error
      exn (get-call-chain) (feed-resource-tags resource) (feed-name feed))
     (dynamic-wind
       (lambda () (mutex-lock! *mutex*))
       (lambda () (feed-xml->rss-items (read-feed-resource-from-file feed resource)))
       (lambda () (mutex-unlock! *mutex*))))))

(define-method (feed-resource-feed-items (feed <atom-feed>) (resource <feed-resource>))
  (map
   (lambda (i) (make-feed-item i (feed-name feed) (feed-resource-tags resource) 'atom))
   (handle-exceptions
       exn
     (handle-possible-ssax-parser-error
      exn (get-call-chain) (feed-resource-tags resource) (feed-name feed))
     (dynamic-wind
       (lambda () (mutex-lock! *mutex*))
       (lambda () (feed-xml->atom-items (read-feed-resource-from-file feed resource)))
       (lambda () (mutex-unlock! *mutex*))))))

(define-method (feed-resource-feed-items
                (feed <hacker-news-feed>) (resource <hacker-news-feed-resource>))
  (handle-exceptions exn
    (log-error exn)
    (feed-resource-items feed resource)))

(define (fetch-and-save-image uri filepath)
  (if (uri-reference uri)
      (condition-case
        (call-with-input-request*
         uri
         #f
         (lambda (p response)
           (with-output-to-file filepath
             (lambda ()
               ;; In CHICKEN strings are the same as binary and the
               ;; most efficient way to do things.
               (let ((len (header-value 'content-length
                                        (response-headers response))))
                 (write-string (read-string len p) len))))))
        (exn (exn client-error)
             (log-error exn ((condition-property-accessor 'exn 'message "nill") exn)))
        (exn () (log-error exn)))
      (log-for (warn) (conc "unable to get a URI reference from " uri))))

(define (save-feed-images-to-files feed-items)
  (for-each
   (lambda (item)
     (for-each
      (lambda (media-item)
        (handle-exceptions exn
          (log-error exn)
          (fetch-and-save-image (media-item-url media-item)
                                (media-item-filesystem-path media-item))))
      (filter (lambda (i) (media-item-url i)) (feed-item-medias item))))
   feed-items))

(define-method (save-feed-resource-images (feed <feed>) (resource <feed-resource>))
  (handle-exceptions exn
    (log-error exn)
    (save-feed-images-to-files
     (with-db
      (lambda (conn)
        (log-for (info) (conc "saving images from: " (feed-name feed) " "
                              (feed-resource-tags resource)))
        (filter (lambda (item)
                  (not (article-id-by-guid conn (feed-item-guid item))))
                (handle-exceptions exn
                  (log-error exn '())
                  (feed-resource-feed-items feed resource))))))))

(define-method (save-feed-images (feed <feed>))
  (for-each
   (lambda (resource)
     (save-feed-resource-images feed resource))
   (feed-resources feed)))

;; hacker news

(define array-as-list-parser
  (cons 'array (lambda (x) x)))

(json-parsers (cons array-as-list-parser (json-parsers)))

(define (fetch-from-hacker-news uri)
  (with-input-from-request uri #f read-json))

(define (fetch-hacker-news-top-stories-ids #!key (limit 30))
  (log-for (info) "fetching: Hacker News top stories")
  (handle-exceptions exn
    (log-error exn '())
    (let ((r (fetch-from-hacker-news
              (conc *hacker-news-base-uri* *hacker-news-top-stories-uri*
                    *hacker-news-uri-suffix*))))
      (if limit (take r limit) r))))

(define (fetch-hacker-news-item id)
  (fetch-from-hacker-news
   (conc *hacker-news-base-uri* *hacker-news-item-uri* id *hacker-news-uri-suffix*)))

(define (hacker-news-root-filepath)
  "feed-json/hacker-news/")

(define (fetch-hacker-news-items ids)
  (let* ((mutex (make-mutex))
         (items '())
         (threads (map (lambda (id)
                         (make-thread
                          (lambda ()
                            (log-for (info) (conc "fetching: Hacker News item " id))
                            (handle-exceptions exn
                              (log-error exn)
                              (let ((r (fetch-hacker-news-item id)))
                                (mutex-lock! mutex)
                                (set! items (cons r items))
                                (mutex-unlock! mutex))))))
                       ids)))
    (for-each (lambda (thread) (thread-start! thread)) threads)
    (for-each (lambda (thread) (thread-join! thread)) threads)
    items))

(define (write-hacker-news-items-to-file items path)
  (create-directory (hacker-news-root-filepath) #t)
  (with-output-to-file (conc (hacker-news-root-filepath) path)
    (lambda () (write items))))

(define (read-hacker-news-items-from-file path)
  (with-input-from-file (conc (hacker-news-root-filepath) path) read))

(define (hacker-news-json-items->feed-items path)
  (map (lambda (item) (make-feed-item item "Hacker News" '(hacker-news) 'hacker-news))
       (read-hacker-news-items-from-file path)))


(define (make-feed src)
  (define (make-feed* feed-type resource-type src)
    (make feed-type
      'resources (map
                  (lambda (tags/uri)
                    (make resource-type
                      'tags (car tags/uri)
                      'uri  (cdr tags/uri)))
                  (source-uris src))
      'name (source-name src)))
  (cond ((equal? (source-name src) "New York Times")
         (make-feed* <new-york-times-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "Los Angeles Times")
         (make-feed* <los-angeles-times-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "Wall Street Journal")
         (make-feed* <wall-street-journal-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "San Francisco Chronicle")
         (make-feed* <san-francisco-chronicle-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "Hacker News")
         (make <hacker-news-feed> 'resources
               `(,(make <hacker-news-feed-resource>))
               'name "Hacker News"))
        ((equal? (source-name src) "Fox News")
         (make-feed* <fox-news-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "Christianity Today")
         (make-feed* <christianity-today-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "TechCrunch")
         (make-feed* <techcrunch-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "Engadget")
         (make-feed* <engadget-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "NPR")
         (make-feed* <npr-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "Common Dreams")
         (make-feed* <common-dreams-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "Raw Story")
         (make-feed* <raw-story-feed> <xml-uri-feed-resource> src))
        ((equal? (source-name src) "Reddit")
         (make-feed* <reddit-feed> <xml-uri-feed-resource> src))
        ((eq? (source-type src) 'rss-chronological)
         (make-feed*
          <rss-chronological-order-ranking-feed> <xml-uri-feed-resource> src))
        ((eq? (source-type src) 'atom-chronological)
         (make-feed*
          <atom-chronological-order-ranking-feed> <xml-uri-feed-resource> src))
        ((eq? (source-type src) 'rss)
         (make-feed* <rss-feed> <xml-uri-feed-resource> src))
        ((eq? (source-type src) 'atom)
         (make-feed* <atom-feed> <xml-uri-feed-resource> src))
        (else (error "source type not supported"))))

;;; RANK ;;;
(define-method (rank-feed (feed <new-york-times-feed>))
  (with-db
   (lambda (conn)
     (let ((name (feed-name feed)))
       ;; demote current elevated ranks
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       ;; order matters. primary outranks secondary.
       (with-transaction conn
         (lambda ()
           (db:set-rank-by-tag-association
            conn name "ny-times-rank-secondary" 2 40)))
       (with-transaction conn
         (lambda ()
           (db:set-rank-by-tag-association
            conn name "ny-times-rank-primary" 1 3)))))))

(define-method (rank-feed (feed <los-angeles-times-feed>))
  (let ((name (feed-name feed)))
    (with-db
     (lambda (conn)
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       (let ((sxml
              (cdr
               (with-input-from-string
                   (with-input-from-request "http://latimes.com" #f read-string)
                 html->sxml)))
             (uri-root "http://www.latimes.com"))
         ;; secondary articles
         (let ((secondary-uri-list
                ((sxpath '(// (section (@ class
                                         (equal?
                                          "trb_outfit_group trb_outfit_section")))
                              // ((@ data-content-url *text*))))
                 sxml)))
           (unless (null? secondary-uri-list)
             (with-transaction conn
               (lambda ()
                 (db:set-rank-by-partial-uri
                  conn name
                  (map (lambda (u) (last (utf8:string-split u "/"))) secondary-uri-list)
                  2)))))
         ;; featured article
         (let ((featured-uri-list
                ((sxpath '(// (section (@ data-outfit-type (equal? "centerpiece")))
                              (section
                               (@ class
                                 (equal? "trb_outfit_primaryItem trb_outfit_section")))
                              ((@ data-content-url *text*))))
                 sxml)))
           (unless (null? featured-uri-list)
             (with-transaction conn
               (lambda ()
                 (db:set-rank-by-partial-uri
                  conn name
                  (map (lambda (u) (last (utf8:string-split u "/"))) featured-uri-list)
                  1))))))))))

(define-method (rank-feed (feed <wall-street-journal-feed>))
  (with-db
   (lambda (conn)
     (let ((name (feed-name feed)))
       ;; demote current elevated ranks
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       ;; order matters. primary outranks secondary.
       (with-transaction conn
         (lambda ()
           (db:set-rank-by-tag-association
            conn name "wsj-rank-secondary" 2 40)))
       (with-transaction conn
         (lambda ()
           (db:set-rank-by-tag-association
            conn name "wsj-rank-primary" 1 3)))))))

(define-method (rank-feed (feed <hacker-news-feed>))
  (define (hn-guid id) (guid->guid-hash (conc "hacker-news-" id)))
  (let ((name (feed-name feed)))
    (with-db
     (lambda (conn)
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 3 4 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       (let ((items (read-hacker-news-items-from-file "top-stories-ids.json")))
         (with-transaction conn
           (lambda ()
             (db:set-rank-by-guids
              conn 1 (map-in-order hn-guid (take items 3)))
             (db:set-rank-by-guids
              conn 2 (map-in-order hn-guid (take (drop items 3) 3))))))))))

(define-method (rank-feed (feed <san-francisco-chronicle-feed>))
  (let ((name (feed-name feed)))
    (with-db
     (lambda (conn)
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       (let* ((doc (cdr
                    (with-input-from-string
                        (with-input-from-request "http://sfgate.com" #f read-string)
                      html->sxml)))
              (path-proc
               (lambda (base)
                 (lambda (name)
                   ((sxpath `(// (div (@ (equal? (class ,(string-append base " " name)))))
                                 // a
                                 ((@ href *text*)))) doc)))))
         (with-transaction conn
           (lambda ()
             (db:set-rank-by-partial-uri
              conn name
              ((sxpath '(// (div (@ class (equal? "ctpl-centerpiece")))
                            // a
                            ((@ href *text*))))
               doc)
              1)))
         (db:set-rank-by-partial-uri
          conn name
          (map
           car
           (group/key
            identity
            (flatten
             (append
              (map (path-proc "package")
                   '("news" "sports" "business" "food" "realestate" "entertainment"))
              (map (path-proc "headline-list")
                   '("news" "business" "national" "living"))))))
          2))))))

(define-method (rank-feed (feed <chronological-order-ranking-feed>))
  (let ((name (feed-name feed)))
    (with-db
     (lambda (conn)
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       (with-transaction conn
         (lambda ()
           (db:set-rank-by-date-difference
            conn 2 (make-duration hours: 8) name 3 3)
           (db:set-rank-by-date-difference
            conn 1 (make-duration hours: 4) name 3 0)))))))

(define-method (rank-feed (feed <fox-news-feed>))
  (with-db
   (lambda (conn)
     (let ((name (feed-name feed)))
       ;; demote current elevated ranks
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       (with-transaction conn
         (lambda ()
           (db:set-rank-by-tag-association
            conn name "fox-news-rank-primary" 1 3)
           (db:set-rank-by-tag-association
            conn name "fox-news-rank-primary" 2 40 offset: 3)))))))

(define-method (rank-feed (feed <christianity-today-feed>))
  (with-db
   (lambda (conn)
     (let ((name (feed-name feed)))
       ;; demote current elevated ranks
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       (with-transaction conn
         (lambda ()
           (db:set-rank-by-tag-association
            conn name "christianity-today-rank-primary" 1 3)
           (db:set-rank-by-tag-association
            conn name "christianity-today-rank-primary" 2 40 offset: 3)))))))

(define-method (rank-feed (feed <techcrunch-feed>))
  (let ((name (feed-name feed)))
    (with-db
     (lambda (conn)
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       (let ((sxml
              (cdr
               (with-input-from-string
                   (with-input-from-request "http://techcrunch.com/" #f read-string)
                 html->sxml))))
         ;; secondary articles
         (let ((secondary-uri-list
                ((sxpath '(// (div (@ class
                                     (equal?
                                      "island-main")))
                              // a
                              // ((@ href *text*))))
                 sxml)))
           (unless (null? secondary-uri-list)
             (with-transaction conn
               (lambda ()
                 (db:set-rank-by-partial-uri
                  conn name
                  (map (lambda (u) (last (utf8:string-split u "/"))) secondary-uri-list)
                  2)))))
         ;; featured article
         (let ((featured-uri-list
                ((sxpath '(// (div (@ class
                                     (equal?
                                      "island-secondary")))
                              // a
                              // ((@ href *text*))))
                 sxml)))
           (unless (null? featured-uri-list)
             (with-transaction conn
               (lambda ()
                 (db:set-rank-by-partial-uri
                  conn name
                  (map (lambda (u) (last (utf8:string-split u "/"))) featured-uri-list)
                  1))))))))))

(define-method (rank-feed (feed <engadget-feed>))
  (let ((name (feed-name feed)))
    (with-db
     (lambda (conn)
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 3 4 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 2 1000)))
       (let ((sxml
              (cdr
               (with-input-from-string
                   (with-input-from-request "http://www.engadget.com/" #f read-string)
                 html->sxml))))
         ;; featured articles
         (let ((featured-uri-list
                ((sxpath '(// (li (@ class
                                     (equal?
                                      "lede-item post")))
                              // a
                              // ((@ href *text*))))
                 sxml)))
           (unless (null? featured-uri-list)
             (with-transaction conn
               (lambda ()
                 (db:set-rank-by-partial-uri
                  conn name
                  (map (lambda (u) (last (utf8:string-split u "/"))) featured-uri-list)
                  1))))))))))

(define-method (rank-feed (feed <npr-feed>))
  (with-db
   (lambda (conn)
     (let ((name (feed-name feed)))
       ;; demote current elevated ranks
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 4 1000)))
       (with-transaction conn
         (lambda ()
           (db:set-rank-by-tag-association
            conn name "npr-rank-primary" 1 3)
           (db:set-rank-by-tag-association
            conn name "npr-rank-primary" 2 40 offset: 3)))))))

(define-method (rank-feed (feed <common-dreams-feed>))
  (let ((name (feed-name feed)))
    (with-db
     (lambda (conn)
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 3 4 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 2 1000)))

       (let ((sxml
              (cdr
               (with-input-from-string
                   (with-input-from-request
                       "http://www.commondreams.org/" #f read-string)
                 html->sxml))))
         (for-each
          (match-lambda
            ((rank uris)
             (for-each
              (lambda (uri)
                (with-transaction conn
                  (lambda ()
                    (db:set-rank-by-uri
                     conn name
                     (string-append "http://www.commondreams.org" uri)
                     rank))))
              uris)))
          (map (match-lambda
                 ((rank article-class)
                  `(,rank
                    ,((sxpath `(// (div (@ class
                                          ,(lambda (x y)
                                             (if (not (null? x))
                                                 (let ((class (cadar x)))
                                                   (string-contains class article-class))
                                                 #f))))
                                   // (div (@ class
                                             ,(lambda (x y)
                                                (if (not (null? x))
                                                    (let ((class (cadar x)))
                                                      (string-contains class "hp-title"))
                                                    #f))))
                                   // (div (@ class (equal? "field-content")))
                                   // a
                                   // ((@ href *text*))))
                      sxml))))
               '((1 "primary-news-article") (1 "secondary-news-article")
                 (2 "tertiary-news-article") (2 "remaining-news-article")))))))))

(define-method (rank-feed (feed <raw-story-feed>))
  (let ((name (feed-name feed)))
    (with-db
     (lambda (conn)
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 3 4 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 2 1000)))
       (let ((sxml
              (cdr
               (with-input-from-string
                   (with-input-from-request "http://www.rawstory.com/" #f read-string)
                 html->sxml))))

         (let ((uri-list
                ((sxpath `(// (div (@ class
                                     ,(lambda (x y)
                                        (if (not (null? x))
                                            (let ((class (cadar x)))
                                              (string-contains class "blog-item-class"))
                                            #f))))
                              // a
                              // ((@ href *text*))))
                 sxml)))
           (unless (null? uri-list)
             (for-each
              (match-lambda
                ((rank uris)
                 (with-transaction conn
                   (lambda ()
                     (for-each
                      (lambda (uri)
                        (db:set-rank-by-uri conn name uri rank))
                      uris)))))
              `((1 ,(take uri-list 3))
                (2 ,(drop uri-list 3)))))))))))

(define-method (rank-feed (feed <reddit-feed>))
  (let ((name (feed-name feed)))
    (with-db
     (lambda (conn)
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 3 4 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 2 3 1000)))
       (with-transaction conn (lambda () (db:set-rank-by-rank conn name 1 2 1000)))


       (let ((items (feed-resource-feed-items feed (first (feed-resources feed)))))
         (with-transaction conn
           (lambda ()
             (db:set-rank-by-guids
              conn 1 (map-in-order (compose guid->guid-hash feed-item-guid)
                                   (take items 3)))
             (db:set-rank-by-guids
              conn 2 (map-in-order (compose guid->guid-hash feed-item-guid)
                                   (take (drop items 3) 3))))))))))


;; TEXT TAGS ;;
(define (set-text-tags)
  (with-db
   (lambda (conn)
     (for-each
      (lambda (tag/texts)
        (with-transaction
         conn
         (lambda ()
           (db:set-tags-by-text conn (cdr tag/texts) (car tag/texts)))))
      '(("religion" "religion" "religious" "theology" "doctrine")
        ("bernie-sanders" "bernie sanders" "sanders bernie")
        ("hillary-clinton" "hillary clinton" "clinton hillary")
        ("jeb-bush" "jeb bush" "bush jeb")
        ("ted-cruz" "ted cruz" "cruz ted")
        ("rand-paul" "rand paul" "paul rand")
        ("donald-trump" "donald trump" "trump donald" "donald j trump")
        ("ben-carson" "ben carson" "carson ben")
        ("chris-christie" "christie chris")
        ("carly-fiorina" "carly fiorina" "fiorina carly")
        ("mike-huckabee" "mike huckabee" "huckabee mike")
        ("marco-rubio" "marco rubio" "rubio marco")
        ("president-2016"
         "president 2016"
         "2016 president"
         "presidential 2016"
         "2016 presidential"
         "presidential campaign 2016"
         "Presidential campaign 2016"
         "presidential election 2016"
         "Presidential election 2016"
         "2016 presidential poll"
         "presidential poll 2016"
         "presidential candidate"
         "Presidential candidate"
         "bernie sanders"
         "sanders bernie"
         "hillary clinton"
         "clinton hillary"
         "jeb bush"
         "bush jeb"
         "ted cruz"
         "cruz ted"
         "rand paul"
         "paul rand"
         "donald trump"
         "trump donald"
         "donald j trump"
         "ben carson"
         "carson ben"
         "christie chris"
         "carly fiorina"
         "fiorina carly"
         "mike huckabee"
         "huckabee mike"
         "marco rubio"
         "rubio marco")
        ("terrorism" "terrorism" "terrorist")
        ("isis" "isis" "isil" "islamic state" "islamic-state")
        ("climate-change" "climate change" "global warming" "greenhouse gas"
         "fossile fuel" "fossile fuels" "clean energy" "cap and trade" "cap-and-trade"
         "offshore drilling" "carbon tax" "renewables"))))))

;; IMPORT ;;
(define (get-image-dimensions path)
  (map
   string->number
   (string-split
    (let ((s (with-input-from-pipe
                 (string-append "identify -format \"%w,%h\" " path) read-string)))
      (if (string-null? s)
          (signal (make-property-condition 'invalid-image-format))
          s))
    ",")))

(define (date-in-future? date)
  ;; There has to be a better way to do this...
  ;; just using the srfi-19 date comparison procedures doesn't work
  ;; since it can't seem to handle dates that have different timezones.
  ;; (> (time->seconds (date->time date)) (time->seconds (date->time (current-date))))
  (> (time-compare (date->time date) (date->time (current-date))) -1))

(define (save-feed-items-to-database source tag items)
  (with-db
   (lambda (conn)
     (for-each
      (lambda (a)
        (handle-exceptions
            exn
          (let* ((_chain (get-call-chain))
                 (chain (drop-right _chain 2)))
            (cond ((and ((condition-property-accessor 'query 'error-code "nill") exn)
                        (string=?
                         ((condition-property-accessor 'query 'error-code "nill") exn)
                         "23505")) ; unique violation, it should be ok...
                   (log-for (warn) (with-output-to-string
                                     (lambda ()
                                       (print "unique violation")
                                       (print-object a)))))
                  ((skip-log-condition-predicate exn) (void))
                  (else
                   (log-error exn (with-output-to-string
                                    (lambda () (print-object a))) #f chain))))
          (let* ((article-id (article-id-by-guid conn (feed-item-guid a)))
                 (images (if article-id
                             '()
                             (let ((first-item #t))
                               (filter
                                identity
                                (map (lambda (media-item)
                                       (handle-exceptions exn
                                         (let* ((_chain (get-call-chain))
                                                (chain (drop-right _chain 1)))
                                           (if ((condition-predicate
                                                 'invalid-image-format) exn)
                                               (begin
                                                 (log-for (warn)
                                                          "invalid image format")
                                                 #f)
                                               (log-error
                                                exn
                                                (with-output-to-string
                                                  (lambda ()
                                                    (print-object a)))
                                                #f)))
                                         (let* ((url (media-item-url media-item))
                                                (path
                                                 (media-item-relative-path media-item))
                                                (full-path
                                                 (media-item-filesystem-path media-item))
                                                (file-exists (file-exists? full-path))
                                                (dimen (if file-exists
                                                           (get-image-dimensions full-path)
                                                           #f)))
                                           (if file-exists
                                               `((cover
                                                  . ,(if first-item
                                                         (begin (set! first-item #f) #t)
                                                         #f))
                                                 (original-path . ,path)
                                                 (original-width . ,(car dimen))
                                                 (original-height . ,(cadr dimen)))
                                               (begin (log-for
                                                       (warn)
                                                       (conc "image does not exist: "
                                                             full-path))
                                                      #f)))))
                                     (filter (lambda (i) (media-item-url i))
                                             (feed-item-medias a))))))))
            (if (date-in-future? (feed-item-date a))
                (log-for (warn) (with-output-to-string
                                  (lambda ()
                                    (print "date in the future: "
                                           (exn* (feed-item-date a)))
                                    (print "tags: " (exn* (feed-item-tags a)))
                                    (print "link: " (exn* (feed-item-link a))))))
                (with-transaction conn
                  (lambda ()
                    (db:upsert-article!
                     conn
                     title: (feed-item-title a)
                     author: (feed-item-author a)
                     authors: (feed-item-authors a)
                     ;; TODO handle errors
                     date: (feed-item-date a)
                     ;; TODO based on feed
                     tags: (map ->string (feed-item-tags a))
                     ;; TODO error handle
                     description: (feed-item-description a)
                     content: ""
                     guid-hash: (guid->guid-hash (feed-item-guid a))
                     article-id: article-id
                     source: (feed-item-source a)
                     uri: (feed-item-link a)
                     images: images
                     insert-tag-if-not-exists: #t)))))))
      (filter (lambda (item)
                (unless (feed-item-title item)
                  (log-for (info) (conc "missing item title: " source tag)))
                (feed-item-title item)) items)))))

(define-method (import-feed-resource (feed <feed>) (resource <feed-resource>))
  (handle-exceptions exn
    (log-error exn)
    (save-feed-items-to-database
     (feed-name feed) (feed-resource-tags resource)
     (feed-resource-feed-items feed resource))))

(define-method (import-feed (feed <feed>))
  (for-each
   (lambda (resource)
     (log-for (info) (conc "importing feed: " (feed-name feed) " - "
                           (feed-resource-tags resource)))
     (import-feed-resource feed resource))
   (feed-resources feed)))

(define opts
  (list (args:make-option (f fetch-feeds) #:none "fetch and save feeds")
        (args:make-option (m fetch-media) #:none "fetch and save media objects")
        (args:make-option (i import) #:none "import into database")
        (args:make-option (u update-article-view) #:none "update article view")
        (args:make-option (r rank) #:none "rank articles")
        (args:make-option (t set-text-tags) #:none "set text tags")
        (args:make-option (d debug-level) (optional: "LEVEL")
                          "debug level [default: 1]")
        (args:make-option (h help) #:none "display usage" (usage))))

(define (usage)
  (with-output-to-port (current-error-port)
    (lambda ()
      (print "Usage: " (car (argv)) " [options...]")
      (newline)
      (print (args:usage opts))))
  (exit 1))

(define (source-name source) (car source))
(define (source-type source) (cadr source))
(define (source-uris source) (cddr source))

(receive
    (options operands) (args:parse (command-line-arguments) opts)

  (let ((debug-level (or (and (alist-ref 'debug-level options)
                              (string->number (alist-ref 'debug-level options)))
                         1)))
    (when (> debug-level 0)
      (start-sender error-sender
                      (port-sender (current-error-port))
                      (output (<standard-out message))
                      (category error))
      (when (>= debug-level 2)
        (start-sender warn-sender
                      (port-sender (current-output-port))
                      (output (<standard-out message))
                      (category warn)))
      (when (>= debug-level 3)
        (start-sender info-sender
                      (port-sender (current-output-port))
                      (output (<standard-out message))
                      (category info)))
      (when (= debug-level 4)
        (start-sender debug-sender
                      (port-sender (current-output-port))
                      (output (<standard-out message))
                      (category debug)))))

  (let* ((force (null? (filter (lambda (a)
                                 (and (not (equal? (car a) 'd))
                                      (not (equal? (car a) 'debug-level))))
                               options)))
         (tasks (map (lambda (src) `(,(source-name src) . ,(make-queue))) *sources*))
         (task-add!
          (lambda (src proc)
            (let ((src-queue (alist-ref (source-name src) tasks)))
              (when src-queue
                (queue-add! src-queue proc))))))

    (print "options:")
    (when (or force (alist-ref 'f options))
      (print " fetch feeds")
      (for-each
       (lambda (src)
         (task-add! src
                    (lambda ()
                      (fetch-feed-and-write-to-file (make-feed src)))))
       *sources*))

    (when (or force (alist-ref 'm options))
      (print " fetch media")
      (for-each
       (lambda (src)
         (task-add!
          src
          (lambda ()
            (save-feed-images (make-feed src)))))
       *sources*))

    (when (or force (alist-ref 'i options))
      (print " import articles")
      (for-each
       (lambda (src)
         (task-add!
          src
          (lambda ()
            (import-feed (make-feed src)))))
       *sources*))

    (when (or force (alist-ref 'r options))
      (print " rank articles")
      (for-each
       (lambda (src)
         (task-add! src (lambda () (handle-exceptions exn
                                (log-error exn)
                                (let ((feed (make-feed src)))
                                  (log-for (info) (conc "ranking " (feed-name feed)))
                                  (rank-feed feed))))))
       *sources*))

    (when (or force (alist-ref 't options))
      (print " set text tags"))

    (when (or force (alist-ref 'u options))
      (print " refresh article view"))
    (newline)

    (log-for (info) "running tasks")
    (let ((threads (map
                    (lambda (task)
                      (make-thread
                       (lambda ()
                         (for-each
                          (lambda (e)
                            (e))
                          (queue->list (cdr task))))))
                    tasks)))
      (for-each (cut thread-start! <>) threads)
      (for-each (cut thread-join! <>) threads))
    (log-for (info) "completed tasks")

    (when (or force (alist-ref 't options))
      (log-for (info) "setting text tags")
      (set-text-tags))

    (when (or force (alist-ref 'u options))
      (log-for (info) "refreshing views...")
      (with-db
       (lambda (conn)
         (db:refresh-article-view! conn)
         (db:refresh-tags-and-sources-view! conn))))

    (log-for (info) "done")))