root/websites/scheme-users.jp/planet/planet.scm @ 97

Revision 64, 5.8 kB (checked in by baal5084, 16 years ago)

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