;; 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 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
;; General Public License for more details.
;;
;; You can find a copy of the GNU General Public License at
;; http://www.gnu.org/licenses/

(module couchdb 
  (server database last-error 

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

   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)

;; Default server URI and database name
(define server (make-parameter (uri-reference "http://localhost:5984/")))
(define database (make-parameter #f))

;; 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)
  (update-uri uri path: (append (uri-path uri) (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))))))))

;; Returns only the body of a http response since that is all we care about most of the time
(define-syntax returning-body
  (syntax-rules ()
    ((_ e) (receive (b u r) e b))))


(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))

;; General request method with some couchdb specific error handling
(define (send-request request #!optional (input #f))
  (condition-case (returning-body (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 #!optional (server (server)))
  (send-request server))


;; Request method for the document API
(define (send-document-request database server #!key doc id rev send-body method (headers (alist->headers '())))
  (unless database (couchdb-error 'send-document-request "No database given (neither argument nor parameter)"))

  (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 . ,(list rev))) headers) headers)])

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

			    ((404) (last-error! (format "Document ~A doesn't exist in ~A" id 
							(uri->string (uri-path-append server database))))))))

;; GETs the document with the given id
(define (get-document id #!optional (database (database)) (server (server)))
  (and-let* ([response (send-document-request database server id: id method: 'GET)])
    (avector->document response)))


;; DELETEs the document with the given id and revision
(define (delete-document doc #!optional (database (database)) (server (server)))
  (let ([id (and (not (document? doc)) doc)])
    (send-document-request database server doc: doc id: id method: 'DELETE)))


;; Saves the given document and returns it with updated id and revision
(define (save-document doc #!optional (database (database)) (server (server)))
  (let ([response (send-document-request database server 
					 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)))))


;; Request method for the database API
(define (send-database-request name server method)
  (unless name (couchdb-error 'send-database-request "No database given (neither argument nor parameter)"))

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

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

;; Deletes database of given name
(define (delete-database #!optional (name (database)) (server (server)))
  (let ([result (send-database-request name server 'DELETE)])
    (and result (json-ref 'ok result))))

;; Retrieves information about the given database
(define (get-database-info #!optional (name (database)) (server (server)))
  (send-database-request name server 'GET)))