xyttrで画像アップロード

tweet-with-photo.l

;;; -*- mode:lisp; package:xyttr -*-

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

(in-package "xyttr")

(defvar *upload-url* "http://upload.twitter.com")

(defun file2binstr (path)
  (let* ((size (file-length path))
	 (buf (make-vector size :element-type 'character :fill-pointer 0)))
    (with-open-file (is path :direction :input :encoding :binary)
      (read-into buf is))))

(defun make-media-data (status path boundary)
  (let ((fsize (file-length path))
	(data (file2binstr path))
	(part1 (format nil "--~A\r\n~
Content-Disposition: form-data; name=\"status\";\r\n\r\n
~A\r\n~
--~A\r\n~
Content-Disposition: form-data; name=\"media[]\"; filename=\"~A\"\r\n~
Content-Type: image/~A\r\n~
Content-Transfer-Encoding: binary\r\n\r\n"
		       boundary
		       (convert-encoding-from-internal *encoding-utf8n* status)
		       boundary
		       (file-namestring path)
		       (pathname-type path))))
    (values
     (concat part1 data "\r\n--" boundary "--\r\n")
     (+ (si:chunk-size (si:make-string-chunk part1))
	fsize 8 (length boundary)))))


(defun api-update-with-media (&key status image-path)
  (interactive)
  (let* ((path "/1/statuses/update_with_media.json")
	 (url (concat *upload-url* path))
	 (cred (list :consumer-key *consumer-key*
		     :consumer-secret *consumer-secret*
		     :token *token*
		     :token-secret *token-secret*))
	 (auth (oauth:auth-header cred 'POST url nil))
	 (boundary (oauth::random-string 20)))
      (multiple-value-bind (data clen)
	  (make-media-data status image-path boundary)
	(with-open-stream (cn (connect "upload.twitter.com" 80))
	  (set-stream-encoding cn :binary)
	  (format cn "POST ~A HTTP/1.1\n~
Host: upload.twitter.com\n~
Authorization: ~A\n~
Content-Length: ~D\n~
Content-Type: multipart/form-data; boundary=~A\n\n~
~A\n"
		  path auth clen boundary data)
	  (set-stream-encoding cn :text)
	  (while (not (listen cn)) (sleep-for 0.5))
	  (while (string/= (read-line cn nil) ""))
	  (let ((res (json:json-decode (read-line cn nil))))
	    (if (json-value res error)
		(error 'request-error
		       :host *upload-url* :path path :method 'POST
		       :status status :response res)
	      res))))))


(defvar *photo-directory* (merge-pathnames "Pictures" (si:getenv "USERPROFILE")))

(defun tweet-with-photo ()
  (interactive)
  (multiple-value-bind (path ok)
      (filer *photo-directory* nil "画像ファイル" nil nil)
    (unless ok (quit))
    (let ((status (read-status "tweet: ")))
      (when (api-update-with-media :status status :image-path path)
	(message "Uploaded: ~A" path)))))