[51] | 1 | (use srfi-19) |
---|
| 2 | (use rfc.http) |
---|
| 3 | (use sxml.ssax) |
---|
| 4 | (use sxml.sxpath) |
---|
| 5 | (use sxml.serializer) |
---|
| 6 | (use text.html-lite) |
---|
| 7 | (use text.tree) |
---|
| 8 | |
---|
| 9 | (define bloggers '( |
---|
| 10 | ("higepon" "http://d.hatena.ne.jp/higepon/" hatena-rss "d.hatena.ne.jp" "/higepon/searchdiary?word=scheme&mode=rss") |
---|
| 11 | ("g000001" "http://cadr.g.hatena.ne.jp/g000001/" hatena-rss2 "cadr.g.hatena.ne.jp" "/g000001/rss2") |
---|
| 12 | )) |
---|
| 13 | |
---|
| 14 | (define month-name->number (lambda (str) |
---|
| 15 | (let ((month-name '("Jan" "Feb" "Mar" "Apr" "May" |
---|
| 16 | "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))) |
---|
| 17 | (let loop ((count 1) (ls month-name)) |
---|
| 18 | (if (pair? ls) |
---|
| 19 | (if (string=? str (car ls)) |
---|
| 20 | count |
---|
| 21 | (loop (+ count 1) (cdr ls))) |
---|
| 22 | 0))))) |
---|
| 23 | |
---|
| 24 | (define rss-dc-date->time (lambda (str) |
---|
| 25 | (if (string? str) |
---|
| 26 | (rxmatch-if |
---|
| 27 | (rxmatch #/(\d+)-(\d+)-(\d+)T(\d+):(\d+):(\d+)/ str) |
---|
| 28 | (#f y mo d h mi s) |
---|
| 29 | (time->seconds |
---|
| 30 | (date->time-utc |
---|
| 31 | (make-date 0 (x->integer s) (x->integer mi) |
---|
| 32 | (x->integer h) (x->integer d) |
---|
| 33 | (x->integer mo) (x->integer y) 0))) |
---|
| 34 | 0) |
---|
| 35 | 0))) |
---|
| 36 | |
---|
| 37 | (define rss2pubdate->time (lambda (str) |
---|
| 38 | (if (string? str) |
---|
| 39 | (rxmatch-if |
---|
| 40 | (rxmatch #/(\w+), (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) (\w+)/ str) |
---|
| 41 | (#f w d mo y h mi s tz) |
---|
| 42 | (time->seconds |
---|
| 43 | (date->time-utc |
---|
| 44 | (make-date 0 (x->integer s) (x->integer mi) |
---|
| 45 | (x->integer h) (x->integer d) |
---|
| 46 | (month-name->number mo) (x->integer y) 0))) |
---|
| 47 | 0) |
---|
| 48 | 0))) |
---|
| 49 | |
---|
| 50 | (define parse-hatena-rss (lambda (in author blog-url) |
---|
| 51 | (let ((sxml (ssax:xml->sxml in |
---|
| 52 | '((rss . "http://purl.org/rss/1.0/") |
---|
| 53 | (rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#") |
---|
| 54 | (content . "http://purl.org/rss/1.0/modules/content/") |
---|
| 55 | (dc . "http://purl.org/dc/elements/1.1/"))))) |
---|
| 56 | (map |
---|
| 57 | (lambda (item) |
---|
| 58 | (list |
---|
| 59 | (cons 'author author) |
---|
| 60 | (cons 'blog-url blog-url) |
---|
| 61 | (cons 'title |
---|
| 62 | (let ((fi (find (lambda (i) (and (pair? i) (eq? 'rss:title (car i)))) item))) |
---|
| 63 | (if (pair? fi) (cadr fi) fi))) |
---|
| 64 | (cons 'time |
---|
| 65 | (let ((fi (find (lambda (i) (and (pair? i) (eq? 'dc:date (car i)))) item))) |
---|
| 66 | (if (pair? fi) (rss-dc-date->time (cadr fi)) fi))) |
---|
| 67 | (cons 'msg-url |
---|
| 68 | (let ((fi (find (lambda (i) (and (pair? i) (eq? 'rss:link (car i)))) item))) |
---|
| 69 | (if (pair? fi) (cadr fi) fi))) |
---|
| 70 | (cons 'msg |
---|
| 71 | (let ((fi (find (lambda (i) (and (pair? i) (eq? 'content:encoded (car i)))) item))) |
---|
| 72 | (if (pair? fi) (cadr fi) fi))))) |
---|
| 73 | ((sxpath '(rdf:RDF rss:item)) sxml))))) |
---|
| 74 | |
---|
| 75 | (define parse-hatena-rss2 (lambda (in author blog-url) |
---|
| 76 | (let ((sxml (ssax:xml->sxml in '()))) |
---|
| 77 | (map |
---|
| 78 | (lambda (item) |
---|
| 79 | (list |
---|
| 80 | (cons 'author author) |
---|
| 81 | (cons 'blog-url blog-url) |
---|
| 82 | (cons 'title |
---|
| 83 | (let ((fi (find (lambda (i) (and (pair? i) (eq? 'title (car i)))) item))) |
---|
| 84 | (if (pair? fi) (cadr fi) fi))) |
---|
| 85 | (cons 'time |
---|
| 86 | (let ((fi (find (lambda (i) (and (pair? i) (eq? 'pubDate (car i)))) item))) |
---|
| 87 | (if (pair? fi) (rss2pubdate->time (cadr fi)) fi))) |
---|
| 88 | (cons 'msg-url |
---|
| 89 | (let ((fi (find (lambda (i) (and (pair? i) (eq? 'link (car i)))) item))) |
---|
| 90 | (if (pair? fi) (cadr fi) fi))) |
---|
| 91 | (cons 'msg |
---|
| 92 | (let ((fi (find (lambda (i) (and (pair? i) (eq? 'description (car i)))) item))) |
---|
| 93 | (if (pair? fi) (cadr fi) fi))))) |
---|
| 94 | ((sxpath '(rss channel item)) sxml))))) |
---|
| 95 | |
---|
| 96 | (define get-blogs (lambda () |
---|
| 97 | (sort |
---|
| 98 | (apply append |
---|
| 99 | (map |
---|
| 100 | (lambda (blog) |
---|
| 101 | (apply |
---|
| 102 | (lambda (author blog-url type host rss-path) |
---|
| 103 | (call-with-values |
---|
| 104 | (lambda () (http-get host rss-path)) |
---|
| 105 | (lambda (x y z) |
---|
| 106 | (call-with-input-string z |
---|
| 107 | (lambda (in) |
---|
| 108 | (cond |
---|
| 109 | ((eq? type 'hatena-rss) (parse-hatena-rss in author blog-url)) |
---|
| 110 | ((eq? type 'hatena-rss2) (parse-hatena-rss2 in author blog-url)) |
---|
| 111 | (else (write type) (display "*ERROR*") '()))))))) |
---|
| 112 | blog)) |
---|
| 113 | bloggers)) |
---|
| 114 | (lambda (o1 o2) |
---|
| 115 | (if (and (pair? o1) (pair? o2)) |
---|
| 116 | (let ((p1 (assq 'time o1)) (p2 (assq 'time o2))) |
---|
| 117 | (and p1 p2 (number? (cdr p1)) (number? (cdr p2)) (> (cdr p1) (cdr p2)))) |
---|
| 118 | #f))))) |
---|
| 119 | |
---|
| 120 | (define make-html (lambda (blogs) |
---|
| 121 | (list "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" #\newline |
---|
| 122 | (html-doctype :type :xhtml-1.1) |
---|
| 123 | (html:html :xmlns "http://www.w3.org/1999/xhtml" :xml:lang "ja" |
---|
| 124 | (html:head |
---|
| 125 | (html:meta :http-equiv "Content-Type" :content "text/html; charset=UTF-8") #\newline |
---|
| 126 | (html:meta :http-equiv "Content-Language" :content "ja") #\newline |
---|
| 127 | (html:link :rel "shortcut icon" :href "/favicon.ico") #\newline |
---|
| 128 | (html:link :rel "stylesheet" :href "planet.css" :type "text/css") #\newline |
---|
| 129 | (html:title "Planet Scheme Japan - The Community Scheme Blog in Japan")) |
---|
| 130 | (html:body |
---|
[56] | 131 | (html:p (html:a :href "http://scheme-users.jp/" |
---|
| 132 | (html:img :src "../images/top.png" :alt "scheme-users.jp" :style "border:none;"))) |
---|
[51] | 133 | (html:h1 "Planet Scheme Japan") |
---|
| 134 | (map |
---|
| 135 | (lambda (blog) |
---|
| 136 | (let ((author (let ((i (assq 'author blog))) (if i (cdr i) "????"))) |
---|
| 137 | (blog-url (let ((i (assq 'blog-url blog))) (if i (cdr i) #f))) |
---|
| 138 | (title (let ((i (assq 'title blog))) (if i (cdr i) "????"))) |
---|
| 139 | (time (let ((i (assq 'time blog))) (if i (cdr i) "????"))) |
---|
| 140 | (msg-url (let ((i (assq 'msg-url blog))) (if i (cdr i) #f))) |
---|
| 141 | (msg (let ((i (assq 'msg blog))) (if i (cdr i) "????")))) |
---|
| 142 | (html:div :class "blog" |
---|
| 143 | (html:div :class "blog-header" |
---|
| 144 | (if msg-url (html:a :href msg-url title) title)) |
---|
| 145 | (html:div :class "blog-body" msg) |
---|
| 146 | (html:div :class "blog-footer" "By : " |
---|
| 147 | (html:span :class "author" |
---|
| 148 | (if blog-url (html:a :href blog-url author) author)) " - " |
---|
| 149 | (html:span :class "date" |
---|
| 150 | (date->string (time-utc->date (seconds->time time)) "~Y/~m/~d ~H:~M.")))))) |
---|
| 151 | blogs)))))) |
---|
| 152 | |
---|
| 153 | (define main (lambda (args) |
---|
| 154 | (let* ((blogs (get-blogs)) (html-tree (make-html blogs))) |
---|
| 155 | (call-with-output-file "index.html" |
---|
| 156 | (lambda (out) (write-tree html-tree out)))) |
---|
| 157 | 0)) |
---|