;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 <andyjpb@knodium.com>, 2012/10/29
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module rest-bind
 (define-method)

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

; (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)))
	     (pos-args (take-while pred args))
	     (uri/req  (second defn))
	     (writer   (third defn))
	     (reader   (fourth defn))
	     (args     (if writer
			 `(,@pos-args body)
			 `(,@pos-args)))
	     (args     (if (not (null? params))
			 `(,@args #!key ,@params)
			 `(,@args))))
	;(list 'quote
	      `(define ,name
		 (let* ((writer  ,writer)
			(uri/req ,uri/req)
			(uri     (cond ((request? uri/req) (request-uri uri/req))
				       ((uri? uri/req) uri/req)
				       (else (uri-reference uri/req))))
			(method  (cond ((request? uri/req) (request-method uri/req))
				       (writer 'POST)
				       (else 'GET))))
		   (lambda ,args
		     (let* (,@(if (not (null? pos-args))
			      `((uri (update-uri uri path: (append (uri-path uri) (map ->string (list ,@pos-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 (make-request uri: uri method: method)) ; poke the args into query string.
			   )
		       (call-with-input-request req ,(if writer '(writer body) #f) ,reader)))))
	      ;)
	))))

)