;; Apache CouchDB view server
;;
;; Copyright (C) 2009 Moritz Heidkamp
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
;; as published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You can find a copy of the GNU Lesser General Public License at
;; http://www.gnu.org/licenses/

(use json environments data-structures srfi-1)

(define functions '())
(define config '())
(define map-results (make-parameter '()))
(define sandbox (environment-copy (scheme-report-environment 5) #f))

(for-each (lambda (def)
	    (environment-extend! sandbox (car def) (cdr def)))

	  `((void . ,void)
	    (null . ,(void))
	    (emit . ,(lambda (key value)
		       (map-results (cons (list key value) (map-results)))))
	    (ref  . ,(lambda (key doc)
		       (let ((pair (assoc (->string key) (vector->list doc))))
			 (and pair (cdr pair)))))
	    (log  . ,(lambda (message)
		       (json-write `(log ,message)) (newline)))))

(for-each (lambda (fun)
	    (environment-extend! sandbox (car fun) (eval (car fun))))
	  (receive (_ names _) (##sys#module-exports (alist-ref 'srfi-1 ##sys#module-table)) names))

(define (parse-function definition)
  (with-input-from-string definition read))

(define (reduce-results funs keys values rereduce)
  (let* ((result (with-output-to-string 
		   (cut json-write (map (lambda (fun)
					  (eval (list (parse-function fun) `(quote ,keys) `(quote ,values) rereduce) sandbox)) funs))))
	 (result-length (string-length result)))
    
    (if (and (alist-ref 'reduce_limit config)
	     (> result-length 200)
	     (> (* 2 result-length) current-commad-length))
	(write-error 'reduce_overflow_error 
		     (format "Reduce output must shrink more rapidly. 
Current output: '~A'... (first 100 of ~A bytes)" (substring result 0 100) result-length))
	(write-string (string-append "[true, " result "]")))))
(define commands
  `(("reset"     . ,(lambda (#!optional (new-config '#()))
		      (set! functions '())
		      (set! config (vector->list new-config))
		      (gc)
		      (json-write #t)))

    ("add_fun"   . ,(lambda (definition)
		      (set! functions (cons (parse-function definition) functions))
		      (json-write #t)))

    ("map_doc"   . ,(lambda (doc)
		      (parameterize ((map-results '()))
			(for-each (lambda (f) (eval (list f (list 'quote doc)) sandbox)) functions)
			(json-write (list (if (null? (map-results)) '(()) (map-results)))))))

    ("reduce"    . ,(lambda (funs results)
		      (reduce-results funs (map caar results) (map cadr results) #f)))

    ("rereduce"  . ,(cut reduce-results <> #f <> #t))))


(define (write-error error reason)
  (json-write `#((error . ,error) (reason . ,reason)))
  (newline))

(define current-commad-length 0)
(define (read-command)
  (and (not (eof-object? (peek-char)))
       (let ((line (read-line)))
	 (set! current-commad-length (string-length line))
	 (with-input-from-string line json-read))))

(call/cc (lambda (break)
	   (let loop ()
	     (condition-case 
	      (let ((command (read-command)))
		(unless command (break))

		(let ((handler (find (lambda (c) (string=? (car c) (car command))) commands)))
		  (if handler 
		      (begin
			(apply (cdr handler) (cdr command))

			(newline))
		      (display (format "unknown command: ~A" command) (current-error-port)))))
	      
	      (exn (syntax)
		   (write-error 'syntax_error ((condition-property-accessor 'exn 'message) exn)))
	      (exn ()
	      	   (let ((args ((condition-property-accessor 'exn 'arguments) exn))
	      		 (message ((condition-property-accessor 'exn 'message) exn)))

		     (if (and (pair? args) (pair? (car args)) (eq? 'json-parse-error (caar args)))
			 (write-error 'json_parse_error (->string (cdar args)))
			 (write-error 'general (format "~A: ~A" message args))))))

	     (flush-output)
	     (loop))))