ldrpin mode for xyzzy

ldrpin.l

;;; -*- mode: lisp; package: ldrpin -*-

;;; ldrpin mode for xyzzy

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require 'xml-http-request)
  (require 'json)
  (require 'www/www)
  (unless (find-package :ldrpin)
    (defpackage :ldrpin
      (:use :lisp :editor :xhr))))


(in-package :ldrpin)
(defvar *ldr-url* "http://reader.livedoor.com/reader/")
(defvar *ldr-apiurl* "http://reader.livedoor.com/api/")
(defvar *ldr-apikey* nil)
(defvar *ldr-username* nil)
(defvar *ldr-password* nil)

(defvar *ldrpin-buffer-name* "*ldr-pins*")
(defvar *ldrpin-mode-map* nil)
(defvar ldr-pins nil)

(export '(ldrpin-add ldrpin-del ldrpin-all ldrpin-clear
	  ldrpin-list ldr-getapikey
	  *ldr-url* *ldr-apiurl*
	  *ldr-username* *ldr-password*
	  *ldrpin-mode-map*))


;;; formatting
(defun entity2char (str)
  (reduce #'(lambda (s pair) (apply #'substitute-string s pair))
	  '(("&amp;" "&") ("&gt;" ">") ("&lt;" "<") ("&quot;" "\""))
	  :initial-value str))

(defun utc2ut (utc)
  (+ utc 2208988800))

(defun format-datetime (utc)
  (format-date-string
   "%y/%m/%d %H:%M:%S" (utc2ut utc)))

