rest-bind hygeine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; REST Procedure Call
;;; Generates wrappers to REST-like HTTP APIs
;;;
;;;  Copyright (C) 2012, Andy Bennett
;;;  All rights reserved.
;;;
;;;  Redistribution and use in source and binary forms, with or without
;;;  modification, are permitted provided that the following conditions are met:
;;;
;;;  Redistributions of source code must retain the above copyright notice, this
;;;  list of conditions and the following disclaimer.
;;;  Redistributions in binary form must reproduce the above copyright notice,
;;;  this list of conditions and the following disclaimer in the documentation
;;;  and/or other materials provided with the distribution.
;;;  Neither the name of the author nor the names of its contributors may be
;;;  used to endorse or promote products derived from this software without
;;;  specific prior written permission.
;;;
;;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;;;  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;;  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;;  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
;;;  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;;  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;;;  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;;  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;;;  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;;;  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;;  POSSIBILITY OF SUCH DAMAGE.
;;;
;;; Andy Bennett , 2012/10/29
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module rest-bind
 (define-method)

(import chicken scheme)
(import-for-syntax chicken srfi-1)
(use data-structures)
(use intarweb uri-common)

; (define-method (name args...) endpoint writer reader #!optional header)
; -> if no writer is provided, generates a procedure (name #!optional args...)
;    otherwise generates a procedure (name body #!optional args...)
; endpoint is the URI provided for the API call
; writer is a procedure of one argument.
;   writer is called with body
;   writer should return something suitable for passing to
;   call-with-input-request
;     i.e. a string containing the raw data to send, an alist or a pair of
;     values: a procedure that accepts a port and writes the response data to
;     it and an alist of extra headers. If you supply a pair of values then do
;     not forget to include a content-length header in the accompanying alist.
(define-syntax define-method
  (ir-macro-transformer
    (lambda (expr inject compare)
      (assert (pair? expr))
      (let* ((proc (car expr))
	     (defn (cdr expr))
	     (_ (assert (list? defn)))
	     (_ (assert (or (= 4 (length defn)) (= 5 (length defn)))))
	     (sig      (first defn))
	     (name     (car sig))
	     (args     (cdr sig))
	     (pred     (lambda (x) (not (eqv? '#!key x))))
	     (params   (drop-while pred args))
	     (params   (if (null? params) params (cdr params)))
	     (uri-args  (take-while pred args))
	     (mutate-args (reverse
			    (fold (lambda (arg args)
				    (if (list? arg)
				      (cons
					`(,(first arg) (,(second arg) ,(first arg)))
					args)))
				  '() uri-args)))
	     (uri-args    (reverse
			    (fold (lambda (arg args)
				    (cons
				      (if (list? arg) (first arg) arg)
				      args))
				  '() uri-args)))
	     (proc-args (reverse
			  (fold (lambda (arg args)
				  (cond ((symbol? arg) (cons arg args))
					((string? arg) args)
					(else (abort (conc "Cannot handle " arg)))))
				'() uri-args)))
	     (uri/req  (second defn))
	     (writer   (third defn))
	     (reader   (fourth defn))
	     (header-reader (if (= 5 (length defn)) (fifth defn) #f))
	     (proc-args (if writer
			  `(,@proc-args body)
			  `(,@proc-args)))
	     (proc-args (if (not (null? params))
			  `(,@proc-args #!key ,@params)
			  `(,@proc-args))))
	;(list 'quote
	      `(define ,name
		 (let* ((writer  ,writer)
			,@(if header-reader `((header-reader ,header-reader)) '())
			(uri/req ,uri/req)
			(uri     (cond ((request? uri/req) (request-uri uri/req))
				       ((uri? uri/req) uri/req)
				       (else (uri-reference uri/req))))
			(req     (cond ((request? uri/req) uri/req)
				       (else (make-request method: (if writer 'POST 'GET)))))
			)
		   (lambda ,proc-args
		     (let* (,@(if (null? mutate-args) '() mutate-args)
			    ,@(if (not (null? uri-args))
			      `((uri (update-uri uri path: (append (uri-path uri) (map ->string (list ,@uri-args)))))
				      ;(_ (pp (uri-path uri)))
			       )
			      '())
			   ,@(if (not (null? params))
			       `((uri (update-uri uri query: (append (uri-query uri)
								     (list ,@(map (lambda (param)
										    ``(,',param . ,(if ,param
												     (->string ,param)
												     ,param)))
										  params))))))
				   '())
			   (req (update-request req uri: uri))
			   )


		       (fprintf (current-error-port) "\n\n\nREQUEST\n")
		       (write-request (update-request req port: (current-error-port)))
		       (fprintf (current-error-port) "\n")


		       (receive (reader uri response)
				(call-with-input-request req ,(if writer '(writer body) #f) ,reader)
				,(if header-reader
					'(values (header-reader (response-headers response)) reader (list uri response))
					'(values reader (list uri response))))
				))))
	      ;)
	))))

)

-----

(use http-client uri-common intarweb rest-bind medea)

(define-method (account/info (path (lambda (arg) (string-append "hello-" path)))) "https://api.dropbox.com/1/account/info" #f read-json)

(define-method (account/info (path (lambda (arg) (string-append "hello-" arg)))) "https://api.dropbox.com/1/account/info" #f read-json)