anything advent-calendar-2011 for #xyzzy

adcal.l

;;; -*- mode:lisp; package:adcal2011 -*-

;;; usage: M-x advent-calendar-2011

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "cmu_loop")
  (require "anything/anything")
  (require "xml-http-request"))

(defpackage :advent-calendar-2011
  (:nicknames :adcal2011)
  (:use :lisp :editor :anything))

(in-package :adcal2011)

;; https://github.com/mattn/unite-advent_calendar から拝借
(defvar *calendars*
  '((:type atnd :url "http://atnd.org/events/21936" :title "C++11 Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/20321" :title "bjam Advent Calendar jp 2011")
    (:type atnd :url "http://atnd.org/events/23108" :title "Visual Basic Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/21988" :title "C# Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22001" :title "Silverlight Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22434" :title "Java Advent Calendar 2011 ")
    (:type atnd :url "http://atnd.org/events/22247" :title "Play! framework Advent Calendar 2011 jp #play_ja")
    (:type atnd :url "http://atnd.org/events/21977" :title "JavaScript Advent Calendar 2011 (フレームワークコース)")
    (:type atnd :url "http://atnd.org/events/21979" :title "JavaScript Advent Calendar 2011 (Node.js/WebSocketsコース)")
    (:type atnd :url "http://atnd.org/events/21980" :title "JavaScript Advent Calendar 2011 (オレ標準コース)")
    (:type atnd :url "http://atnd.org/events/21978" :title "JavaScript Advent Calendar 2011 (WebGLコース)")
    (:type atnd :url "http://atnd.org/events/22017" :title "Backbone.js Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22837" :title "jQuery Mobile Addenpa Calendar 2011")
    (:type rss :url "http://perl-users.jp/articles/advent-calendar/2011/casual/rss" :title "Perl Advent Calendar Japan 2011 - Casual Track")
    (:type rss :url "http://perl-users.jp/articles/advent-calendar/2011/hacker/rss" :title "Perl Advent Calendar Japan 2011 - Hacker Track")
    (:type rss :url "http://perl-users.jp/articles/advent-calendar/2011/test/rss" :title "Perl Advent Calendar Japan 2011 - Test Track")
    (:type rss :url "http://perl-users.jp/articles/advent-calendar/2011/acme/rss" :title "Perl Advent Calendar Japan 2011 - Acme Trap")
    (:type rss :url "http://perl-users.jp/articles/advent-calendar/2011/english/rss" :title "Perl Advent Calendar Japan 2011 - English Track")
    (:type rss :url "http://perl-users.jp/articles/advent-calendar/2011/anysan/rss" :title "Perl Advent Calendar Japan 2011 - AnySan Track")
    (:type rss :url "http://perl-users.jp/articles/advent-calendar/2011/dbix/rss" :title "Perl Advent Calendar Japan 2011 - DBIx Track")
    (:type rss :url "http://perl-users.jp/articles/advent-calendar/2011/amon2/rss" :title "Perl Advent Calendar Japan 2011 - Amon2 Track")
    (:type atnd :url "http://atnd.org/events/22820" :title "Perl6 Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22781" :title "PHP Advent Calendar jp 2011")
    (:type atnd :url "http://atnd.org/events/22473" :title "PHP5.4 Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22721" :title "CakePHP Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22380" :title "FuelPHP Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22378" :title "Symfony Advent Calendar JP 2011")
    (:type atnd :url "http://atnd.org/events/22078" :title "PyPy Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22021" :title "Ruby Advent Calendar jp: 2011")
    (:type atnd :url "http://atnd.org/events/10901" :title "Ruby逆引きレシピAdvent Calendar")
    (:type atnd :url "http://atnd.org/events/22483" :title "G* Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22123" :title "Nimrod Advent Calendar jp: 2011")
    (:type atnd :url "http://atnd.org/events/22463" :title "Esolang Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22563" :title "Processing Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22909" :title "Force.com Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22528" :title "MySQL Casual Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/21994" :title "PostgtreSQL Advent Calendar")
    (:type atnd :url "http://atnd.org/events/21910" :title "カーネル／VM Advent Calendar")
    (:type atnd :url "http://atnd.org/events/22792" :title "iOS Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22816" :title "cocos2d Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22351" :title "Windows Phone Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22723" :title "KINECT SDK Advent Calendar")
    (:type atnd :url "http://atnd.org/events/22725" :title "OpenNI Advent Calendar")
    (:type atnd :url "http://atnd.org/events/22935" :title "Fedora Advent Calendar ")
    (:type atnd :url "http://atnd.org/events/22905" :title "Debian/Ubuntu JP Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/21987" :title "HTML5 Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/21919" :title "Less & Sass Advent calendar 2011")
    (:type atnd :url "http://atnd.org/events/22823" :title "WordPress Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22672" :title "Reblog Advent Calend*e*r 3011")
    (:type atnd :url "http://atnd.org/events/22760" :title "a-blog cms Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22596" :title "Cloud Foundry jp Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22821" :title "Windows Azure Advent Calendar jp: 2011")
    (:type atnd :url "http://atnd.org/events/21925" :title "Vim Advent Calendar 2011 ")
    (:type atnd :url "http://atnd.org/events/21982" :title "Emacs Advent Calendar jp: 2011")
    (:type atnd :url "http://atnd.org/events/22048" :title "Jenkins Advent Calendar jp 2011")
    (:type atnd :url "http://atnd.org/events/22899" :title "JIRA Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/21951" :title "Titanium Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22851" :title "Redmine Advent Calendar jp 2011")
    (:type atnd :url "http://atnd.org/events/22819" :title "TFS Advent Calendar")
    (:type atnd :url "http://atnd.org/events/22073" :title "PowerShell Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22039" :title "R Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22320" :title "ターミナルマルチプレクサ Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22027" :title "TDD Advent Calendar jp: 2011")
    (:type atnd :url "http://atnd.org/events/22266" :title "コワーキング・アドベント・カレンダー　２０１１")
    (:type atnd :url "http://atnd.org/events/22322" :title "日本App Inventorユーザー会 Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22833" :title "「Software Test ＆ Quality Advent Calendar 2011」")
    (:type atnd :url "http://atnd.org/events/22570" :title "Kosen Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22842" :title "Mac Dev JP advent calendar")
    (:type atnd :url "http://atnd.org/events/22740" :title "Hatena::Staff Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22822" :title "元etolabo::Staff Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22852" :title "Ariel Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22939" :title "女帝 Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22020" :title "変態アドベントカレンダー 2011")
    (:type atnd :url "http://atnd.org/events/22136" :title "まやふのほもっきんちゃん Advent Calendar")
    (:type atnd :url "http://atnd.org/events/22829" :title ".。oO(さっちゃんAdvent Calendar)")
    (:type atnd :url "http://atnd.org/events/22130" :title "Punishment Advent Calendar jp: 2011")
    (:type atnd :url "http://atnd.org/events/22441" :title "PHP Advent Calendar 2011（全部俺）")
    (:type atnd :url "http://atnd.org/events/22450" :title "Sphinx & blockdiag Advent Calendar(全部俺)")
    (:type atnd :url "http://atnd.org/events/22557" :title "Python Advent Calendar 2011（全部俺）")
    (:type atnd :url "http://atnd.org/events/22574" :title "Google Product Advent Calender 2011 （全部俺）")
    (:type atnd :url "http://atnd.org/events/22631" :title "俺 AdventCalendar 2011")
    (:type atnd :url "http://atnd.org/events/22669" :title "My AdventCalendar 2011")
    (:type atnd :url "http://atnd.org/events/22826" :title "LispギャグAdvent Calendar")
    (:type atnd :url "http://atnd.org/events/22834" :title "do_aki Advent Calendar 2011")
    (:type atnd :url "http://atnd.org/events/22835" :title "JBoss Advent Calendar 2011（全部俺）")
    (:type atnd :url "http://atnd.org/events/22862" :title "Windows Phone Advent Calendar ''ひとり'' 2011")
    (:type atnd :url "http://atnd.org/events/22889" :title "xyttr Advent Calendar")
    (:type partake.in :url "http://partake.in/events/07bb74d8-ba0d-4a3f-991c-b0547c78380c" :title "きつねさんAdvent Calendar 2012")
    (:type partake.in :url "http://partake.in/events/33870915-f25b-40b6-9456-b898b898d48b" :title "Scala Advent Calendar jp 2011")
    (:type partake.in :url "http://partake.in/events/b79f232d-5234-4ce3-9b10-b01629d492e7" :title "Functional Ikamusume Advent Calendar jp 2011")
    (:type partake.in :url "http://partake.in/events/30381166-394a-4fab-a5ea-5984d051de01" :title "Theorem Proving Advent Calendar 2011")
    (:type partake.in :url "http://partake.in/events/eaea52c2-61ef-46d5-a855-3a2dde459e3a" :title "Haskell Advent Calendar 2011")
    (:type partake.in :url "http://partake.in/events/902cd6d9-0215-4ea3-b51f-b8ff32e56426" :title "Mercurial Advent Calendar 2011")
    (:type partake.in :url "http://partake.in/events/ee35b200-e151-44c1-b123-482d0a7447b5" :title "Competitive Programming Advent Calendar")
    ))

