#lang scheme
;; Method invocation for Flickr API.

(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 non-text-tags   (make-parameter '(rsp)))

(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)))
  
;; String -> Boolean
;; Is the string all whitespace?
(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)]))))

;; Eliminate all whitespace-only strings.
(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")))))

;; From the Flickr API:
;; The process of signing is as follows.
;;
;; * Sort your argument list into alphabetical order based on the parameter name.
;; * e.g. foo=1, bar=2, baz=3 sorts to bar=2, baz=3, foo=1
;; * concatenate the shared secret and argument name-value pairs
;; * e.g. SECRETbar2baz3foo1
;; * calculate the md5() hash of this string
;; * append this value to the argument list with the name api_sig, in hexidecimal string form
;; * e.g. api_sig=1f3870be274f6c49b3e31a0c6728957f

;; String [Listof [Pairof Symbol String]] -> String
(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)))))))


;; String -> String
;; MD5 on strings (using utf-8 bytes)
(define (md5/utf-8 str)
  (bytes->string/utf-8 (md5 (string->bytes/utf-8 str))))
     
;; String [Listof [Pairof Symbol String]] -> String
(define (sign sec ak)
  (md5/utf-8 (signature-string sec ak)))

;; URL [Listof [Pairof Symbol String]] -> URL
(define (url/query base-url q)
  (struct-copy url base-url [query q]))


;; authorize-url : String [Pairof Symbol String]] ... -> URL
;; Constructs an authorization URL.
(define (authorize-url sec . args)
  (url/query auth-url 
             (append args (list (cons 'api_sig (sign sec args))))))
 
;; method-url : [Pairof Symbol String]] ... -> URL
;; Constructs a method invocation URL.
(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")

;; Tests based on http://www.flickr.com/services/api/auth.howto.web.html
(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")

;; Test to invoke unsigned methods
(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?)