(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))