;; util
(defun get-rss (rssurl)
  ;; xhrで使ってるXMLHTTP2.0(?)だとCDATAをパースしてくれない(?)ので6.0を使う
  (let ((xhr (ole-create-object "Msxml2.XMLHTTP.6.0")))
    (ole-method xhr :Open "GET" rssurl nil)
    (ole-method xhr :Send)
    (xhr::dom->sexp (ole-getprop xhr :responseXml))))

(defun rss-items (rssurl)
  (flet ((find-node (tagname node)
	   (find-if #'(lambda (e) (string= tagname (car e))) (cddr node))))
    (let ((rss (get-rss rssurl)))
      (loop for elm in (cddr (find-node "channel" (car rss)))
	when (string= "item" (car elm))
	collect
	(mapcan #'(lambda (k tag) (list k (caddr (find-node tag elm))))
		'(:title  :date     :url   :author  :description)
		'("title" "pubDate" "link" "author" "description"))))))

(defun to1line (text)
  (substitute-string text "[\t\r\n]+" " "))

;; entries
(defun get-atnd-entries (url)
  (let ((rssurl (concat (substitute-string url "events" "comments") ".rss")))
    (loop for item in (rss-items rssurl)
      for desc = (to1line (getf item :description))
      when (string-match "https?://[^ \"]+" desc)
      collect
      (let ((url (match-string 0))
	    (text (substitute-string
		   (substitute-string desc "</?[^>]+>" "")
		   (regexp-quote url) " ")))
	(cons (format nil "[~A] ~A~@[ by ~A~]" (getf item :date) text (getf item :author))
	      url)))))

(defun get-rss-entries (url)
  (loop for item in (nreverse (rss-items url))
    collect
    (cons (format nil "[~A] ~A~@[ by ~A~]"
		  (getf item :date) (getf item :title) (getf item :author))
	  (getf item :url))))

(defvar *entries* nil)

(defun open-entry (title)
  (let ((url (cdr (assoc title *entries* :test #'string=))))
    (shell-execute url t)))

;; menu
(defun user::advent-calendar-2011 ()
  (interactive)
  (let ((anything::*anything-sources* #0=(make-hash-table :test 'equal))
	(anything::*anything-type-attributes* #0#))

    ; エントリーをanythingで表示 (Partake.inは未対応)
    (add-anything-attribute
     :type calendar
     :display "View entries"
     :default t
     :action
     (lambda (title)
       (let* #3=((p (find title *calendars*
			  :key #'(lambda (p) (getf p :title))
			  :test #'string=))
		 (type (getf p :type))
		 (url (getf p :url)))
	 (case type
	   (atnd
	    (let ((entries (get-atnd-entries url)))
	      #1=(if entries (view-entries title entries)
		   #2=(shell-execute url t))))
	   (rss (let ((entries (get-rss-entries url))) #1#))
	   (partake.in #2#)))))

    ; 集約ページを表示
    (add-anything-attribute
     :type calendar
     :display "Open in browser"
     :action
     (lambda (title)
       (let* #3#
	 (case type
	   ((atnd partake.in) (shell-execute url t))
	   (rss (shell-execute (substitute-string url "/rss" "") t))))))

    (add-anything-sources
     :name "Advent Calendar 2011 jp"
     :type calendar
     :candidates (lambda () (mapcar #'(lambda (p) (getf p :title)) *calendars*)))

    (anything)))

(defun view-entries (title entries)
  (anything::anything-cleanup)
  (let ((anything::*anything-sources* #0=(make-hash-table :test 'equal))
	(anything::*anything-type-attributes* #0#)
	(*entries* entries))
    (setf (gethash title anything::*anything-sources*)
	  (anything::make-anything
	   :name title
	   :candidates (lambda () (mapcar #'car *entries*))
	   :action 'open-entry))
    (anything)))