scheme, gauche, twitter

tumblrandom.scm

(use srfi-13)
(use util.match :only (match-let1))
(use net.twitter :only (<twitter-cred> twitter-update))
(use rfc.http :only (http-get))
(use rfc.json :only (parse-json-string))
(use math.mt-random :only (mt-random-integer <mersenne-twister>))
(use util.list :only (intersperse))

;; http://valvallow.tumblr.com/api/read/json?num=1&type=quote

;; (param-pairs->string  '(start . 410)'(num . 1)'(type . quote))
;; -> "?start=410&num=1&type=quote"
(define (param-pairs->string . param-pairs)
  (if (null? param-pairs)
      ""
      (let1 params (map (^e (string-append (x->string (car e))
                                           "="
                                           (x->string (cdr e))))
                        param-pairs)
        (apply string-append "?" (intersperse "&" params)))))

;; (build-uri "/api/read/json" '(start . 410)'(num . 1)'(type . quote))
;; -> "/api/read/json?start=410&num=1&type=quote"
(define (build-uri request-uri . param-pairs)
  (string-append request-uri (apply param-pairs->string param-pairs)))

(define (tumble-uri . param-pairs)
  (apply build-uri "/api/read/json" param-pairs))

(define (tumble-server id)
  (format "~a.tumblr.com" id))

(define (tumble-json server uri)
  (let1 str (values-ref (http-get server uri) 2)
    (let1 matched (#/\{.*\}/ str)
      (unless matched
        (error str))
      (parse-json-string (matched)))))

(define (tumble-total-count server :optional (type ""))
  (let1 uri (tumble-uri '(start . 0)'(num . 0)`(type . ,type))
    (let1 json (tumble-json server uri)
      (string->number (cdr (assoc "posts-total" json))))))

(define (random-number total)
  (mt-random-integer (make <mersenne-twister> :seed (sys-time)) total))

(define (tumble-random-json id :optional (type ""))
  (let1 server (tumble-server id)
    (let1 total (tumble-total-count server type)
      (tumble-json server
                   (tumble-uri `(start . ,(random-number total))
                                       '(num . 1)`(type . ,type))))))

(define (build-msg id :optional (type ""))
  (let1 json (tumble-random-json id type)
    (let1 post (vector-ref (cdr (assoc "posts" json)) 0)
      (let ((url (cdr (assoc "url" post)))
            (txt (cdr (assoc (string-append (if (string-null? type)
                                                ""
                                                #`",|type|-") "text") post))))
        (let ((len (- 140 (string-length url) 1))
              (txt (regexp-replace-all #/<.*?>/ (regexp-replace-all #/@/ txt "[at]") "")))
          (string-append (if (<= (string-length txt) len)
                             txt
                             (string-take txt len)) " " url))))))

(define (main args)
  (match-let1
   (con-key con-sec acc-tok acc-sec tumblr-id type)(cdr args)
   (let ((cred (make <twitter-cred>
                 :consumer-key con-key
                 :consumer-secret con-sec
                 :access-token acc-tok
                 :access-token-secret acc-sec))
         (msg (build-msg tumblr-id type)))
     (twitter-update cred msg))))