;; Apache CouchDB client library
;;
;; 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/

(module couchdb 
  (last-error make-connection connection-uri update-connection connection-database

   make-document document-id document-rev document-body update-document
   document-attribute document-attribute? document? json-ref

   get-view get-all-documents send-temp-view-request

   get-server-info get-document save-document delete-document 
   create-database delete-database get-database-info)


(import chicken scheme)

(require-library intarweb)
(import (rename intarweb (headers alist->headers)))

(use http-client json uri-common extras ports srfi-1 data-structures defstruct srfi-69 regex)

;; Whenever errors occur, a descriptive message can be accessed through last-error
(define last-error (make-parameter #f))

;; Internal mapping for couchdb error keys
(define errors '(("illegal_database_name" . "Illegal database name")))

;; Convenience method for setting and signalling an error (i.e. returning #f)
(define (last-error! e) 
  (last-error e) #f)

;; Signals a couchdb exception
(define (couchdb-error location message)
  (signal (make-composite-condition 
	   (make-property-condition 'exn 'message message 'location location)
	   (make-property-condition 'couchdb))))

;; Retrieves a field from a JSON object vector or hash-table
(define (json-ref name object) 
  (let* ([object (if (vector? object) (vector->list object) (hash-table->alist object))]
	 [pair (assoc (->string name) object)])
    (and pair (cdr pair))))

;; Parses a condition property as JSON
(define (condition-property->json e type property)
  (with-input-from-string (condition-property e type property) json-read))

;; Convenience function for accessing condition properties
(define (condition-property e type property)
  ((condition-property-accessor type property) e))

;; Appends path to the path of uri and returns the resulting uri
(define (uri-path-append uri . path)
  (let* ((old-path (uri-path uri))
	 (old-path (if (string=? "" (cadr old-path)) '(/) old-path)))
    (update-uri uri path: (append old-path (filter string? path)))))

;; Syntax for handling http-client client-errors by HTTP status code
(define-syntax handling-client-errors
  (syntax-rules ()
    ((_ exn statement handler1 handler2 ...)
     (condition-case statement
		     (exn (client-error)
			  (case (response-code (condition-property exn 'client-error 'response))
			    handler1 handler2 ...
			    (else (abort exn))))))))

(defstruct document id rev (body '#()))

(define (avector->document avector)
  (let* ([body (alist->hash-table 
		(map (lambda (p) (cons (string->symbol (car p))
				       (if (vector? (cdr p))
					   (avector->hash-table (cdr p)) (cdr p))))
		     (vector->list avector)))]
	 [id (hash-table-ref body '_id)]
	 [rev (hash-table-ref body '_rev)])

    (hash-table-delete! body '_id)
    (hash-table-delete! body '_rev)

    (make-document id:   id
		   rev:  rev
		   body: body)))

(define (avector->hash-table av)
  (alist->hash-table
   (map (lambda (p) (cons (string->symbol (car p))
			  (if (vector? (cdr p))
			      (avector->hash-table (cdr p)) (cdr p)))) (vector->list av))))

(define (document-attribute doc name)
  (hash-table-ref (document-body doc) name))

(define (document-attribute? doc name)
  (hash-table-exists? (document-body doc) name))

(defstruct connection 
  database
  (server (uri-reference "http://localhost:5984/")))

(define (connection-uri conn)
  (uri-path-append (connection-server conn) (connection-database conn)))

(define (assert-connection-database conn source)
  (unless (connection-database conn) (couchdb-error source "No database given")))

;; General request method with some couchdb specific error handling
(define (send-request request #!optional (input #f))
  (let* ((request (if (request? request) request (make-request uri: request)))
	 (request (update-request request minor: 0)))
    (condition-case (with-input-from-request request input json-read)
		   (exn (server-error)
			(let* ([body (condition-property->json exn 'server-error 'body)]
			       [error-key (and body (json-ref 'reason body))]
			       [error (assoc error-key errors)])
			  (if error
			      (last-error! (cdr error))
			      (signal exn)))))))

;; Fetches general information about the server
(define (get-server-info conn)
  (send-request (connection-server conn)))

;; Request method for the document API
(define (send-document-request conn #!key doc id rev send-body method (headers (alist->headers '())))
  (assert-connection-database conn 'send-document-request)

  (let* ([body (and send-body (with-output-to-string (cute json-write (document-body doc))))]
	 [rev (or rev (and (document? doc) (document-rev doc)))]
	 [id (or id (document-id doc))]
	 [headers (alist->headers '((content-type application/json)) headers)]
	 [headers (if body (alist->headers `((content-length ,(list (string-length body)))) headers) headers)]
	 [headers (if rev (alist->headers `((if-match (strong . ,rev))) headers) headers)])

    (handling-client-errors exn (send-request (make-request uri: (uri-path-append (connection-uri conn) id)
							    method: method 
							    headers: headers) body)

			    ((404) (last-error! (format "Document ~A doesn't exist in ~A" id 
							(uri->string (connection-uri conn))))))))

;; GETs the document with the given id
(define (get-document conn id)
  (let ((response (send-document-request conn id: id method: 'GET)))
    (and response (avector->document response))))


;; DELETEs the document with the given id and revision
(define (delete-document conn doc)
  (let ((id (and (not (document? doc)) doc)))
    (send-document-request conn doc: doc id: id method: 'DELETE)))


;; Saves the given document and returns it with updated id and revision
(define (save-document conn doc)
  (let ((response (send-document-request conn
					 send-body: #t
					 method: (if (document-id doc) 'PUT 'POST)
					 doc: doc)))

    (and response (update-document doc
				   id: (json-ref 'id response)
				   rev: (json-ref 'rev response)))))


(define (send-temp-view-request conn body #!optional (query '()))
  (send-request (make-request uri: (update-uri
                                    (uri-path-append
                                     (connection-uri conn) "_temp_view")
                                    query: query)
                              method: 'POST)
                (with-output-to-string (lambda () (json-write body)))))

;; Request method for the view API
(define (send-view-request conn view method #!key (query '()))
  (assert-connection-database conn 'send-view-request)
  
  (let ((uri (apply uri-path-append (cons (connection-uri conn) view))))
    (handling-client-errors exn
			    (send-request (make-request method: method
							uri: (update-uri uri query: query)))
			    
			    ((404) (last-error! (format "View ~A doesn't exist on ~A" 
							(uri->string (update-uri (uri-reference "") path: (cddr (uri-path uri))))
							(uri->string (connection-uri conn))))))))



(define (get-view conn view #!optional (query '()))
  (let* ((query (map (lambda (q) 
		       (cons (string->symbol (string-substitute* (symbol->string (car q)) '(("-" . "_")))) 
			     (with-output-to-string (lambda () (json-write (cdr q))))))
		     query))
	 (include-docs (any (compose (cut eq? 'include_docs <>) car) query))
	 (view (if (list? view) (append-map list '("_design" "_view") view) (list view)))
	 (result (send-view-request conn view 'GET query: query)))
    (and result 
	 (let ((result (vector->list result)))
	   (when include-docs
	     (alist-update! "rows" (map (lambda (row)
					  (list->vector (alist-update! "doc" (avector->document (alist-ref "doc" row string=?))
								       row string=?)))
					(map vector->list (alist-ref "rows" result string=?))) result string=?))
	   (list->vector result)))))


(define (get-all-documents conn #!optional (query '()))
  (get-view conn "_all_docs" query))


;; Request method for the database API
(define (send-database-request conn method)
  (assert-connection-database conn 'send-database-request)

  (handling-client-errors exn
			  (send-request (make-request uri: (connection-uri conn)
						      method: method))
			  
			  ((404) (last-error! (format "Database ~A doesn't exist on ~A" (connection-database conn) (uri->string (connection-server conn)))))))

;; Creates a new database of the given name
(define (create-database conn)
  (handling-client-errors exn (json-ref 'ok (send-database-request conn 'PUT))
			  ((412) (last-error! (format "Database ~A already exists on ~A" 
						      (connection-database conn)
						      (uri->string (connection-server conn)))))))

;; Deletes database of given name
(define (delete-database conn)
  (let ((result (send-database-request conn 'DELETE)))
    (and result (json-ref 'ok result))))

;; Retrieves information about the given database
(define (get-database-info conn)
  (send-database-request conn 'GET))

)