Radiance MongoDB Interface

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;MONGO.LISP;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
  This file is a part of TyNETv5/Radiance
  (c) 2013 TymoonNET/NexT http://tymoon.eu (shinmera@tymoon.eu)
  Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(defpackage radiance-mod-mongo
  (:use :cl :radiance :cl-mongo)
  (:export :mongodb
           :mongo-data-model))

(in-package :radiance-mod-mongo)

(defmodule mongodb (database)
  "Database implementation for MongoDB"
  (:name "MongoDB Binding" :author "Nicolas Hafner" :version "0.0.1" :license "Artistic" :url "http://tymoon.eu")
  (dbinstance :initform NIL :initarg dbinstance :accessor dbinstance))

(implement 'database (get-module 'mongodb))

(defmethod db-connect ((db mongodb) dbname &key (host (config-tree :database :host))
                                             (port (config-tree :database :port))
                                             (user (config-tree :database :user))
                                             (pass (config-tree :database :pass)))
  "Connects to the mongodb."
  (if (not host) (setf host *mongo-default-host*))
  (if (not port) (setf port *mongo-default-port*))
  (log:info "Connecting to mongoDB on ~a:~a" host port)
  (let ((mongo (mongo :db dbname :port port :host host)))
    (setf (dbinstance db) mongo)
    (when (and user pass)
      (log:info "Authenticating with ~a/~a" user pass)
      (db.auth user pass))
    (log:info "Switching database to ~a" dbname)
    (db.use dbname)))

(defmethod db-disconnect ((db mongodb) &key)
  "Disconnects from mongodb."
  (mongo-close :default)
  (setf (dbinstance db) NIL))

(defmethod db-connected-p ((db mongodb) &key)
  "Returns T if a connection exists, NIL otherwise."
  (if (dbinstance db) T NIL))

(defmethod db-collections ((db mongodb) &key)
  "Returns a list of all collection names available in the database."
  (db.collections))

(defmethod db-create ((db mongodb) (collection string) &key indices)
  "Creates a new collection on the database. Optionally a list of indexed fields can be supplied."
  (db.create-collection collection)
  (loop for index in indices
     do (destructuring-bind (keys &key drop-duplicates unique) index
          (db.ensure-index collection keys :drop-duplicates drop-duplicates :unique unique))))

