#lang scheme
;; Flickr API.
(require "method.ss")

(provide (all-defined-out)
         #;(all-from-out "method.ss"))

;; #:auth-token is either optional or required on all methods.
;; #:api_sig is optional on all methods.

;; if parameter signed? is true, then method call signatures are
;; computed and attached.

(define (needs-auth-token? ais)
  (ormap (λ (ai) (and (string=? (argument-info-name ai) "auth_token")
                      (not (argument-info-optional? ai))))
         ais))

(define (method-lambda-spec ais)
  (apply append
         '(#:api_sig [api_sig #f])
         (if (needs-auth-token? ais)
             '()
             '(#:auth_token [auth_token #f]))
         (map (match-lambda 
                [(struct argument-info (name optional? description))
                 (if (string=? name "api_key")
                     `(#:api_key [api_key (current-api-key)])                             
                     `(,(string->keyword name) 
                       ,(if optional?
                            `[,(string->symbol name) #f]
                            (string->symbol name))))])
              ais)))

(define (method-apply-spec ais)
  (append (if (needs-auth-token? ais)
              '()
              `((,'unquote-splicing (if auth_token
                                        (,'quasiquote ((auth_token . (,'unquote auth_token))))
                                        '()))))
          (map (match-lambda
                 [(struct argument-info
                          ((app string->symbol name) optional? description))
                  (if optional?
                      `(,'unquote-splicing (if ,name
                                               (,'quasiquote ((,name . (,'unquote ,name))))
                                               '()))
                      `(,name . (,'unquote ,name)))])
               ais)))

(define (make-method-definition mi)
  (match mi
    [(struct method-info (name needs-login? needs-signing? required-perms 
                               description response explaination arguments errors))
     `(define (,(string->symbol name) ,@(method-lambda-spec arguments))
        ((if (or (signed?) ,needs-signing?)
             (let ((sec (current-sec-key)))
               (λ (args) (invoke-method/signed sec args)))
             invoke-method)             
         (,'quasiquote
          ((method . ,name)
           ,@(method-apply-spec arguments)))))]))
  
(define (flickr-api-link name)
  `(link ,(format "http://www.flickr.com/services/api/~a.html" name)
         ,name))

(define (flickr-api-explorer-link name)
  `(link ,(format "http://www.flickr.com/services/api/explore/?method=~a" name)
         ,name))

(define ((method-lambda-doc stx) ais) 
  #`((#:api_sig api_sig (or/c #f string?) #f)        
     #,@(if (needs-auth-token? ais)
            #'()
            #'((#:auth_token auth_token (or/c #f string?) #f)))
     #,@(map (match-lambda 
               [(struct argument-info (name optional? description))
                (if (string=? name "api_key")
                    #`(#:api_key #,(datum->syntax stx 'api_key) string? (#,(datum->syntax stx 'current-api-key)))
                    #`(#,(string->keyword name) 
                       #,@(if optional?
                              #`[#,(datum->syntax stx (string->symbol name)) (or/c #f string?) #f]
                              #`[#,(datum->syntax stx (string->symbol name)) string?])))])
             ais)))

(require xml)
(require (for-template scribble/manual scheme/base))
(require (for-label scheme xml))

;; SExpr -> Syntax
;; Converts given datum into a "pretty" syntax object:
;; uses pretty print to lay out the datum and the syntax
;; object contains the appropriate source location information.
(define (pretty-result sexpr)
   (let ((out (open-output-string)))
     (pretty-print sexpr out)
     (parameterize ((port-count-lines-enabled #t))
       (read-syntax #f (open-input-string (get-output-string out))))))

(define ((make-method-documentation stx) mi)
  (match mi
    [(struct method-info (name needs-login? needs-signing? required-perms 
                               description response explaination arguments errors))
     #`(defproc (#,(datum->syntax stx (string->symbol name))
                 #,@((method-lambda-doc stx) arguments)) 
         (listof xexpr?)
         #,description
         (itemlist
          #,@(map (λ (a) 
                    #`(item (scheme #,(datum->syntax stx (string->symbol (argument-info-name a))))
                            " --- "
                            #,(argument-info-description a)))
                  arguments))
         (para (bold "Authentication: "))
         (para "This method " #,(if needs-login? '(bold "needs") "does not need") " login.")
         (para "This method " #,(if needs-signing? '(bold "needs") "does not need") " signing.")
         #,@(if response
                #`((para (bold "Response: "))
                   (schemeblock
                    ;; Flickr emits buggy responses in their documentation.
                    #,(with-handlers ([(λ (_) #t) (λ (_) "MALFORMED RESPONSE")])
                        (pretty-result (list (string->response response))))))
                #'())
         #,(if explaination 
               #`(para (bold "Explanation: ") #,explaination)
               "")
         (para (bold "Error codes:"))
         (itemlist 
          #,@(map (λ (e) #`(item (scheme #,(string->number (error-info-code e)))
                                 " --- "
                                 (bold #,(error-info-msg e))
                                 ": "
                                 #,(error-info-explan e)))
                  errors))
         
         (para "Flickr API: " #,(flickr-api-link name))
         (para "API Explorer: " #,(flickr-api-explorer-link name)))]))