Welcome to the CHICKEN Scheme pasting service

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; REST Procedure Call
;;; Generates wrappers to REST-like HTTP APIs
;;;
;;;  Copyright (C) 2012, Andy Bennett
;;;  Copyright (C) 2013, Philip Kent
;;;  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
   make-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))
	     (uri/req  (second defn))
	     (writer   (third defn))
	     (reader   (fourth defn))
	     (header-reader (if (= 5 (length defn)) (fifth defn) #f)))
	;(list 'quote
	      `(define ,name
		 (make-method ,args ,uri/req ,writer ,reader ,header-reader))
	      ;)
	))))

(define-syntax make-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)))))
	     (args     (first defn))
	     (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))
	     (proc-args (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))
      	 (form-sep (form-urlencoded-separator))
	     (proc-args (if writer
			  `(,@proc-args body)
			  `(,@proc-args)))
	     (proc-args (if (not (null? params))
			  `(,@proc-args #!key ,@params)
			  `(,@proc-args))))
	(list 'quote
		 `(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 (parameterize ((form-urlencoded-separator ,form-sep)) (uri-reference uri/req)))))
			(method  (cond ((request? uri/req) (request-method uri/req))
				       (writer 'POST)
				       (else 'GET))))
		   (lambda ,proc-args
		     (let* (,@(if (not (null? uri-args))
			      `((uri (parameterize ((form-urlencoded-separator ,form-sep)) (update-uri uri path: (append (uri-path uri) (map ->string (list ,@uri-args))))))
				      ;(_ (pp (uri-path uri)))
			       )
			      '())
			   ,@(if (not (null? params))
			       `((uri (parameterize ((form-urlencoded-separator ,form-sep)) (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.
			   )
		       (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))))
				)))
	      )
	))))

)

; (load "rest") (import rest)
; (use intarweb uri-common medea oauth-client)
;  (define (call-with-input-request req wr re) (printf "req: ~A\n     ~A\n     ~A\nwr: ~A\nre: ~A\n" req (uri->string (request-uri req)) (request-method req) wr re))
; (define-method (account/info test #!key locale) "xxx" #f read-json)
;
;
;
; (pp (define-method (account/info test #!key locale) "xxx" #f read-json))