(module method mzscheme
(require (lib "match.ss")
(lib "struct.ss")
(lib "kw.ss")
(lib "list.ss")
(lib "md5.ss")
(lib "contract.ss")
(lib "xml.ss" "xml")
(lib "url.ss" "net")
(lib "uri-codec.ss" "net"))
(current-alist-separator-mode 'amp)
(define-struct argument-info (name optional? description))
(define-struct method-info
(name needs-login? needs-signing? required-perms
description response explaination arguments))
(define current-api-key (make-parameter "123")) (define current-sec-key (make-parameter "456")) (define meth-url (string->url "http://api.flickr.com/services/rest/?"))
(define auth-url (string->url "http://flickr.com/services/auth/?"))
(define sign-all? (make-parameter #f))
(define non-text-tags (make-parameter '(rsp)))
(define-struct exn:flickr (method-name message code) #f)
(define (raise-flickr-error method-name message code)
(raise (make-exn:flickr method-name message (string->number code))))
(define (required-argument method-name argument-name)
(error method-name "requires a ~a argument" argument-name))
(define (flickr-true? x)
(cond ((string=? x "1") #t)
((string=? x "0") #f)
(else
(error "Expected 0 or 1"))))
(define (keyword->symbol kw)
(string->symbol (keyword->string kw)))
(define remove-space
(lambda (element)
((eliminate-whitespace (non-text-tags) (lambda (x) x)) element)))
(define/kw (invoke-method #:all-keys args)
(if (sign-all?)
(apply invoke-method-signed args)
(apply invoke-method-unsigned args)))
(define/kw (invoke-method-signed #:all-keys args)
(apply invoke-method-unsigned #:api_sig (apply sign args) args))
(define/kw (invoke-method-unsigned #:all-keys args)
(let* ((response
(document-element
(call/input-url (apply method-url args) get-pure-port read-xml))))
(match (xml->xexpr (remove-space response))
(('rsp (('stat "ok")) . elements) elements)
(('rsp (('stat "fail")) ('err (('code error-code) ('msg message))))
(raise-flickr-error (keyword-get args #:method) message error-code))
(_ (error "Unkown response")))))
(define/kw (sign #:all-keys ak)
(bytes->string/utf-8
(md5
(string->bytes/utf-8
(apply string-append
(current-sec-key)
(map (lambda (p) (string-append (keyword->string (car p)) (cdr p)))
(sort
(even-list->list-of-pairs ak)
(lambda (p1 p2) (keyword<? (car p1) (car p2))))))))))
(define/kw (url/keyword-query base-url #:all-keys ak)
(copy-struct
url base-url
(url-query
(let loop ((ak ak) (accum '()))
(cond
[(null? ak) (reverse accum)]
[(not (cadr ak)) (loop (cddr ak) accum)]
[else
(loop (cddr ak)
(cons (cons (keyword->symbol (car ak))
(cadr ak))
accum))])))))
(define/kw (authorize-url #:all-keys args)
(let ((sig (apply sign #:api_key (current-api-key) args)))
(apply url/keyword-query auth-url #:api_key (current-api-key) #:api_sig sig args)))
(define/kw (method-url #:all-keys arguments)
(apply url/keyword-query meth-url arguments))
(define (even-list->list-of-pairs ls)
(let loop ((ls ls) (accum null))
(if (null? ls)
(reverse accum)
(loop (cddr ls)
(cons (cons (car ls) (cadr ls)) accum)))))
(define (required-keywords . kws)
(apply and/c
(map
(lambda (kw)
(flat-named-contract (format "required keyword: ~a" kw)
(lambda (args)
(string? (keyword-get args kw)))))
kws)))
(provide
[struct exn:flickr (method-name message code)]
[struct argument-info (name optional? description)]
[struct method-info
(name needs-login? needs-signing?
required-perms description
response explaination arguments)])
(provide sign)
(provide/contract
[flickr-true? (-> any/c boolean?)]
[sign-all? (parameter/c boolean?)]
[current-api-key (parameter/c string?)]
[current-sec-key (parameter/c string?)]
[non-text-tags (parameter/c (listof symbol?))]
[required-keywords (->* () (listof keyword?) (contract?))]
[invoke-method (->* () (required-keywords #:method #:api_key) ((listof xexpr?)))]
[invoke-method-signed (->* () (required-keywords #:method #:api_key) ((listof xexpr?)))]
[method-url (->* () (required-keywords #:method #:api_key) (url?))]
[authorize-url (->* () (required-keywords #:perms #:frob) (url?))])
)