#lang racket
;
; CouchDB interface.
;

; Our dependencies.
(require net/url
         net/head
         net/uri-codec
         (planet dherman/json:3:0))

; CouchDB server specification.
(define-struct/contract
  couchdb-server ((host string?)
                  (port exact-nonnegative-integer?)
                  (user (or/c string? false?))
                  (password (or/c string? false?))))

; Database specification.
(define-struct/contract
  couchdb-database ((server couchdb-server?)
                    (name string?)))

; Our exceptions.
(define-struct (exn:couchdb exn) (error url doc))
(define-struct (exn:couchdb:not-found exn:couchdb) ())
(define-struct (exn:couchdb:conflict exn:couchdb) ())

; Exception map.
(define exn-map #hasheq(('not_found   . make-exn:couchdb:not-found)
                        ('conflict    . make-exn:couchdb:conflict)))

; Export functions that already have contracts defined.
(provide
  couchdb-server?
  couchdb-database?
  exn:couchdb?
  exn:couchdb:conflict?
  exn:couchdb:not-found?)

; Exports functions with contracts.
(provide (contract-out
           (couchdb-connect (->* ()
                                 (#:host string?
                                  #:port exact-nonnegative-integer?
                                  #:user (or/c string? #f)
                                  #:password (or/c string? #f))
                                 couchdb-server?))

           (couchdb-db (-> couchdb-server?
                           string?
                           couchdb-database?))

           (couchdb-get (->* (couchdb-database?
                              string?)
                             (#:rev (or/c string?
                                          (symbols 'current))
                              #:open-revs (or/c (symbols 'all 'current)
                                                (listof string?))
                              #:revs-info? boolean?
                              #:conflicts? boolean?)
                             (and/c jsexpr? hash?)))

           (couchdb-put (-> couchdb-database?
                            (and/c jsexpr? hash?)
                            (and/c jsexpr? hash?)))

           (couchdb-delete (-> couchdb-database?
                               (and/c jsexpr? hash?)
                               (and/c jsexpr? hash?)))

           (couchdb-view (->* (couchdb-database?
                               (list/c string? string?))
                              (#:include-docs? boolean?
                               #:key (or/c jsexpr? void?)
                               #:startkey (or/c jsexpr? void?)
                               #:startkey-docid (or/c jsexpr? void?)
                               #:endkey (or/c jsexpr? void?)
                               #:endkey-docid (or/c jsexpr? void?)
                               #:limit (or/c exact-nonnegative-integer? void?)
                               #:stale (or/c (symbols 'ok 'update-after) void?)
                               #:descending? boolean?
                               #:skip exact-nonnegative-integer?
                               #:group? boolean?
                               #:group-level (or/c exact-nonnegative-integer?
                                                   void?)
                               #:reduce? (or/c boolean? void?)
                               #:inclusive-end? boolean?
                               #:update-seq? boolean?)
                              jsexpr?))))

;
; Creates new CouchDB connection.
;
; In reality, this merely sets up a strucure with info for
; each connection done through it.
;
(define (couchdb-connect #:host (host "localhost")
                         #:port (port 5984)
                         #:user (user #f)
                         #:password (password #f))
  (make-couchdb-server host port user password))

;
; Select specific CouchDB database to perform CRUD on.
;
(define (couchdb-db server name)
  (make-couchdb-database server name))

; Creates URL pointing to a database document.
(define (make-document-url db id (query null))
  (let ((server (couchdb-database-server db))
        (dbname (uri-encode (couchdb-database-name db))))
    (make-url "http"
              (couchdb-server-user server)
              (couchdb-server-host server)
              (couchdb-server-port server)
              #t
              (list (make-path/param dbname null)
                    (make-path/param (uri-encode id) null))
              query
              #f)))

; Creates URL pointing to a database view.
(define (make-view-url db view (query null))
  (let ((server (couchdb-database-server db))
        (dbname (uri-encode (couchdb-database-name db)))
        (design (uri-encode (car view)))
        (view   (uri-encode (cadr view))))
    (make-url "http"
              (couchdb-server-user server)
              (couchdb-server-host server)
              (couchdb-server-port server)
              #t
              (list (make-path/param dbname null)
                    (make-path/param "_design" null)
                    (make-path/param design null)
                    (make-path/param "_view" null)
                    (make-path/param view null))
              query
              #f)))

; Encodes open_revs argument.
(define (encode-open-revs open-revs)
  (if (symbol? open-revs)
    (uri-encode (symbol->string open-revs))
    (jsexpr->json open-revs)))

; Raise proper exception.
(define (raise-error ccm doc method url)
  (let* ((error (hash-ref doc 'error))
         (reason (string-append "CouchDB " method " " (url->string url)
                                "\n        " error
                                ": " (hash-ref doc 'reason))))
    (if (hash-has-key? exn-map error)
      (raise ((hash-ref exn-map 'error) reason ccm error url doc))
      (raise (make-exn:couchdb reason ccm error url doc)))))

; Gets document from DB.
(define (get-document url)
  (let* ((port (get-pure-port url))
         (doc (read-json port)))
    (if (or (hash-has-key? doc '_id)
            (hash-has-key? doc 'total_rows))
      doc
      (raise-error (current-continuation-marks) doc "GET" url))))

; Puts new document/revision to DB.
(define (put-document url data)
  (let* ((port (put-pure-port url data))
         (doc (read-json port)))
    (if (hash-has-key? doc 'ok)
      doc
      (raise-error (current-continuation-marks) doc "PUT" url))))

; Deletes document from DB.
(define (delete-document url)
  (let* ((port (delete-pure-port url))
         (doc (read-json port)))
    (if (hash-has-key? doc 'ok)
      doc
      (raise-error (current-continuation-marks) doc "DELETE" url))))

;
; Returns document associated with given ID from given database.
;
(define (couchdb-get db id
                     #:rev (rev 'current)
                     #:open-revs (open-revs 'current)
                     #:revs-info? (revs-info? #f)
                     #:conflicts? (conflicts? #f))

  ; Parameter list.
  (define params null)

  ; Adds new parameter.
  (define (add-param name value)
    (set! params (cons (cons name value) params)))

  ; Include revision if not 'current
  (or (equal? rev 'current)
      (add-param 'rev rev))

  ; Include open_revs if 'all or list of names.
  (or (equal? open-revs 'current)
      (add-param 'open_revs (encode-open-revs open-revs)))

  ; Include revs_info if true.
  (and revs-info?
       (add-param 'revs_info "true"))

  ; Include conflicts if true.
  (and conflicts?
       (add-param 'conflicts "true"))

  ; Perform the request and return result.
  (let* ((url (make-document-url db id params)))
    (get-document url)))

;
; Stores new document or revision in the database.
;
(define (couchdb-put db document)
  (let* ((id  (hash-ref document '_id))
         (url (make-document-url db id)))
    (put-document url (string->bytes/utf-8 (jsexpr->json document)))))

;
; Deletes given document from the database.
;
(define (couchdb-delete db document)
  (let* ((id  (hash-ref document '_id))
         (rev (hash-ref document '_rev))
         (url (make-document-url db id `((rev . ,rev)))))
    (delete-document url)))

(define (couchdb-view db view #:include-docs? (include-docs? #f)
                              #:key (key (void))
                              #:startkey (startkey (void))
                              #:startkey-docid (startkey-docid (void))
                              #:endkey (endkey (void))
                              #:endkey-docid (endkey-docid (void))
                              #:limit (limit (void))
                              #:stale (stale (void))
                              #:descending? (descending? #f)
                              #:skip (skip 0)
                              #:group? (group? #f)
                              #:group-level (group-level (void))
                              #:reduce? (reduce? (void))
                              #:inclusive-end? (inclusive-end? #t)
                              #:update-seq? (update-seq? #f))
  ; Parameters for the request.
  (define params null)

  ; Adds new parameter.
  (define (add-param name value)
    (set! params (cons (cons name value) params)))

  ; Shall we include document bodies?
  (and include-docs?
       (add-param 'include_docs "true"))

  ; Key, if defined.
  (or (void? key)
      (add-param 'key (jsexpr->json key)))

  ; Starting key, if defined.
  (or (void? startkey)
      (add-param 'startkey (jsexpr->json startkey)))

  ; Starting key's document id, if defined.
  (or (void? startkey-docid)
      (add-param 'startkey_docid (jsexpr->json startkey-docid)))

  ; Ending key, if defined.
  (or (void? endkey)
      (add-param 'endkey (jsexpr->json endkey)))

  ; Ending key's document id, if defined.
  (or (void? endkey-docid)
      (add-param 'endkey_docid (jsexpr->json endkey-docid)))

  ; Limit, if defined.
  (or (void? limit)
      (add-param 'limit (number->string limit)))

  ; Stale view handling, if defined.
  (or (void? stale)
      (add-param 'stale (if (equal? stale 'ok) "ok" "update_after")))

  ; Reverse output order?
  (and descending?
       (add-param 'descending "true"))

  ; Number of items to skip.
  (and (> skip 0)
       (add-param 'skip (number->string skip)))

  ; Grouping, if enabled.
  (and group?
       (add-param 'group "true"))

  ; Grouping level, if enabled.
  (or (void? group-level)
      (add-param 'group_level (number->string group-level)))

  ; Reduce toggle, if defined.
  (or (void? reduce?)
      (add-param 'reduce (if reduce? "true" "false")))

  ; Inclusive end, if disabled.
  (or inclusive-end?
      (add-param 'inclusive_end "false"))

  ; Include sequence number?
  (and update-seq?
       (add-param 'update_seq "true"))

  (let* ((url (make-view-url db view params)))
    (get-document url)))

; vim:set ts=2 sw=2 et: