#lang scheme
;; Method invocation for Flickr API.

(require file/md5

(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)

(define meth-url (string->url ""))
(define auth-url (string->url ""))
(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)
         (error "Expected 0 or 1"))))

(define (symbol<? s1 s2)
  (string<? (symbol->string s1)
            (symbol->string s2)))
(define remove-space
  (lambda (element)
    ((eliminate-whitespace (non-text-tags) (lambda (x) x)) element)))
(define (invoke-method/signed sec args)
  (invoke-method (cons (cons 'api_sig (sign sec args)) args)))

(define (invoke-method args)
  (let* ((response 
           (call/input-url (apply method-url args) get-pure-port read-xml))))
    (match (xml->xexpr (remove-space 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])
      (_ (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")))

(check-url-is (url/query (string->url "http://foo/?f=x&g=y") 

(check equal?
       (signature-string "SECRET"
                         '((foo . "1") 
                           (bar . "2")
                           (baz . "3")))

;; Tests based on
(check string=?
       (signature-string "000005fab4534d05" '((perms . "write")
                                              (api_key . "9a0554259914a86fb9e7eb014e4e5d52")))       

(check string=?
       (md5/utf-8 "000005fab4534d05api_key9a0554259914a86fb9e7eb014e4e5d52permswrite")

 (authorize-url "000005fab4534d05"
                '(api_key . "9a0554259914a86fb9e7eb014e4e5d52")
                '(perms . "write"))

;; 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