2010-12-06

フィードを表示するWiLiKiのリーダーマクロ

オプション引数の処理がad hocなのは仕様です。

(use gauche.charconv)
(use srfi-1)
(use srfi-13)
(use srfi-19)
(use rfc.822)
(use rfc.http)
(use rfc.uri)
(use sxml.ssax)
(use sxml.sxpath)
(use sxml.tools)
(use util.list)

(define-reader-macro (feed url . args)
  (define *item-max* 10)
  (define *date-format* "~Y/~m/~d")
  (define *item-format* "(~a) ~a")
  (define *ns*
    '((atom . "http://www.w3.org/2005/Atom")
      (openSearch . "http://a9.com/-/spec/opensearchrss/1.0/")
      (georss . "http://www.georss.org/georss")
      (thr . "http://purl.org/syndication/thread/1.0")
      (rss1 . "http://purl.org/rss/1.0/")
      (rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
      (content . "http://purl.org/rss/1.0/modules/content/")
      (dc . "http://purl.org/dc/elements/1.1/")
      (foo . "bar")))
  (define (w3cdtf->date str)
    (define (df->nano df)
      (string->number (string-pad-right (number->string df) 9 #\0)))
    (and-let*
        ((match (#/^(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:T(\d\d):(\d\d)(?::(\d\d)(?:\.(\d+))?)?(?:Z|([+-]\d\d):(\d\d)))?)?)?$/ str)))
      (receive (year month day hour minute second df zh zm)
          (apply values (map (lambda (i) (x->integer (match i))) (iota 9 1)))
        (make-date (df->nano df)
                   second minute hour day month year
                   (* (if (negative? zh) -1 1)
                      (+ (* (abs zh) 3600) (* zm 60)))))))
  (define *feed-attributes*
    `((atom 
       (converter
        ,(sxpath '(// atom:entry atom:title *text*))
        ,(sxpath '(// atom:entry
                   (atom:link (@ (equal? (rel "alternate"))))
                   @ href *text*))
        ,(sxpath '(// atom:entry atom:published *text*)))
       (date-parser . ,w3cdtf->date))
      (rss1
       (converter
        ,(sxpath '(// rss1:item rss1:title *text*))
        ,(sxpath '(// rss1:item rss1:link *text*))
        ,(sxpath '(// rss1:item dc:date *text*)))
       (date-parser . ,w3cdtf->date))
      (rss2
       (converter
        ,(sxpath '(// item title *text*))
        ,(sxpath '(// item link *text*))
        ,(sxpath '(// item pubDate *text*)))
       (date-parser . ,rfc822-date->date))))
  (define (feed-attr type field)
    (cdr (assoc field (cdr (assoc type *feed-attributes*)))))
  (define (decompose-uri url)
    (receive (_ specific) (uri-scheme&specific url)
      (uri-decompose-hierarchical specific)))
  (define (authority&path?query url)
    (define (path?query path query)
      (with-output-to-string
        (lambda ()
          (display path)
          (when query (format #t "?~a" query)))))
    (receive (authority path query _) (decompose-uri url)
      (values authority (path?query path query))))
  (define (feed-get url)
    (receive (authority path?query) (authority&path?query url)
      (receive (status header body) (http-get authority path?query)
        (unless (equal? status "200")
          (error "フィードの読み込みに失敗しました。ステータスコードは~aです。"
                 status))
        (if (or (null? args) (null? (cdr args)))
            body
            (ces-convert body (cadr args))))))
  (define (feed->sxml feed)
    (with-input-from-string feed
      (cut ssax:xml->sxml (current-input-port) *ns*)))
  (define (feed-type-of sxml)
    (define root-node ((car-sxpath '(*)) sxml))
    (define (rss1?)
      (eq? (sxml:name root-node) 'rdf:RDF))
    (define (rss2?)
      (and (eq? (sxml:name root-node) 'rss)
           (equal? (sxml:attr root-node 'version) "2.0")))
    (define (atom?)
      (eq? (sxml:name root-node) 'atom:feed))
    (cond ((rss1?) 'rss1)
          ((rss2?) 'rss2)
          ((atom?) 'atom)
          (else (error "対応していない種類のフィードです。"))))
  (define converter-title car)
  (define converter-link cadr)
  (define converter-date caddr)
  (define (take-item-max nodes)
    (let1 n (if (null? args) *item-max* (car args))
      (take* nodes n)))
  (let* ((feed (feed->sxml (feed-get url)))
         (type (feed-type-of feed))
         (conv (feed-attr type 'converter))
         (proc (feed-attr type 'date-parser))
         (title (converter-title conv))
         (link (converter-link conv))
         (date (converter-date conv)))
    `((ul ,@(map (lambda (title link date)
                   `(li (a (@ (href ,link))
                           ,(format #f *item-format*
                                    (date->string (proc date) *date-format*)
                                    title))))
                 (take-item-max (title feed))
                 (take-item-max (link feed))
                 (take-item-max (date feed)))))))

0 件のコメント: