[Common Lisp] Emacs Muse で書いて、Common Lisp 経由で Blogger に投稿する
とにかく Emacs から Blogger に投稿したかった。どうせなら Muse で書きたかった。simple-hatena-mode とかうらやましかった。というわけで作ってみた。
できること。
- 新規投稿
- 投稿したものの修正
めんどうなところ
- Slime 経由なので M-x slime とか事前にしておく必要がある。
- 新規投稿後、元ファイルの末尾に post-id をくっつけるので、Emacs 上で再読み込みする必要がある。
- カテゴリにはまだ対応してない。
- Web 上で編集したものとローカルの Muse ファイルの同期はとれない。Muse -> Web の一方通行。
- slime の repl バッファを見てないと、投稿が完了したかどうか分からない;)
これで随分と快適になった。howm で Muse を使うようにしているので、howm でメモをとり、まとまったらそのまま Blogger にポストできる。はてなに移行した理由の半分くらいがなくなった。Muse なら htmlize で Emacs の表示そのままソースに色が付くしね。
ちょっと量が多いが載っける。
blogger.asd
;;;; -*- Mode: LISP; -*-
(asdf:defsystem :blogger
:version "0.0.0"
:serial t
:components ((:file "packages")
(:file "blogger"))
:depends-on (drakma cl-ppcre cl-interpol s-xml))
packages.lisp
(defpackage :blogger
(:use :cl :drakma :cl-ppcre)
(:export :post))
blogger.lisp
(in-package :blogger)
(defvar *author* nil)
(defvar *email* nil)
(defvar *passwd* nil)
(defvar *blog-id* nil)
(defvar *blogger* nil)
(load (merge-pathnames #p".blogger.lisp" (user-homedir-pathname)))
;; CL-INTERPOL を使う
(cl-interpol:enable-interpol-syntax)
;; Drakma の設定
;; UTF-8
(setq *drakma-default-external-format* :utf-8)
;; application/atom+xml をバイナリではなくテキストとして扱う。
(pushnew (cons "application" "atom+xml") drakma:*text-content-types*
:test #'equal)
;; s-xml
;; ネームスペースを使わない
(setf s-xml:*ignore-namespaces* t)
(defclass blogger ()
((sid :initform nil :accessor sid)
(lsid :initform nil :accessor lsid)
(auth :initform nil :accessor auth)
(blog-id :initform *blog-id* :accessor blog-id)
(author :initform *author* :accessor author)
(email :initform *email* :accessor email)
(passwd :initform *passwd* :accessor passwd)
(latest-entry :initform nil :accessor latest-entry)))
(defmethod login-parameters ((blogger blogger))
`(("Email" . ,(email blogger))
("Passwd" . ,(passwd blogger))
("service" . "blogger")
("source" . "tahara-lisp-1")))
(defmethod login ((blogger blogger))
(register-groups-bind (sid lsid auth)
((create-scanner "^SID=(.*)\\nLSID=(.*)\\nAuth=(.*)$" :multi-line-mode t)
(http-request "https://www.google.com/accounts/ClientLogin"
:method :post
:parameters (login-parameters blogger)))
(or auth (error "loign failed."))
(setf (sid blogger) sid
(lsid blogger) lsid
(auth blogger) auth)))
(defmethod request ((blogger blogger) url &rest rest)
(apply #'http-request
url
:additional-headers
`(("Authorization"
. ,#?"GoogleLogin auth=${(auth blogger)}"))
rest))
(defmethod list-of-blogs ((blogger blogger))
(request blogger "http://www.blogger.com/feeds/default/blogs"))
(defmethod retrive-posts ((blogger blogger))
(request
blogger
#?"http://www.blogger.com/feeds/${(blog-id blogger)}/posts/default"))
(defmethod retrive-entry ((blogger blogger) entry-id)
(let ((res (request
blogger
#?"http://www.blogger.com/feeds/${(blog-id blogger)}/posts/default/${entry-id}")))
(print res)
(setf (latest-entry blogger) (s-xml:parse-xml-string res))))
(defmethod send-entry ((blogger blogger) url method post-data)
(print post-data)
(let ((res (request blogger
url
:method method
:content-type "application/atom+xml"
:content-length
(length (sb-ext:string-to-octets
post-data :external-format :utf-8))
:content post-data)))
(print res)
(setf (latest-entry blogger) (s-xml:parse-xml-string res))))
(defmethod post-entry ((blogger blogger) title contents)
(let*
((url #?"http://www.blogger.com/feeds/${(blog-id blogger)}/posts/default")
(post-data #?"<entry xmlns='http://www.w3.org/2005/Atom'>
<title type='text'>${title}</title>
<content type='xhtml'>${contents}</content>
<author>
<name>${(author blogger)}</name>
<email>${(email blogger)}</email>
</author>
</entry>"))
(send-entry blogger url :post post-data)))
(defmethod edit-entry ((blogger blogger) title content)
(replace-title blogger title)
(replace-content blogger content)
(let ((post-data (s-xml:print-xml-string (latest-entry blogger ))))
(send-entry blogger
(print (edit-href blogger))
:put
post-data)))
(defmethod replace-xml ((blogger blogger) tag text)
(setf (cdr (find tag (latest-entry blogger) :key #'find-key))
(list text)))
(defmethod replace-title ((blogger blogger) title)
(replace-xml blogger :|title| title))
(defmethod replace-content ((blogger blogger) content)
(replace-xml blogger :|content| content))
(defmethod edit-href ((blogger blogger))
(second
(member :|href|
(car
(find '(:|link| :|rel| "edit")
(latest-entry blogger)
:key #'(lambda (x)
(and (consp (car x))
(= (length (car x)) 7)
(subseq (car x) 0 3)))
:test #'equal)))))
(defun find-key (x)
(and (consp (car x)) (caar x)))
(defmethod delete-entry ((blogger blogger))
(request blogger (edit-href blogger) :method :delete))
(defun get-additional-info (muse-file)
(let (title post-id)
(with-open-file (in muse-file)
(loop for l = (read-line in nil nil)
while l
do (progn
(register-groups-bind (ttl)
("^#title\\s*(.+)" l)
(setf title ttl))
(register-groups-bind (pstid)
("^; post-id (.+)" l)
(setf post-id pstid)))))
(values title post-id)))
(defun html-file (muse-file)
(let ((file (make-pathname :directory "tmp"
:type "html"
:defaults muse-file)))
(if (probe-file file)
file
(make-pathname :directory "tmp"
:type #?"${(pathname-type muse-file)}.html"
:defaults muse-file))))
(defun get-content-from-file (file)
(with-output-to-string (out)
(with-open-file (in file)
(loop for line = (read-line in nil nil)
with pre-p = nil
while line
do (progn
(write-string line out)
(cond ((eql 0 (search "<pre" line))
(setf pre-p t))
((eql 0 (search "</pre>" line))
(setf pre-p nil))
(t
(when pre-p (terpri out)))))))))
(defun add-post-id-to-file (muse-file)
(register-groups-bind (post-id) (".*/(.*)" (edit-href *blogger*))
(let ((content (with-output-to-string (out)
(with-open-file (in muse-file)
(loop for c = (read-char in nil nil)
while c
do (write-char c out))))))
(with-open-file (out muse-file :direction :output :if-exists :supersede)
(write-string content out)
(format out "~&; post-id ~a~%" post-id)))))
;;;; api
(defun post (muse-file)
(setf *blogger* (make-instance 'blogger))
(login *blogger*)
(let ((content (get-content-from-file (html-file muse-file))))
(multiple-value-bind (title post-id) (get-additional-info muse-file)
(if post-id
;; 修正
(progn
(retrive-entry *blogger* post-id)
(edit-entry *blogger* title content))
;; 新規
(progn
(post-entry *blogger* title content)
(add-post-id-to-file muse-file)))))
*blogger*)
blogger.el Slime で同じように funcall read-from-string している理由がようやくわかった。read 時点では blogger パッケージはまだ存在しないからだ。
;; Blogger 用のスタイル
(setq muse-blogger-markup-strings
(copy-tree muse-html-markup-strings))
(mapcar #'(lambda (arg)
(rplacd (assoc (car arg) muse-blogger-markup-strings)
(cdr arg)))
'((section . "<h3>")
(section-end . "</h3>")
(subsection . "<h4>")
(subsection-end . "</h4>")
(subsubsection . "<h5>")
(subsubsection-end . "</h5>")
(section-other . "<h6>")
(section-other-end . "</h6>")
(begin-example . "<pre class='src'>")))
(muse-derive-style
"blogger" "html"
:header ""
:footer ""
:strings 'muse-blogger-markup-strings
)
(defun blogger-post ()
(interactive)
(save-buffer)
(muse-publish-this-file (muse-style "blogger") "/tmp" t)
(slime-repl-send-string
(format "(progn (require :blogger) (funcall (read-from-string \"blogger:post\") #p\"%s\"))"
(buffer-file-name))))
~/.blogger.lisp
;; -*- lisp -*-
(in-package :blogger)
(setf *author* "Your name"
*email* "your-email@gmail.com"
*passwd* "password"
*blog-id* "1096313046657120208")
~/.emacs
;;;; blogger
(add-path (expand-file-name "~/letter/lisp/lib/blogger"))
(autoload 'blogger-post "blogger" "Blogger Post" t)
1 件のコメント:
自分はblogger初心者ですが、おもしろそうですね。
install方法と使い方記述はないのですか？
コメントを投稿