;; 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 "")
           (lib "")
           (lib "")
           (lib "")
           (lib "")
           (lib "")
           (lib "" "xml")
           (lib "" "net")
           (lib "" "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 ""))
  (define auth-url (string->url ""))
  (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)
           (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 
             (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)
       (apply string-append
              (map (lambda (p) (string-append (keyword->string (car p)) (cdr p)))
                    (even-list->list-of-pairs ak)
                    (lambda (p1 p2) (keyword<? (car p1) (car p2))))))))))
  (define/kw (url/keyword-query base-url #:all-keys ak)
     url base-url
      (let loop ((ak ak) (accum '()))
          [(null? ak) (reverse accum)]
          [(not (cadr ak)) (loop (cddr ak) accum)]
           (loop (cddr ak)
                 (cons (cons (keyword->symbol (car ak))
                             (cadr ak))
  ;; 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
            (lambda (kw)
              (flat-named-contract (format "required keyword: ~a" kw)
                                   (lambda (args)
                                     (string? (keyword-get args kw)))))

   [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)
   [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.