Index: /websites/scheme-users.jp/planet/planet.scm
===================================================================
--- /websites/scheme-users.jp/planet/planet.scm (revision 51)
+++ /websites/scheme-users.jp/planet/planet.scm (revision 51)
@@ -0,0 +1,156 @@
+(use srfi-19)
+(use rfc.http)
+(use sxml.ssax)
+(use sxml.sxpath)
+(use sxml.serializer)
+(use text.html-lite)
+(use text.tree)
+
+(define bloggers '(
+	("higepon" "http://d.hatena.ne.jp/higepon/" hatena-rss "d.hatena.ne.jp" "/higepon/searchdiary?word=scheme&mode=rss")
+	("g000001" "http://cadr.g.hatena.ne.jp/g000001/" hatena-rss2 "cadr.g.hatena.ne.jp" "/g000001/rss2")
+	))
+
+(define month-name->number (lambda (str)
+	(let ((month-name '("Jan" "Feb" "Mar" "Apr" "May"
+			"Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
+		(let loop ((count 1) (ls month-name))
+			(if (pair? ls)
+				(if (string=? str (car ls))
+					count
+					(loop (+ count 1) (cdr ls)))
+				0)))))
+
+(define rss-dc-date->time (lambda (str)
+	(if (string? str)
+		(rxmatch-if
+			(rxmatch #/(\d+)-(\d+)-(\d+)T(\d+):(\d+):(\d+)/ str)
+			(#f y mo d h mi s)
+			(time->seconds
+				(date->time-utc
+					(make-date 0 (x->integer s) (x->integer mi)
+						(x->integer h) (x->integer d)
+						(x->integer mo) (x->integer y) 0)))
+			0)
+		0)))
+
+(define rss2pubdate->time (lambda (str)
+	(if (string? str)
+		(rxmatch-if
+			(rxmatch #/(\w+), (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) (\w+)/ str)
+			(#f w d mo y h mi s tz)
+			(time->seconds
+				(date->time-utc
+					(make-date 0 (x->integer s) (x->integer mi)
+						(x->integer h) (x->integer d)
+						(month-name->number mo) (x->integer y) 0)))
+			0)
+		0)))
+
+(define parse-hatena-rss (lambda (in author blog-url)
+	(let ((sxml (ssax:xml->sxml in
+			'((rss . "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/")))))
+		(map
+			(lambda (item)
+				(list
+					(cons 'author author)
+					(cons 'blog-url blog-url)
+					(cons 'title
+						(let ((fi (find (lambda (i) (and (pair? i) (eq? 'rss:title (car i)))) item)))
+							(if (pair? fi) (cadr fi) fi)))
+					(cons 'time
+						(let ((fi (find (lambda (i) (and (pair? i) (eq? 'dc:date (car i)))) item)))
+							(if (pair? fi) (rss-dc-date->time (cadr fi)) fi)))
+					(cons 'msg-url
+						(let ((fi (find (lambda (i) (and (pair? i) (eq? 'rss:link (car i)))) item)))
+							(if (pair? fi) (cadr fi) fi)))
+					(cons 'msg
+						(let ((fi (find (lambda (i) (and (pair? i) (eq? 'content:encoded (car i)))) item)))
+							(if (pair? fi) (cadr fi) fi)))))
+			((sxpath '(rdf:RDF rss:item)) sxml)))))
+
+(define parse-hatena-rss2 (lambda (in author blog-url)
+	(let ((sxml (ssax:xml->sxml in '())))
+		(map
+			(lambda (item)
+				(list
+					(cons 'author author)
+					(cons 'blog-url blog-url)
+					(cons 'title
+						(let ((fi (find (lambda (i) (and (pair? i) (eq? 'title (car i)))) item)))
+							(if (pair? fi) (cadr fi) fi)))
+					(cons 'time
+						(let ((fi (find (lambda (i) (and (pair? i) (eq? 'pubDate (car i)))) item)))
+							(if (pair? fi) (rss2pubdate->time (cadr fi)) fi)))
+					(cons 'msg-url
+						(let ((fi (find (lambda (i) (and (pair? i) (eq? 'link (car i)))) item)))
+							(if (pair? fi) (cadr fi) fi)))
+					(cons 'msg
+						(let ((fi (find (lambda (i) (and (pair? i) (eq? 'description (car i)))) item)))
+							(if (pair? fi) (cadr fi) fi)))))
+			((sxpath '(rss channel item)) sxml)))))
+
+(define get-blogs (lambda ()
+	(sort
+		(apply append
+			(map
+				(lambda (blog)
+					(apply
+						(lambda (author blog-url type host rss-path)
+							(call-with-values
+								(lambda () (http-get host rss-path))
+								(lambda (x y z)
+									(call-with-input-string z
+										(lambda (in)
+											(cond
+												((eq? type 'hatena-rss) (parse-hatena-rss in author blog-url))
+												((eq? type 'hatena-rss2) (parse-hatena-rss2 in author blog-url))
+												(else (write type) (display "*ERROR*") '())))))))
+						blog))
+				bloggers))
+		(lambda (o1 o2)
+			(if (and (pair? o1) (pair? o2))
+				(let ((p1 (assq 'time o1)) (p2 (assq 'time o2)))
+					(and p1 p2 (number? (cdr p1)) (number? (cdr p2)) (> (cdr p1) (cdr p2))))
+				#f)))))
+
+(define make-html (lambda (blogs)
+	(list "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" #\newline
+		(html-doctype :type :xhtml-1.1)
+		(html:html :xmlns "http://www.w3.org/1999/xhtml" :xml:lang "ja"
+			(html:head
+				(html:meta :http-equiv "Content-Type" :content "text/html; charset=UTF-8") #\newline
+				(html:meta :http-equiv "Content-Language" :content "ja") #\newline
+				(html:link :rel "shortcut icon" :href "/favicon.ico") #\newline
+				(html:link :rel "stylesheet" :href "planet.css" :type "text/css") #\newline
+				(html:title "Planet Scheme Japan - The Community Scheme Blog in Japan"))
+			(html:body
+				(html:p "(" (html:a :href "http://scheme-users.jp/" "scheme-users.jp") ")")
+				(html:h1 "Planet Scheme Japan")
+				(map
+					(lambda (blog)
+						(let ((author (let ((i (assq 'author blog))) (if i (cdr i) "????")))
+							(blog-url (let ((i (assq 'blog-url blog))) (if i (cdr i) #f)))
+							(title (let ((i (assq 'title blog))) (if i (cdr i) "????")))
+							(time (let ((i (assq 'time blog))) (if i (cdr i) "????")))
+							(msg-url (let ((i (assq 'msg-url blog))) (if i (cdr i) #f)))
+							(msg (let ((i (assq 'msg blog))) (if i (cdr i) "????"))))
+							(html:div :class "blog"
+								(html:div :class "blog-header"
+									(if msg-url (html:a :href msg-url title) title))
+								(html:div :class "blog-body" msg)
+								(html:div :class "blog-footer" "By : "
+									(html:span :class "author"
+										(if blog-url (html:a :href blog-url author) author)) " - "
+									(html:span :class "date"
+										(date->string (time-utc->date (seconds->time time)) "~Y/~m/~d ~H:~M."))))))
+					blogs))))))
+
+(define main (lambda (args)
+	(let* ((blogs (get-blogs)) (html-tree (make-html blogs)))
+		(call-with-output-file "index.html"
+			(lambda (out) (write-tree html-tree out))))
+	0))
Index: /websites/scheme-users.jp/planet/planet.css
===================================================================
--- /websites/scheme-users.jp/planet/planet.css (revision 51)
+++ /websites/scheme-users.jp/planet/planet.css (revision 51)
@@ -0,0 +1,9 @@
+body { margin:20px; padding:20px; background-color:white; color:black; }
+h1 { color:#00CCEE; }
+h2 { color:#00AACC; }
+h3 { color:#0088AA; }
+span.date { color:#004488; }
+div.blog { border:1px solid gray; margin:5px; padding:5px; }
+div.blog-header { border:1px solid gray; margin:5px; padding:5px; }
+div.blog-body { border:1px solid gray; margin:5px; padding:5px; }
+div.blog-footer { border:1px solid gray; margin:5px; padding:5px; }
Index: /websites/scheme-users.jp/index.scm
===================================================================
--- /websites/scheme-users.jp/index.scm (revision 51)
+++ /websites/scheme-users.jp/index.scm (revision 51)
@@ -0,0 +1,136 @@
+(use sxml.serializer)
+(define main (lambda (args)
+	(call-with-output-file "index.html"
+		(lambda (out)
+			(display "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" out)
+			(newline out)
+			(display "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\"" out)
+			(newline out)
+			(display "\t\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" out)
+			(newline out)
+			(srl:sxml->xml
+				`(html (@ (xmlns "http://www.w3.org/1999/xhtml") (xml:lang "ja"))
+					(head
+						(meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
+						(meta (@ (http-equiv "Content-Language") (content "ja")))
+						(link (@ (rel "shortcut icon") (href "favicon.ico") (type "image/x-icon")))
+						(link (@ (rel "stylesheet") (type "text/css") (href "index.css")))
+						(title "Scheme-users.jp - 日本の Scheme ユーザのためのハブサイト"))
+					(body
+						(p (@ (style "margin-left:0;")) "(" (a (@ (href "http://scheme-users.jp/")) "scheme-users.jp") ")")
+
+						(h1 "日本の Scheme ユーザのためのハブサイト")
+
+						(p (a (@ (href "http://conferences.yapcasia.org/ya2008/") (title "YAPC::Asia 2008 - May 15-16th in Tokyo, JAPAN")) "YAPC::Asia 2008")
+							" で " (a (@ (href "http://conferences.yapcasia.org/ya2008/user/780") (title "ユーザ情報: YAPC::Asia 2008 - May 15-16th in Tokyo, JAPAN")) "Michael Schwern")
+							" は「SEO に有効な独自ドメインを取って、もっと Perl 初心者が集まりやすい nice な Perl の情報を集めたサイトを作れ！」といったそうです。"
+							"そして「" (a (@ (href "http://perl-users.jp")) "Perl-users.jp - 日本のPerlユーザのためのハブサイト") "」ができました。")
+						(p "これは Scheme も同じではないのか？"
+							"そう思って scheme-users.jp ドメインを取り、ここに scheme-users.jp を開始します。"
+							"完全に perl-users.jp とか js-users.jp とか as-users.jp とかにインスパイアされています。"
+							"本当にありがとうございます。" "ノープランです。")
+
+						(h2 "ポリシー的な物")
+						(ul
+							(li "日本語とＳ式で語り合う。")
+							(li "このサイトの想定する利用者層は、超初心者から超上級者まで。")
+							(li "たとえば " (a (@ (href "http://www.r6rs.org/")) "R6RS")
+								" で、いきなり言語仕様が変更されたとしても、"
+								"しっかり初心者層にリーチし、最新のトレンドに近づけるように。")
+							(li "Users ってついてるけど、日本人は Users ってついてるものが好きだからという理由だけなので "
+								(a (@ (href "http://schemers.org/")) "schemers.org") " とか "
+								(a (@ (href "http://practical-scheme.net/wiliki/wiliki.cgi")) "WiLiKi")
+								" とかそういうのと競合になるとかスピンアウトしたとかそういうのではありません。"
+								"レイヤーが違います。"))
+
+						(h2 "Scheme NEWS")
+						(ul
+							(li (span (@ (class "date")) "2008/06/07(SAT)") " : 本日 6月7日(土) 午後8時より " (a (@ (href "http://www.lingr.com/room/gKpArxPn9wi")) "Lingr: COMMON LISP 部屋") " で " (a (@ (href "http://cadr.g.hatena.ne.jp/g000001/20080531/1212235511")) "第2回 突発性CL勉強会@Lingr 8時だョ!全員集合") " が開催されます。")
+							(li (span (@ (class "date")) "2008/06/04(WED)") " : " (a (@ (href "http://www.plt-scheme.org/")) "Plt Scheme") " の新バージョン 4.0 が " (a (@ (href "http://blog.plt-scheme.org/2008/06/plt-scheme-version-40-is-coming-soon.html")) "まもなくリリース") " されるようです。")
+							(li (span (@ (class "date")) "2008/06/03(TUE)") " : Scheme コミュニティのブログ集 " (a (@ (href "http://scheme-users.jp/planet/")) "Planet Scheme Japan") " を開始しました。" (span (@ (style "color:red;")) "(参加者募集中！)"))
+							(li (span (@ (class "date")) "2008/05/30(THU)") " : " "軽量プログラミング言語のイベント " (a (@ (href "http://ll.jus.or.jp/2008/")) "LL Future") " のチケットがローソンチケットにて発売開始しました。")
+							(li (span (@ (class "date")) "2008/05/28(WED)") " : " (a (@ (href "http://jp.youtube.com/")) "YouTube") " に " (a (@ (href "http://practical-scheme.net/wiliki/wiliki.cgi?Shiro")) "Shiro") " さんが " (a (@ (href "http://practical-scheme.net/gauche/index-j.html")) "Gauche") " について話す " (a (@ (href "http://www.youtube.com/watch?v=WEBOdWyGE3E")) "動画") " が公開されています。")
+							(li (span (@ (class "date")) "2008/05/27(TUE)") " : " "Open Tech Press に Scheme 関連記事「" (a (@ (href "http://opentechpress.jp/developer/08/05/27/024252.shtml")) "SCSH (Scheme Shell) スクリプト入門") "」が掲載されています。")
+							(li (span (@ (class "date")) "2008/05/25(SUN)") " : " "scheme-users.jp 開設しました。"))
+						(p (a (@ (href "http://ll.jus.or.jp/2008/")) (img (@ (src "./images/ll2008.jpg") (alt "LL Future 2008/08/30") (style "border:none;")))))
+
+						(h2 "Lisp/Scheme チャット")
+						(ul
+							(li (a (@ (href "irc://irc.freenode.net/#Lisp_Scheme")) "irc.freenode.net#Lisp_Scheme") " (UTF-8)"))
+
+						(h2 (a (@ (href "http://scheme-users.jp/planet/")) "Planet Scheme Japan"))
+						(p (a (@ (href "http://scheme.dk/planet/")) "Planet Scheme")
+							" の " (a (@ (href "http://scheme-users.jp/planet/")) "日本版")
+							" を作りたいと考えています。参加者募集中です！"
+							" Scheme について書いたブログならどなたでも参加できます。")
+						(ul
+							(li (a (@ (href "http://d.hatena.ne.jp/higepon/")) "ひげぽん OS とか作っちゃうか Mona-"))
+							(li (a (@ (href "http://cadr.g.hatena.ne.jp/g000001/")) "わだば Lisper になる")))
+
+						(h2 "日本でよく使われている処理系")
+						(ul
+							(li (a (@ (href "http://practical-scheme.net/gauche/index-j.html")) "Gauche"))
+							(li (a (@ (href "http://code.google.com/p/sigscheme/")) "SigScheme"))
+							(li (a (@ (href "http://www.plt-scheme.org/")) "Plt Scheme") " / " (a (@ (href "http://www.plt-scheme.org/software/drscheme/")) "DrScheme") " / " (a (@ (href "http://www.plt-scheme.org/software/mzscheme/")) "MzScheme"))
+							(li (a (@ (href "http://www.gnu.org/software/guile/")) "GNU Guile"))
+							(li (a (@ (href "http://www.gnu.org/software/mit-scheme/")) "MIT/GNU Scheme"))
+							(li (a (@ (href "http://code.google.com/p/mosh-scheme/")) "mosh") " : " (a (@ (href "http://d.hatena.ne.jp/higepon/")) "higepon") " 氏が新しく作りはじめた処理系。期待しましょう :-)"))
+
+						(h2 "初心者向け学習サイト")
+						(ul
+							(li (a (@ (href "http://www.shido.info/lisp/idx_scm.html")) "もうひとつの Scheme 入門"))
+							(li (a (@ (href "http://www.unixuser.org/~euske/doc/scm-sd7/")) "Scheme プログラミング入門"))
+							(li (a (@ (href "http://www1.ocn.ne.jp/~scheme/scheme-start.html")) "まったく初めての人のための Scheme"))
+							(li (a (@ (href "http://www.sampou.org/scheme/t-y-scheme/t-y-scheme.html")) "独習 Scheme 三週間"))
+							(li (a (@ (href "http://www.stdio.h.kyoto-u.ac.jp/~hioki/gairon-enshuu/SchemeNotes/scheme.html")) "Scheme への道")))
+
+						(h2 "定番サイト")
+						(ul
+							(li (a (@ (href "http://practical-scheme.net/")) "Practical Scheme"))
+							(li (a (@ (href "http://www.kahua.org/")) "Kahua Project"))
+							(li (a (@ (href "http://karetta.jp/book-cover/gauche-hacks")) "Gaucheプログラミング(立読み版)"))
+							(li (a (@ (href "http://schemers.org/")) "schemers.org"))
+							(li (a (@ (href "http://srfi.schemers.org/")) "SRFI - Scheme Requests for Implementation"))
+							(li (a (@ (href "http://www.r6rs.org/")) "R6RS.Org"))
+							(li (a (@ (href "http://swiss.csail.mit.edu/projects/scheme/")) "The Scheme Programming Language"))
+							(li (a (@ (href "http://www1.ocn.ne.jp/~scheme/")) "やっぱり Scheme だね"))
+							(li (a (@ (href "http://lambda.bugyo.tk/hatena/")) "はてなようせいとまなぶ Scheme の形式的意味論"))
+							(li (a (@ (href "http://lambda.bugyo.tk/hatena/r5rs.html")) "はてなようせいとまなぶ R5RS の表示的意味論"))
+							(li (a (@ (href "http://www.math.u-toyama.ac.jp/~iwao/Scheme/scheme.html")) "Algorithmic Language Scheme")))
+							;;(li (a (@ (href "http://t-code.org/scheme-aa.html")) "ポルナレフ"))
+
+						(h2 "その他の *-users.jp")
+						(ul
+							(li (a (@ (href "http://air-users.jp/")) "air-users.jp"))
+							(li (a (@ (href "http://arc-users.jp/")) "arc-users.jp"))
+							(li (a (@ (href "http://as-users.jp/")) "as-users.jp"))
+							(li (a (@ (href "http://awk-users.jp/")) "awk-users.jp"))
+							(li (a (@ (href "http://cakephp-users.jp/")) "cakephp-users.jp"))
+							(li (a (@ (href "http://emacs-users.jp/")) "emacs-users.jp"))
+							(li (a (@ (href "http://hauhau-users.jp/")) "hauhau-users.jp"))
+							(li (a (@ (href "http://haxe-users.jp/")) "haxe-users.jp"))
+							(li (a (@ (href "http://hsp-users.jp")) "hsp-users.jp"))
+							(li (a (@ (href "http://io-users.jp/")) "io-users.jp"))
+							(li (a (@ (href "http://js-users.jp/")) "js-users.jp"))
+							(li (a (@ (href "http://perl-users.jp/")) "perl-users.jp"))
+							(li (a (@ (href "http://php-users.jp/")) "php-users.jp"))
+							(li (a (@ (href "http://pyobjc-users.jp/")) "pyobjc-users.jp"))
+							(li (a (@ (href "http://python-users.jp/")) "python-users.jp"))
+							(li (a (@ (href "http://rails-users.jp/")) "rails-users.jp"))
+							(li (a (@ (href "http://ruby-users.jp/")) "ruby-users.jp"))
+							(li (a (@ (href "http://vim-users.jp/")) "vim-users.jp")))
+
+						(h3 "管理人")
+						(p "なにかあれば何らかの手段で "
+							"(string-append \"info\" \"@\" \"scheme-users.jp\")"
+							" まで連絡ください。")
+						(p "文章のライセンスは、特に明記が無い限り全て "
+							(abbr (@ (title "Creative Commons Attribution license")) "CC-by")
+							" でお願いします。")
+						(p "このページは "
+							(a (@ (href "http://practical-scheme.net/gauche/index-j.html")) "Gauche")
+							" の "
+							(a (@ (href "http://practical-scheme.net/gauche/man/gauche-refj_148.html")) "sxml.serializer")
+							" を使って生成しています。"
+							"リポジトリはそのうちどこかに置く予定です。")
+						)) out)))))
Index: /websites/scheme-users.jp/index.css
===================================================================
--- /websites/scheme-users.jp/index.css (revision 51)
+++ /websites/scheme-users.jp/index.css (revision 51)
@@ -0,0 +1,7 @@
+body { margin:20px; padding:20px; background-color:white; color:black; }
+h1 { color:#00CCEE; }
+h2 { color:#00AACC; }
+h2 a { color:#00AACC; text-decoration:none; }
+h3 { color:#0088AA; }
+p { margin-left:40px; }
+span.date { color:#004488; }