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

Revision 56, 5.6 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        ))
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
131                                (html:p (html:a :href "http://scheme-users.jp/"
132                                        (html:img :src "../images/top.png" :alt "scheme-users.jp" :style "border:none;")))
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))
Note: See TracBrowser for help on using the browser.