Twitter.scm の手直し
;; 誰かの friends 一覧。 ;; 認証は要らないのでアカウント情報のかわりに #f を渡す。 (for-each (lambda (x) (format #t "~a: ~a~%" (ref* x 'user 'name) (ref x 'text))) (twitter-friends-timeline #f :id "masa_edw")) ;; アカウント情報 (define myself (make <twitter-account> :username-or-email "hogehoge" :password "brabra")) ;; 自分の friends 一覧 (for-each (lambda (x) (format #t "~a: ~a~%" (ref* x 'user 'name) (ref x 'text))) (twitter-friends-timeline myself)) ;; ステータス更新 (twitter-update myself "using twitter.scm")
;; -*- coding: utf-8 -*- ;; ;; Twitter.scm ;; ;; see: ;; http://groups.google.com/group/twitter-development-talk/web/api-documentation ;; (use rfc.http) (use rfc.base64) (use rfc.uri) (use sxml.ssax) (use util.match) (define *user-agent* "Twitter.scm") (define-class <twitter-account> () ((password :init-keyword :password) (username-or-email :init-keyword :username-or-email))) (define-class <twitter-status> () ((created-at :init-keyword :created-at) (id :init-keyword :id) (text :init-keyword :text) (user :init-keyword :user))) (define-class <twitter-user> () ((id :init-keyword :id) (name :init-keyword :name) (screen-name :init-keyword :screen-name) (location :init-keyword :location) (description :init-keyword :description) (profile-image-url :init-keyword :profile-image-url) (url :init-keyword :url) (protected :init-keyword :protected) (status :init-keyword :status) (profile-background-color :init-keyword :profile-background-color) (profile-text-color :init-keyword :profile-text-color) (profile-link-color :init-keyword :profile-link-color) (profile-sidebar-fill-color :init-keyword :profile-sidebar-fill-color) (profile-sidebar-border-color :init-keyword :profile-sidebar-border-color) (friends-count :init-keyword :friends-count) (followers-count :init-keyword :followers-count) (favourites-count :init-keyword :favourites-count) (statuses-count :init-keyword :statuses-count))) (define (twitter-authorization-string twitter) (let ((password (slot-ref twitter 'password)) (username-or-email (slot-ref twitter 'username-or-email))) (let1 base64str (base64-encode-string #`",|username-or-email|:,|password|") #`"Basic ,|base64str|"))) ;; utility (define (car1 pair) (if (null? pair) pair (car pair))) (define (tagname->slotname tag) (string->symbol (regexp-replace-all #/_/ (symbol->string tag) "-"))) (define (twitter-parse-user-status class inner inner-parser msg) (lambda (sxml) (let1 instance (make class) (for-each (match-lambda (((? (lambda (tag) (eq? tag inner)) slot) value ...) (slot-set! instance slot (inner-parser value))) (((? (lambda (tag) (slot-exists? instance (tagname->slotname tag))) tag) value) (slot-set! instance (tagname->slotname tag) value)) ((tag) ; do nothing ()) (i (error (format #f "No such slot in ~a:" class) (tagname->slotname (car i))))) sxml) instance))) (define twitter-parse-user (twitter-parse-user-status <twitter-user> 'status (cut twitter-parse-status <>) "user")) (define twitter-parse-status (twitter-parse-user-status <twitter-status> 'user (cut twitter-parse-user <>) "status")) (define (twitter-parse sxml) (match sxml ((or ('*TOP* x ...) (('*PI* _ ...) x)) (twitter-parse x)) (('statuses ('status x ...) ...) (map twitter-parse-status x)) (('users ('user x ...) ...) (map twitter-parse-user x)) (('status x ...) (twitter-parse-status x)) (('user x ...) (twitter-parse-user x)) (('nil-classes) ()))) (define (twitter-parse-xml xml) (let1 sxml (ssax:xml->sxml (open-input-string xml) ()) (twitter-parse sxml))) (define (twitter-get url . maybe-twitter) (let ((twitter (get-optional maybe-twitter #f))) (receive (status header body) (if twitter (http-get "twitter.com" url :user-agent *user-agent* :authorization (twitter-authorization-string twitter)) (http-get "twitter.com" url :user-agent *user-agent*)) (if (string=? status "200") (twitter-parse-xml body) status)))) (define (twitter-post url twitter data) (receive (status header body) (http-post "twitter.com" url data :user-agent *user-agent* :authorization (twitter-authorization-string twitter)) (if (string=? status "200") (twitter-parse-xml body) status))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Status Methods ;; ;; utility (define (alist->query alist) (if (null? alist) "" (string-append "?" (string-join (map (lambda (x) (format #f "~a=~a" (uri-encode-string (x->string (car x))) (uri-encode-string (x->string (cadr x))))) alist) "&")))) (define (twitter-public-timeline . args) (let-keywords args ((id #f)) (twitter-get (if id #`"/statuses/public_timeline.xml?since_id=,(uri-encode-string id)" "/statuses/public_timeline.xml")))) (define (twitter-friends-timeline twitter . args) (let-keywords args ((id #f) (since #f)) (let ((xmlstr (if id #`"friends_timeline/,(uri-encode-string id).xml" "friends_timeline.xml")) (sincestr (if since #`"?since=,(uri-encode-string since)" ""))) (twitter-get (string-append "/statuses/" xmlstr sincestr) twitter)))) (define (twitter-user-timeline twitter . args) (let-keywords args ((id #f) (count #f) (since #f)) (let ((xmlstr (if id #`"/statuses/user_timeline/,(uri-encode-string id).xml" #`"/statuses/user_timeline.xml")) (query (alist->query (filter cadr `((count ,count) (since ,since)))))) (twitter-get (string-append xmlstr query) twitter)))) (define (twitter-show twitter id-number) (twitter-get #`"/statuses/show/,(uri-encode-string id-number).xml" twitter)) (define (twitter-update twitter status) (if (> (string-length status) 140) (error "Too long status: " status) (twitter-post "/statuses/update.xml" twitter #`"status=,(uri-encode-string status)"))) ;; ;; User Methods ;; (define (twitter-friends twitter . args) (let-keywords args ((id #f)) (if id (twitter-get #`"/statuses/friends/,(uri-encode-string id).xml") (twitter-get "/statuses/friends.xml" twitter)))) (define (twitter-followers twitter) (twitter-get "/statuses/followers.xml" twitter)) (define (twitter-featured twitter) (twitter-get "/statuses/featured.xml" twitter)) (define (twitter-user-show twitter id) (twitter-get #`"/users/show/,(uri-encode-string id).xml" twitter)) ;; ;; Direct Message Methods ;; (define (twitter-direct-messages twitter . args) (let-keywords args ((since #f)) (if since (twitter-get #`"/direct_messages.xml?since=,(uri-encode-string since)" twitter) (twitter-get "/direct_messages.xml" twitter)))) (define (twitter-direct-message-new twitter user text) (if (> (string-length text) 140) (error "Too long text: " text) (twitter-post "/direct_messages/new.xml" twitter #`"user=,(uri-encode-string user)&text=,(uri-encode-string text)"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (easy-output list) (if (pair? list) (for-each (lambda (x) (format #t "~a: ~a~%" (ref* x 'user 'name) (ref x 'text))) list) list))
あ、備前さんのアドバイスにより -*- coding: utf-8 -*- をつけたはいいものの、こんどは日本語コメントが無くなってしまった。
