#xyzzy で Gist閲覧 & 投稿

gist.l

;;; -*- mode:lisp; package: gist -*-

;; gist.l - xyzzyでGistの閲覧, ポスト
;; 
;; Copyright (c) 2011-2012  Yousuke Ushiki
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;; THE SOFTWARE.
;;

;;
;;  ## .xyzzy 設定
;;  (require "gist")
;;  (setq gist:*login-username* "foo@xyzzy.com")
;;
;;  ## 閲覧
;;  M-x gists-mine  -- 自分の投稿したGistのリストを表示 (非公開Gist含む)
;;  M-x gists-starred  -- スターを付けたGistのリストを表示
;;  M-x gists-user  -- 指定ユーザーの公開Gistのリストを表示
;;
;;  ## Gistリストバッファでのキー操作
;;  j, k - 上下移動
;;  J    - 次のページ
;;  o    - カーソル下のGistをブラウザで表示
;;  v    - カーソル下のGistを新規バッファで表示
;;  Q    - リストを閉じる
;;
;;  ## ポスト
;;  M-x gist-region  -- リージョンの内容をポスト
;;  M-x gist-buffer  -- バッファの内容をポスト
;;  M-x gist-files  -- ファイラで選択したファイル(複数可)をポスト
;;
;;  ※ Basic認証を使用しています。
;;  xyzzy起動後の初回のgist閲覧/ポスト時にパスワードを要求します。
;;

(provide "gist")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "xml-http-request")
  (require "json")
  (require "json-encode"))

(defpackage "gist"
  (:use :lisp :editor))

(in-package "gist")
(export '(*login-username*
	  *list-keymap*
	  popup-gist
	  gitio
	  ))

(defvar *api-url* "https://api.github.com")

(defvar *login-username* nil
  "github認証用ユーザー名")

(defparameter *list-keymap* (make-sparse-keymap)
  "gist一覧バッファ用キーマップ")