(defun print-elm (contents tag &rest attrs)
  (let ((start (point-max)))
    (format t "~A~%" contents)
    (apply #'set-text-attribute start (1- (point-max)) tag attrs))
  contents)



;;; json util
(defmacro json-keys (obj)
  `(mapcar #'car ,obj))

(defmacro json-value (obj key)
  `(cdr (assoc ,key ,obj :test #'string=)))

(defmacro with-json ((obj keys) &body body)
  (let ((binds (mapcar #'(lambda (k)
			   (list k `(json-value ,obj ,(symbol-name k))))
		       keys)))
    `(let ,binds ,@body)))

(setf (get 'with-json 'ed:lisp-indent-hook) 'let)


;;; ldr api
(defun ldr-getapikey ()
  (let ((future (xhr-get-future *ldr-url* :key #'xhr-response-values :since :epoch)))
    (multiple-value-bind (res status header) (xhr-future-value future)
      (case status
        (0 (and (ldr-login)
                (ldr-getapikey)))
        (200
         (if (string-match "ApiKey = \"\\([0-9a-z]+\\)\"" res)
             (setq *ldr-apikey* (match-string 1))
             (and (msgbox "ApiKey取得失敗") nil)))
        (t (and (msgbox "接続エラー: ~A" status) nil))))))

(defun ldr-login ()
  (interactive)
  (let* ((username (or *ldr-username* (minibuffer-input "user")))
	 (password (or *ldr-password* (minibuffer-input "pass" t)))
	 (future (xhr-post-future "http://member.livedoor.com/login/index"
                                 `(:livedoor_id ,username :password ,password)
                                 :key #'xhr:xhr-response-values
                                 :since :epoch)))
    (multiple-value-bind (res status header) (xhr-future-value future)
      (case status
        (200
         (if (string-match "認証に失敗しました" res)
             (and (msgbox "ログイン失敗") nil)
             t))
        (t (msgbox "接続エラー: ~A" status) nil)))))

(defun ldr-api (api &optional query ok)
  (when (or *ldr-apikey* (ldr-getapikey))
    (multiple-value-bind (res status header)
	(xhr-post (concat *ldr-apiurl* api)
		  `(,@query :ApiKey ,*ldr-apikey*)
		  :key #'xhr-response-text
		  :since :epoch)
      (if ok
	  (if (string-match "\"isSuccess\":1" res) t nil)
	res))))

(defun ldr-api-async (api query &key oncomplete)
  nil)


(defun ldrpin-add (link &optional (title ""))
  (interactive "sURL: \nsTitle: ")
  (let* ((title (or title link))
	 (ok (ldr-api "pin/add" `(:link ,(map-internal-to-utf-8 link)
				  :title ,(map-internal-to-utf-8 title))
		      t)))
    (message "~:[Failed~;Done (~A)~]" ok link)
    ok))

(defun ldrpin-del (link)
  (interactive "sURL: ")
  (let* ((ok (ldr-api "pin/remove" `(:link ,(map-internal-to-utf-8 link)) t)))
    (message "~:[Failed~;Removed (~A)~]" ok link)
    ok))

(defun ldrpin-clear ()
  (interactive)
  (let* ((ok (ldr-api "pin/clear") t))
    (message "~:[Failed~;Cleared~]" ok)
    ok))

(defun ldrpin-all ()
  (nreverse (json:json-decode (ldr-api "pin/all"))))

(defun ldrpin-list ()
  (save-excursion
    (with-output-to-selected-buffer
      ;(princ "[LDR Pinned Entries]")
      (let ((pins (ldrpin-all))
	    (n 0))
	(dolist (item pins)
	  (with-json (item (link title created_on))
	    (let ((title (entity2char title))
		  (link (entity2char link)))
	      (setf (gethash link ldr-pins) t)
	      (print-elm (format nil "[~2,'0D]~75@{-~}" (incf n) t)
			 :entry :foreground 14)
	      (print-elm title :title)
	      (print-elm link :link)
	      (print-elm (format-datetime created_on) :date))))))
    (not-modified)))



(defun minibuffer-input (prompt &optional (pass nil))
  (let ((in (make-vector 16 :element-type 'character :fill-pointer 0 :adjustable t)))
    (loop
      (if pass
          (minibuffer-prompt "~A: ~v@{~a~:*~}" prompt (length in) #\*)
          (minibuffer-prompt "~A: ~A" prompt in))
      (let ((c (read-char *keyboard*)))
        (case c
          (#\RET
           (return in))
          (#\C-g
           (quit))
          (#\C-q
           (vector-push-extend (read-char *keyboard*) in))
          (#\C-h
           (or (zerop (length in))
               (vector-pop in)))
          (t
           (vector-push-extend c in)))))))


;;; ldrpin-list-mode

(defun current-item (tag)
  (save-excursion
    (goto-eol)
    (let ((entry-start (find-text-attribute :entry :end (point) :from-end t)))
      (when entry-start
	(goto-char entry-start)
	(multiple-value-bind (start end tag)
	    (find-text-attribute tag :start (point))
	  (if start
	      (values (buffer-substring start end) start end)))))))

;;; ldrpin list mode

(defun next-entry ()
  (interactive)
  (goto-eol)
  (multiple-value-bind (start end tag)
      (find-text-attribute :entry :start (point))
    (when start
      (goto-char start)
      (recenter 0))))

(defun previouse-entry ()
  (interactive)
  (goto-bol)
  (multiple-value-bind (start end tag)
      (find-text-attribute :entry :end (point) :from-end t)
    (when start
      (goto-char start)
      (recenter 0))))

(defun toggle-pin ()
  (interactive)
  (let ((link (current-item :link))
	(title (current-item :title)))
    (when link
      (multiple-value-bind (s start end) (current-item :entry)
	(if #1=(gethash link ldr-pins)
	  (and (ldrpin-del link)
	       (set-text-attribute start end :entry :foreground 15)
	       (setf #1# nil))
	  (and (ldrpin-add link title)
	       (set-text-attribute start end :entry :foreground 14)
	       (setf #1# t)))))))

(defun open-current-link ()
  (interactive)
  (let ((link (current-item :link)))
    (when link
      (user::www-open-url link))))

(defun copy-current-link ()
  (interactive)
  (let ((link (current-item :link)))
    (when link
      (copy-to-clipboard link)
      (message "copied: ~A" link))))

(defun ldrpin-quit ()
  (interactive)
  (kill-buffer *ldrpin-buffer-name*))

#|
(defun open-hatebu-comment ()
  (interactive)
  (let ((link (current-item :link)))
    (when link
      (user::www-open-url
       (format nil "http://b.hatena.ne.jp/entry/~A"
	       (substring link (+ 2 (position #\/ link))))))))
|#

(defvar *hatebu-mode-map* nil)
(setq *hatebu-mode-map* (make-sparse-keymap))
(define-key *hatebu-mode-map* #\j 'next-line)
(define-key *hatebu-mode-map* #\k 'previous-line)
(define-key *hatebu-mode-map* #\q 'quit-hatebu)

(defun show-hatebu-comments ()
  (interactive)
  (let* ((url (current-item :link))
	 (res (xhr:xhr-get "http://b.hatena.ne.jp/entry/jsonlite/"
			   :query `(:url ,url)
			   :key #'xhr:xhr-response-text))
	 (buf (get-buffer-create (format nil "*comments on ~A*" url))))
    (with-output-to-buffer (buf)
      (if (string= res "null")
	  (format t "No bookmarks on ~A" url)
	(let ((o (json:json-decode res)))
	  (with-json (o (count bookmarks title))
	    (format t "~A  - ~A user~%~%" title count)
	    (dolist (e bookmarks)
	      (with-json (e (user tags comment))
		(format t "~&~A ~{[~A]~}: ~A" user tags comment)))))))
    (set-buffer-modified-p buf nil)
    (pop-to-buffer buf t)
    (hatebu-mode)))

(defun quit-hatebu ()
  (interactive)
  (delete-buffer (selected-buffer))
  (delete-window))

(defun hatebu-mode ()
  (kill-all-local-variables)
  (make-local-variable 'indent-tabs-mode)
  (setq mode-name "hatebu"
	indent-tabs-mode nil
	buffer-read-only t
	need-not-save t
	kept-undo-information nil
	auto-save nil)
  (toggle-ime nil)
  (set-local-window-flags (selected-buffer)
			  *window-flag-line-number* nil)
  (set-local-window-flags (selected-buffer)
			  *window-flag-newline* nil)
  (set-local-window-flags (selected-buffer)
			  *window-flag-eof* nil)
  (set-local-window-flags (selected-buffer)
			  *window-flag-cursor-line* t)
  (use-keymap *hatebu-mode-map*))


(setq *ldrpin-mode-map* (make-sparse-keymap))
(define-key *ldrpin-mode-map* #\p 'toggle-pin)
(define-key *ldrpin-mode-map* #\j 'next-entry)
(define-key *ldrpin-mode-map* #\k 'previouse-entry)
(define-key *ldrpin-mode-map* #\v 'open-current-link)
(define-key *ldrpin-mode-map* #\c 'copy-current-link)
(define-key *ldrpin-mode-map* #\q 'ldrpin-quit)
(define-key *ldrpin-mode-map* #\b 'show-hatebu-comments)

(defun ldrpin-mode ()
  (kill-all-local-variables)
  (make-local-variable 'indent-tabs-mode)
  (setq mode-name "LDR-Pins"
	indent-tabs-mode nil
	buffer-read-only t
	need-not-save t
	kept-undo-information nil
	auto-save nil)
  (toggle-ime nil)
  (set-local-window-flags (selected-buffer)
			  *window-flag-line-number* nil)
  (set-local-window-flags (selected-buffer)
			  *window-flag-newline* nil)
  (set-local-window-flags (selected-buffer)
			  *window-flag-eof* nil)
  (set-local-window-flags (selected-buffer)
			  *window-flag-cursor-line* t)
  (set-buffer-fold-width t)
;  (make-local-variable 'regexp-keyword-list)
;  (setq regexp-keyword-list *ldrpin-regexp-keyword-list*)
  (use-keymap *ldrpin-mode-map*))


(defun user::ldrpin ()
  (interactive)
  (set-buffer (get-buffer-create *ldrpin-buffer-name*))
  (setq buffer-read-only nil)
  (erase-buffer (selected-buffer))
  (setq ldr-pins (make-hash-table :test #'equal))
  (ldrpin-list)
  (ldrpin-mode))

(defun user::ldrpin-add-region (start end title)
  (interactive "r\nsTitle: " :default1 (buffer-name (selected-buffer)))
  (let ((url (buffer-substring start end)))
    (ldrpin-add url title)))

(provide "ldrpin")