method.ss
;; Method invocation for Flickr API.

;; Copyright (c) 2007 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; (at dvanhorn (dot cs brandeis edu))

(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"))  ;; A bogus API key.
  (define current-sec-key (make-parameter "456"))  ;; A bogus secret key.
  (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)))
  
  ;; invoke-method-signed : #:method String #:api_key String Arg ... -> Response
  ;; Invokes method on signed arguments.
  ;;   (invoke-method-signed Arg ...)
  ;;   ===>
  ;;   (invoke-method-unsigned Arg ... (sign Arg ...))
  (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")))))
  
  ;; sign : Arg ... -> String
  ;; Signs the method arguments.
  ;; A signature is constructed by concatinating the secret key,
  ;; each argument name and value pair (in lexicographic sorted
  ;; order based on argument name), then hashing with MD5.
  (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))])))))
  
  ;; authorize-url : #:perms String #:frob String -> URL
  ;; Constructs an authorization URL.
  (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)))
  
  ;; method-url : #:method String #:api-key String Arg ... -> URL
  ;; Constructs a method invocation URL.
  (define/kw (method-url #:all-keys arguments)
    (apply url/keyword-query meth-url arguments))
    
  
  ;; List utilities
  (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)))))
  
  ;; Contract utilities
  (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?))])
  
  ) ;; end of module method.