(defmethod db-select ((db mongodb) (collection string) query &key (skip 0) (limit 0) sort)
  "Select data from the collection. Using the iterate function is generally faster."
  (db-iterate db collection query #'document->alist :skip skip :limit limit :sort sort))

(defmethod db-iterate ((db mongodb) (collection string) query function &key (skip 0) (limit 0) sort)
  "Iterate over a set of data. The collected return values are returned."
  (if sort (setf query (kv (kv "query" query) (kv "orderby" (alist->document sort)))))
  (let ((result (db.find collection query :limit limit :skip skip)))
    (multiple-value-bind (iterator collection docs) (cl-mongo::db.iterator result)
      (loop
         for next = '(NIL (0 1)) then (db.next collection iter)
         for iter = iterator then (nth-value 0 (cl-mongo::db.iterator next))
         for idocs = docs then (append idocs (second next))
         until (zerop (length (second next)))
         finally (setf docs idocs))
      (loop for doc in docs collect (funcall function doc)))))

(defmethod db-insert ((db mongodb) (collection string) data &key)
  "Insert data into the collection using the rows/fields provided in data."
  (db.insert collection (alist->document data)))

(defmethod db-remove ((db mongodb) (collection string) query &key (skip 0) (limit 0))
  "Remove data from the collection that matches the query. Note that if skip or limit are supplied, the delete operation will be pretty slow due to having to use a select and a remove for each match."
  (if (= 0 skip limit)
      (db.delete collection query)
      (cl-mongo:rm collection (iter (db.find collection query :limit limit :skip skip)))))

;@todo for some reason it won't accept the data document????
(defmethod db-update ((db mongodb) (collection string) query data &key (skip 0) (limit 0) insert-inexistent)
  "Update all rows that match the query with the new data. Note that if skip or limit are supplied, the update operation will be pretty slow due to having to use a select and an update for each match."
  (if (= 0 skip limit)
      (db.update collection query (alist->document data) :multi T :upsert insert-inexistent)
      (let ((docs (docs (db.find collection query :limit limit :skip skip))))
        (if (= 0 (length docs))
            (db.insert collection data)
            (loop for doc in docs do (db.update collection doc data))))))

(defmethod db-apropos ((db mongodb) (collection string) &key)
  "Always returns NIL as any field or type is allowed in MongoDB."
  NIL)

(defun document->alist (document)
  "Turns a document into an alist."
  (%document->alist document))

(defgeneric %document->alist (value))
(defmethod %document->alist (value) value)
(defmethod %document->alist ((value cl-mongo:document))
  (loop with alist = ()
     with map = (cl-mongo::elements value)
     for key being the hash-keys of map
     for val being the hash-values of map
     do (setf alist (acons key (%document->alist val) alist))
     finally (return alist)))

(defun alist->document (alist)
  "Turns an alist into a document."
  (loop with doc = (make-document)
     for (key . val) in alist
     do (add-element key (%alist->document val) doc)
     finally (return doc)))

(defgeneric %alist->document (value))
(defmethod %alist->document (value) value)
(defmethod %alist->document ((value cons))
  (if (listp (cdr value))
      (loop for val in value collect (%alist->document val))
      (add-element (car value) (%alist->document (cdr value)) (make-document))))

(defmacro query (&rest funcs)
  "Construct a query parameter. See the spec for more information on how to use it."
  (case (length funcs)
    (0 'all)
    (1 (%query-part (car (first funcs)) (cdr (first funcs))))
    (otherwise (kv "$and" (loop for func in funcs collect (%query-part (car func) (cdr func)))))))

(defgeneric %query-part (func args))

(defmethod %query-part ((func symbol) args)
  (error "Function ~a unknown." func))

(defmethod %query-part ((func (eql 'or)) args)
  (kv "$or" (loop for func in args collect (%query-part (car func) (cdr func)))))

(defmethod %query-part ((func (eql 'and)) args)
  (kv "$and" (loop for func in args collect (%query-part (car func) (cdr func)))))

(defmethod %query-part ((func (eql 'not)) args)
  ($not (%query-part (car args) (cdr args))))

(defmethod %query-part ((func (eql '=)) args)
  (kv (first args) (second args)))

(defmethod %query-part ((func (eql '!=)) args)
  ($!= (first args) (second args)))

(defmethod %query-part ((func (eql '>)) args)
  ($> (first args) (second args)))

(defmethod %query-part ((func (eql '<)) args)
  ($< (first args) (second args)))

(defmethod %query-part ((func (eql '>=)) args)
  ($>= (first args) (second args)))

(defmethod %query-part ((func (eql '<=)) args)
  ($<= (first args) (second args)))

(defmethod %query-part ((func (eql 'in)) args)
  ($in (first args) (second args)))

(defmethod %query-part ((func (eql '!in)) args)
  ($!in (first args) (second args)))

(defmethod %query-part ((func (eql 'matches)) args)
  ($/ (first args) (second args)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;DATA-MODEL.LISP;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
  This file is a part of TyNETv5/Radiance
  (c) 2013 TymoonNET/NexT http://tymoon.eu (shinmera@tymoon.eu)
  Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package :radiance-mod-mongo)

(defclass mongo-data-model (data-model)
  ((document :initarg :document :initform (make-document :oid T) :accessor document)
   (collection :initarg :collection :initform (error "Collection required") :accessor collection))
  (:documentation "Datamodel for mongodb."))

(defmethod print-object ((model mongo-data-model) out)
  (print-unreadable-object (model out :type T)
    (if (collection model)
        (format out "~a" (collection model))
        (format out "STUB"))))

(implement 'data-model (make-instance 'mongo-data-model :collection NIL :document NIL))

(defmethod model-field ((model mongo-data-model) (field string) &key)
  "Get the value of a field in the document."
  (gethash field (cl-mongo::elements (document model))))

(defun model-field-set (model field value)
  "Set the value of a field in the document."
  (setf (gethash field (cl-mongo::elements (document model))) value))

(defmethod model-get ((model mongo-data-model) (collection string) query &key (skip 0) (limit 0) sort)
  "Get a model for each document in the query result."
  (db-iterate
   (implementation 'database) collection query
   (lambda (doc) (make-instance 'mongo-data-model :collection collection :document doc))
   :sort sort :limit limit :skip skip))

(defmethod model-get-one ((model mongo-data-model) (collection string) query &key (skip 0) sort)
  "Get a model of the first result in the query."
  (if sort (setf query (kv (kv "query" query) (kv "orderby" (alist->document sort)))))
  (make-instance
   'mongo-data-model :collection collection
   :document (first (docs (iter (db.find collection query :skip skip))))))

(defmethod model-hull ((model mongo-data-model) (collection string) &key)
  "Create an empty model."
  (make-instance 'mongo-data-model :collection collection))

(defmethod model-save ((model mongo-data-model) &key)
  "Save an existing model."
  (assert (not (eq (doc-id (document model)) T)) () "Model has not been inserted before.")
  (db.save (collection model) (document model)))

(defmethod model-delete ((model mongo-data-model) &key)
  "Delete an existing model."
  (assert (not (eq (doc-id (document model)) T)) () "Model has not been inserted before.")
  (db.delete (collection model) (kv "_id" (doc-id (document model)))))

(defmethod model-insert ((model mongo-data-model) &key (clone T))
  "Insert the given model as a new entry and return it. If clone is T, a new copy of the document is created and the original is left untouched."
  (let ((model (make-instance 'mongo-data-model :collection (collection model)
                              :document (if clone (clone-document (document model)) (document model)))))
    (db.insert (collection model) (document model))
    model))

(defmacro with-fields ((&rest fields) model &rest body)
  "Lets you access fields directly by name. This is the same stuff as with-accessors or with-slots."
  (let ((vargens (gensym "MODEL")))
    `(let ((,vargens ,model))
       (symbol-macrolet ,(loop for field in fields collect `(,field (model-field ,vargens ,(string-downcase (symbol-name field)))))
         ,@body))))

(defsetf model-field model-field-set)

(defgeneric clone-document (var))

(defmethod clone-document (var) var)

(defmethod clone-document ((var cons))
  (if (listp (cdr var))
      (loop for item in var collect (clone-document item))
      (cons (car var) (clone-document (cdr var)))))

(defmethod clone-document ((document document))
  (let ((doc (make-document)))
    (setf (cl-mongo::elements doc)
          (clone-document (cl-mongo::elements document)))
    doc))

(defmethod clone-document ((table hash-table))
  (loop with trg = (make-hash-table :test 'equal)
       for key being the hash-keys of table
       for val being the hash-values of table
       do (setf (gethash key trg) (clone-document val))
       finally (return trg)))