いかにしておっぱい画像をダウンロードするか～2012 Scheme(Gauche)編

gistfile1.scm

; Gauche 0.9.2

(use srfi-43)
(use rfc.http)
(use rfc.json)
(use rfc.uri)
(use util.list)
(use util.match)
(use file.util)
(use gauche.threads)
(use gauche.parseopt)

(define app_id "replace your AppID")

(define (download-image uri)
	(receive (scheme user-info host port path query fragment) (uri-parse uri)
		(receive (dir filename ext) (decompose-path path)
			(when (and (string? ext) (rxmatch #/jpe?g/i ext))
				(receive (status head body) (http-get host path)
					(with-output-to-file (string-append filename "." ext) (pa$ print body))
					(print "downloaded : " uri))))))

(define (main args)
	(make-directory* "img") (current-directory "img")
	(let-args (cdr args) ((query "query=s"))
	(letrec ((iter (lambda (n)
		(let* ((options `(("AppID" ,app_id)
					("Version" "2.2")
					("Market" "ja-JP")
					("Sources" "Image")
					("Image.Count" "50")
					("Image.Offset" ,(number->string (* 50 n)))
					("Adult" "off")
					("Query" ,(uri-encode-string query))))
			(uri (string-append "/json.aspx?"
					(string-join (map (cut string-join <> "=") options) "&"))))
		(receive (status head body) (http-get "api.bing.net" uri)
			(let* ((response (assoc-ref (parse-json-string body) "SearchResponse"))
				(uri-list (vector-fold (lambda (i xs v) (cons (assoc-ref v "MediaUrl") xs)) '()
						(assoc-ref (assoc-ref response "Image") "Results"))))
			(match '((string=? status "200") (assoc "Errors" response))
				('(#f #f) (print "error status : " status))
				('(#t #t) (print "error reason : " r))
				(else (for-each (pa$ thread-join!)
						(map (lambda (u) (thread-start! (make-thread (pa$ download-image u))))
								uri-list)) (iter (+ n 1))))))))))
		(iter 0))))