#lang scheme
(require file/md5
xml/xml
net/url
net/uri-codec)
(current-alist-separator-mode 'amp)
(define-struct argument-info (name optional? description) #:transparent)
(define-struct error-info (code msg explan) #:transparent)
(define-struct method-info
(name needs-login? needs-signing? required-perms
description response explaination arguments errors)
#:transparent)
(define meth-url (string->url "http://api.flickr.com/services/rest/"))
(define auth-url (string->url "http://www.flickr.com/services/auth/"))
(define-struct exn:flickr (method-name message code) #:transparent)
(define (raise-flickr-error method-name message code)
(raise (make-exn:flickr method-name message (string->number code))))
(define (flickr-true? x)
(cond ((string=? x "1") #t)
((string=? x "0") #f)
(else
(error "Expected 0 or 1"))))
(define (symbol<? s1 s2)
(string<? (symbol->string s1)
(symbol->string s2)))
(define (whitespace? s)
(andmap char-whitespace?
(string->list s)))
(define tree-filter
(let ((none (cons 'none empty)))
(λ (p? t)
(cond [(cons? t)
(let ((lft (tree-filter p? (car t))))
(if (eq? lft none)
(tree-filter p? (cdr t))
(cons lft (tree-filter p? (cdr t)))))]
[else
(if (p? t)
none
t)]))))
(define (scrub xexpr)
(tree-filter (λ (x) (and (string? x)
(whitespace? x)))
xexpr))
(define (string->response str)
(scrub (string->xexpr str)))
(define (invoke-method/signed sec args)
(invoke-method (cons (cons 'api_sig (sign sec args)) args)))
(define (invoke-method args)
(let* ((response
(document-element
(call/input-url (apply method-url args) get-pure-port read-xml))))
(match (scrub (xml->xexpr response))
((list-rest 'rsp (list (list 'stat "ok")) elements) elements)
((list 'rsp
(list (list 'stat "fail"))
(list 'err (list (list 'code error-code)
(list 'msg message))))
(raise-flickr-error (cond [(assoc 'method args) => (match-lambda [(cons 'method m) m])]
[else #f])
message
error-code))
(_ (error "Unkown response")))))
(define (signature-string sec ak)
(string-append sec
(foldl (λ (s+v str)
(string-append str
(symbol->string (car s+v))
(cdr s+v)))
""
(sort ak (λ (p1 p2) (symbol<? (car p1) (car p2)))))))
(define (md5/utf-8 str)
(bytes->string/utf-8 (md5 (string->bytes/utf-8 str))))
(define (sign sec ak)
(md5/utf-8 (signature-string sec ak)))
(define (url/query base-url q)
(struct-copy url base-url [query q]))
(define (authorize-url sec . args)
(url/query auth-url
(append args (list (cons 'api_sig (sign sec args))))))
(define (method-url . arguments)
(url/query meth-url arguments))
(require schemeunit)
(define-simple-check (check-url-is url str)
(string=? (url->string url) str))
(check-url-is (url/query (string->url "http://foo/")
'((f . "x")
(g . "y")))
"http://foo/?f=x&g=y")
(check-url-is (url/query (string->url "http://foo/?f=x&g=y")
empty)
"http://foo/")
(check equal?
(signature-string "SECRET"
'((foo . "1")
(bar . "2")
(baz . "3")))
"SECRETbar2baz3foo1")
(check string=?
(signature-string "000005fab4534d05" '((perms . "write")
(api_key . "9a0554259914a86fb9e7eb014e4e5d52")))
"000005fab4534d05api_key9a0554259914a86fb9e7eb014e4e5d52permswrite")
(check string=?
(md5/utf-8 "000005fab4534d05api_key9a0554259914a86fb9e7eb014e4e5d52permswrite")
"a02506b31c1cd46c2e0b6380fb94eb3d")
(check-url-is
(authorize-url "000005fab4534d05"
'(api_key . "9a0554259914a86fb9e7eb014e4e5d52")
'(perms . "write"))
"http://www.flickr.com/services/auth/?api_key=9a0554259914a86fb9e7eb014e4e5d52&perms=write&api_sig=a02506b31c1cd46c2e0b6380fb94eb3d")
(check equal?
(invoke-method '((method . "flickr.test.echo")
(api_key . "138427ce2d97d6a2d0c4a2f045a59bfa")))
'((method () "flickr.test.echo")
(api_key () "138427ce2d97d6a2d0c4a2f045a59bfa")))
(provide (struct-out exn:flickr)
(struct-out argument-info)
(struct-out method-info)
(struct-out error-info))
(provide invoke-method
invoke-method/signed
authorize-url
method-url
string->response
flickr-true?)