#lang scheme
(require (planet cce/scheme:7/planet)
(this-package-in method))
(provide (all-defined-out)
(all-from-out "method.ss"))
(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 (method-lambda-doc ais)
(apply append
'((#: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 api_key string? (current-api-key)))
`((,(string->keyword name)
,@(if optional?
`[,(string->symbol name) (or/c #f string?) #f]
`[,(string->symbol name) string?]))))])
ais)))
(define (make-method-documentation mi)
(match mi
[(struct method-info (name needs-login? needs-signing? required-perms
description response explaination arguments errors))
`(defproc (,(string->symbol name) ,@(method-lambda-doc arguments)) xexpr?
,description
(para "Flickr link: " ,(flickr-api-link name))
)]))