#!/usr/local/bin/gosh (use srfi-13) (use srfi-19) (use srfi-43) (use util.match :only (match-let1)) (use rfc.http :only (http-get)) (use rfc.json) (use rfc.822 :only (rfc822-parse-date)) (use math.mt-random :only (mt-random-integer )) (use util.list) (use gauche.parseopt) ;; http://valvallow.tumblr.com/api/read/json?num=1&type=quote (define (usage) (print "usage: tumblrand [-i | -t | -j | -h] ") (print " -i | id ex : -i valvallow") (print " -t | type ex : -t quote") (print " -j | json") (print " -h | help") (exit 0)) ;; (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) (let* ((idx (string-scan str #\{)) (json (substring str idx (- (string-length str) 1)))) (parse-json-string json)))) (define (tumble-total-count server :optional (type "")) (let1 uri (tumble-uri '(start . 0)'(num . 1)`(type . ,type)) (let1 json (tumble-json server uri) (cdr (assoc "posts-total" json))))) (define (random-number total) (mt-random-integer (make :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 (format-date date-string) (receive (year month day-of-month hour minutes seconds timezone day-of-week) (rfc822-parse-date date-string) (format "~a/~2,'0D/~2,'0D ~2,'0D:~2,'0D:~2,'0D" year month day-of-month hour minutes seconds))) ;; TODO: ;; - define abstruct class ;; - has show-tumble method ;; - has show-tumble-detail abstruct method ;; - show-tumble call show-tumble-details ;; - show-tumble-details implements concrete class (define (show-tumble json id type) (let ((posts (vector-ref (assoc-ref json "posts") 0))) (let ((tumble-url (assoc-ref posts "url")) (txt (assoc-ref posts #`",|type|-text")) (date (assoc-ref posts "date"))) (print #`"id : ,(tumble-server id)") (print #`"url : ,tumble-url") (print #`"date : ,(format-date date)") (print #`"type : ,type") (print (or txt ""))))) (define (walk-json-alist alist :key (key-fun identity)(val-fun identity)) (define (junction x) (cond ((pair? x)(walk-json-alist x :key-fun key-fun :val-fun val-fun)) ((vector? x)(vector-case x)) (else (val-fun x)))) (define (vector-case v) (vector-map (^ (idx e) (junction e)) v)) (map (^l (cons (key-fun (car l)) (junction (cdr l)))) alist)) (define (transform-tumble-json alist) (walk-json-alist alist :val-fun (lambda (s) (if (string? s) (regexp-replace-all #/\"/ s "\\\\\"") s)))) (define (main args) (let-args (cdr args) ((id "i|id=s") (type "t|type=s") (json "j|json") (help "h|help" => usage) . rest-args) (let ((id (or id (and (not (null? rest-args)) (car rest-args)) (read-line))) (type (or type (and (not (null? rest-args)) (not (null? (cdr rest-args))) (cadr rest-args))))) (let ((response (tumble-random-json id type))) (if json (print (construct-json-string (transform-tumble-json response))) (show-tumble response id type))))))