(define-key *list-keymap* #\c 'copy-url)
(define-key *list-keymap* #\C 'copy-gitio-url)
(define-key *list-keymap* #\j 'forward-entry)
(define-key *list-keymap* #\k 'backward-entry)
(define-key *list-keymap* #\o 'open-gist-in-browser)
(define-key *list-keymap* #\v 'view-gist)
(define-key *list-keymap* #\D 'delete-gist)
(define-key *list-keymap* #\J 'append-page)
(define-key *list-keymap* #\Q 'kill-selected-buffer)

(defvar *separater-attr* '(:foreground 14))

;;; utilities
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun symb (&rest args)
    (values (intern (format nil "~{~A~}" args))))

  (defun kw (expr)
    (intern (string expr) "keyword"))

  (defun json-value (obj key)
    (reduce #'(lambda (o k) (cdr (assoc k o :test #'string=)))
	    (split-string (symbol-name key) #\.)
	    :initial-value obj)))

(defmacro whenlet (var expr &body body)
  `(let ((,var ,expr)) (when ,var ,@body)))

(defmacro w/json (keys obj &body body)
  (let ((gobj (gensym)))
    `(let* ((,gobj ,obj)
	    ,@(mapcar #'(lambda (k) `(,k (json-value ,gobj ',k))) keys))
       ,@body)))

(defmacro w/buffer-modifying ((&optional buf) &body body)
  `(save-excursion
     (set-buffer ,(or buf '(selected-buffer)))
     (setq ed:buffer-read-only nil)
     ,@body
     (set-buffer-modified-p nil)
     (setq ed:buffer-read-only t)))

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


;;; api
(defvar *auth-header* nil)
(defun auth-header ()
  (or *auth-header*
      (let ((user (or *login-username* (read-string "github user: "))))
	(if (string= user "")
	    nil
	  (let* ((pass (minibuffer-input "Password for Github" t))
		 (sign (remove #\LFD (si:base64-encode (concat user ":" pass)))))
	    (setq *auth-header* (list :Authorization (format nil "Basic ~A" sign))))))))


(defmacro define-api (name params path &key (method 'get))
  (unless path (error "define-api: missing 'path'"))
  (let ((sync (symb "api-" name))
	(async (symb "api-" name "-async")))
    `(progn
       (defun ,sync (&key ,@params)
	 (tagbody
	   :retry
	   (multiple-value-bind (res status header)
	       (xhr:xhr-request ',method (concat *api-url* ,path)
				,(or (find 'json params :test #'string=)
				     `(append ,@(mapcar #'(lambda (p) `(if ,p ,(list 'list (kw p) p))) params)))
				:headers `(:Content-Type "application/json" ,@(auth-header))
				:since :epoch
				:key #'xhr:xhr-response-values)
	     (cond ((<= 200 status 210)
		    (return-from ,sync res))
		   ((= 401 status)
		    (setq *auth-header* nil)
		    (go :retry))
		   (t (error "HTTP/~A~%~A" status res))))))

       (defun ,async (&key ,@params onsuccess onfailure)
	 (xhr:xhr-request-async ',method (concat *api-url* ,path)
				,(or (find 'json params :test #'string=)
				     `(append ,@(mapcar #'(lambda (p) `(if ,p ,(list 'list (kw p) p))) params)))
				:headers `(:Content-Type "application/json" ,@(auth-header))
				:since :epoch
				:key #'xhr:xhr-response-values
				:onsuccess onsuccess
				:onfailure
				(lambda (res status header)
				  (cond ((= 401 status)
					 (setq *auth-header* nil)
					 (,async ,@(mapcan #'(lambda (s) (list (kw s) s)) params)
					  :onsuccess onsuccess :onfailure onfailure))
					(t (funcall onfailure res status header))))))
       (export '(,sync ,async))
       )))


(define-api my-gists (page)
  (format nil "/gists~@[?page=~A~]" page))

(define-api user-gists (user page)
  (format nil "/users/~A/gists~@[?page=~A~]" user page))

(define-api public-gists (page)
  (format nil "gists~@[?page=~A~]" page))

(define-api starred-gists (page)
  (format nil "/gists/starred~@[?page=~A~]" page))

(define-api get-gist (id)
  (format nil "/gists/~A" id))

(define-api create (json)
  "/gists"
  :method post)

#+:nil
(define-api edit (id json)
  (format nil "/gists/~A" id)
  :method patch)

(define-api star (id)
  (format nil "/gists/~A/star" id)
  :method post)

(define-api unstar (id)
  (format nil "/gists/~A/star" id)
  :method delete)

(define-api get-star (id)
  (format nil "/gists/~A/star" id))

(define-api fork (id)
  (format nil "/gists/~A/fork")
  :method post)

(define-api delete (id)
  (format nil "/gists/~A" id)
  :method delete)


;;; git.io url shortener
(defun gitio (url &optional code)
  (unless (string-match #0="^https://\\(gist\\.\\)?github.com" url)
    (error "URL must match ~A" #0#))
  (multiple-value-bind (res status header)
      (xhr:xhr-post "http://git.io" `(:url ,url ,@(if code (list :code code)))
		    :key #'xhr:xhr-response-values)
    (if (= status 201)
	(cdr (assoc "Location" header :test #'string-equal))
      (error "~A: ~A" status res))))


;;; post
(defun gist-create (description public file-contents-pairs)
  (let ((json (list
	       (cons :description description)
	       (cons :public public)
	       (cons :files
		     (mapcar #'(lambda (p) (list (car p) (cons :content (cdr p))))
			     file-contents-pairs)))))
    (gist:api-create-async
     :json (json:json-encode json)
     :onsuccess
     (lambda (res status header)
       (whenlet html_url (json-value (json:json-decode res) 'html_url)
	 (when (eq :yes (message-box (format nil "GistのURLをクリップボードにコピーしますか?~%~A" html_url)
				     "Gist作成完了" '(:yes-no)))
	   (copy-to-clipboard html_url))))
     :onfailure
     (lambda (res status header)
       (message "~A: Gist作成失敗" status)))))


;;; gist list buffer
(defun draw-list (buf gists &optional (point 0))
  (save-excursion
    (set-buffer buf)
    (w/buffer-modifying (buf)
      (let ((wc (max 20 (1- (window-columns)))))
	(with-output-to-buffer (buf point)
	  (dolist (gist gists)
	    (let ((start #1=(buffer-stream-point *standard-output*)))
	      (format t " ~V@{-~}~%" (1- wc) t)
	      (w/json (user.login updated_at created_at public description comments
		       url git_pull_url git_push_url html_url files) gist
		(format t "~A [~A] ~:[private~;~]~%~A~%~{~A~^; ~}~%~A~%"
			user.login updated_at public
			(or description "(no description)")
			(mapcar #'car files) html_url)
		(apply #'set-text-attribute
		       (1+ start) (+ start wc) (cons :entry gist) *separater-attr*))))
	  )))
    (recenter)))

(defun entry-point (&optional (p (point)))
  (multiple-value-bind (start end tag)
      (find-text-attribute :entry :key #'safe-car :end (1+ p) :from-end t)
    (when start
      (values start (cdr tag)))))

(defun forward-entry ()
  (interactive)
  (whenlet start (find-text-attribute :entry :key #'safe-car :start (1+ (point)))
    (goto-char start)
    (forward-line 2)
    (recenter)))

(defun backward-entry ()
  (interactive)
  (whenlet c (entry-point)
    (whenlet p (entry-point (1- c))
      (goto-char p)
      (forward-line 2)
      (recenter))))

(defvar-local pager nil)
(defun make-pager (api &rest params)
  (let ((page 0))
    (lambda ()
      (apply api :page (incf page) params))))

(defun append-page ()
  (interactive)
  (unless (eq buffer-mode 'gists-list-mode)
    #0=(return-from append-page))
  (unless pager
    #1=(message "no more pages.")
    #0#)
  (let ((res (funcall pager)))
    (if res
	(draw-list (selected-buffer)
		   (json:json-decode res)
		   (point-max))
      (progn
	(setq pager nil)
	#1# #0#))))


(defun gists-list-mode ()
  (interactive)
  (kill-all-local-variables)
  (setq buffer-mode 'gists-list-mode
	mode-name "gists"
	kept-undo-information nil
	need-not-save t
	buffer-read-only t
	auto-save nil)
  (set-buffer-fold-type-window)
  (use-keymap *list-keymap*))

(defvar *popup-keymap* (make-sparse-keymap))
(define-key *popup-keymap* #\q #'(lambda () (interactive) (delete-buffer (selected-buffer))))

(defun popup-gist (gist-id &optional read-only)
  (whenlet res (api-get-gist :id gist-id)
    (w/json (user.login updated_at files) (json:json-decode res)
      (let ((firstbuf nil)
	    (wc (current-window-configuration)))
	(dolist (f files)
	  (w/json (filename content size) (cdr f)
	    (let ((buf (get-buffer-create (format nil "gist/~A/~A" gist-id filename))))
	      (setq firstbuf (or firstbuf buf))
	      (erase-buffer buf)
	      (with-output-to-buffer (buf)
		(princ content))
	      (save-excursion
		(set-buffer buf)
		(whenlet mode (assoc filename *auto-mode-alist*
				     :test #'(lambda (fn pat) (string-match pat fn)))
		  (funcall (cdr mode)))
		(set-buffer-modified-p nil buf)
		(when read-only
		  (setq buffer-read-only read-only)
		  (if (= (length files) 1)
		      (let ((km (copy-keymap *popup-keymap*)))
			(define-key km #\q #'(lambda () (interactive) (delete-buffer buf) (set-window-configuration wc)))
			(use-keymap km))
		    (use-keymap *popup-keymap*)))
		))))
	(pop-to-buffer firstbuf t)))))


;;; actions
(defmacro w/entry (keys &body body)
  `(multiple-value-bind (#:s #1=#:tag) (entry-point)
     (when #1# (w/json ,keys #1# ,@body))))

(defun open-gist-in-browser ()
  (interactive)
  (w/entry (html_url)
    (when html_url
      (shell-execute html_url t))))

(defun view-gist ()
  (interactive)
  (w/entry (id)
    (popup-gist id t)))

(defun delete-gist ()
  (interactive)
  (w/entry (id)
    (api-delete-async
     :id id
     :onsuccess
     (lambda (r s h)
       (message "gist/~A Deleted." id))
     :onfailure
     (lambda (r s h)
       (message "HTTP ~A failed." s))
     )))

(defun copy-url ()
  (interactive)
  (w/entry (html_url)
    (copy-to-clipboard html_url)
    (message "Copied: ~A" html_url)))

(defun copy-gitio-url ()
  (interactive)
  (w/entry (html_url)
    (let* ((code (minibuffer-input "git.io code"))
	   (shorten (gitio html_url (if (string/= code "") code))))
      (copy-to-clipboard shorten)
      (message "Copied: ~A" shorten))))


;;; commands
;; list
(defun user::gists-mine ()
  (interactive)
  (let ((buf (get-buffer-create "*gists:mine*")))
    (set-buffer buf)
    (if (eq buffer-mode 'gists-list-mode)
	(w/buffer-modifying buf
	  (erase-buffer buf))
      (gists-list-mode))
    (setq pager (make-pager #'api-my-gists))
    (append-page)))

(defun user::gists-user (user)
  (interactive "sGithub User: ")
  (when (string= user "")
    (quit))
  (let ((buf (get-buffer-create (format nil "*gists:~A*" user))))
    (set-buffer buf)
    (if (eq buffer-mode 'gists-list-mode)
	(w/buffer-modifying buf
	  (erase-buffer buf))
      (gists-list-mode))
    (setq pager (make-pager #'api-user-gists :user user))
    (append-page)))

(defun user::gists-starred ()
  (interactive)
  (let ((buf (get-buffer-create "*gists:starred*")))
    (set-buffer buf)
    (if (eq buffer-mode 'gists-list-mode)
	(w/buffer-modifying buf
	  (erase-buffer buf))
      (gists-list-mode))
    (setq pager (make-pager #'api-starred-gists))
    (append-page)))

;; post
(defun user::gist-region (from to)
  (interactive "r")
  (let ((filename (if #0=(get-buffer-file-name) (file-namestring #0#) "gistfile1"))
	(content (buffer-substring from to))
	(description (read-string "Description: "))
	(public (string-equal (completing-read "Public? (y/n): " '("y" "n")
					       :default "y" :case-fold t :must-match t)
			      "y")))
    (gist-create description public (list (cons filename content)))))

(defun user::gist-buffer ()
  (interactive)
  (user::gist-region (point-min) (point-max)))

(defun user::gist-files ()
  (interactive)
  (multiple-value-bind (files select)
      (filer (directory-namestring  (or (get-buffer-file-name) "~/"))
	     t "Select upload files" nil nil)
    (when select
      (let* ((description (read-string "Description: "))
	     (public (string-equal
		      (completing-read "Public? (y/n): " '("y" "n")
				       :default "y" :case-fold t :must-match t)
		      "y"))
	     (buf (create-new-buffer "*gist-temp*"))
	     (data (mapcar #'(lambda (path)
			       (save-excursion
				 (set-buffer buf)
				 (read-file path)
				 (cons (file-namestring path)
				       (buffer-substring 0 (point-max)))))
			   files)))
	(delete-buffer buf)
	(gist-create description public data)))))

json-encode.l

;;; -*- mode:lisp; package:json -*-

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "json"))

(in-package "json")
(export '(json-encode write-json))

(defun json-encode (obj)
  (with-output-to-string (s)
    (write-json obj s)))

(defun write-json (obj &optional s)
  (cond
   ((consp obj) (write-alist obj s))
   ((stringp obj) (write-js-string obj s))
   ((characterp obj) (write-js-char obj s))
   ((symbolp obj) (write-js-symbol obj s))
   ((or (integerp obj) (single-float-p obj)) (princ obj s))
   ((realp obj)
    (princ (substitute-string (format nil "~F" (* 1d0 obj)) "d" "e") s))
   ((vectorp obj) (write-array obj s))
   (t (type-error obj '(or string char symbol number cons))))
  nil)

(defun write-alist (al s)
  (princ #\{ s)
  (format s "~S:" (string (caar al)))
  (write-json (cdar al) s)
  (loop for (k . v) in (cdr al) do
    (format s ",~S:" (string k))
    (write-json v s))
  (princ #\} s))

(defun write-array (v s)
  (format s "[~{~A~^,~}]" (map 'list #'json-encode v)))

(defun write-js-string (str s)
  (princ #\" s)
  (loop for c across str do (write-js-char c s))
  (princ #\" s))

(defun write-js-char (chr s)
  (case chr
    (#\TAB (format s "\\t"))
    (#\LFD (format s "\\n"))
    (#\RET (format s "\\r"))
    (#\C-h (format s "\\b"))
    (#\C-l (format s "\\f"))
    (#\\ (format s "\\\\"))
    (#\" (format s "\\\""))
    (t (let ((uc (char-unicode chr)))
	 (when uc
	   (if (<= 32 uc 126)
	       (princ chr s)
	     (format s "\\u~4,'0x" uc)))))))

(defun write-js-symbol (sym s)
  (cond ((or (eq sym t) (string= sym "true"))
	 (princ "true" s))
	((or (eq sym nil) (string= sym "null"))
	 (princ "null" s))
	((string= sym "false")
	 (princ "false" sym))
	(t (write-js-string (symbol-name sym) s))))