montezuma-store.lisp

(defpackage :slacker.montezuma-store
  (:use :cl :alexandria :serapeum :fw.lu)
  (:export
   #:montezuma-store
   #:search-index
   #:retire-open-indices))
(in-package :slacker.montezuma-store)

(defclass montezuma-store ()
  ((%indexes :reader indexes
	     :initform (make-hash-table :test #'equal :synchronized t))
   (%montezuma-index-path :reader index-path
			  :initarg :index-path))
  (:default-initargs :index-path nil))

(defun retire-open-indices (client)
  (sb-ext:with-locked-hash-table ((indexes client))
    (let ((old-indexes (indexes client)))
      (setf (slot-value client '%indexes) 
	    (make-hash-table :test #'equal :synchronized t))
      (alexandria:maphash-values (lambda (v) (montezuma:close v)) 
				 old-indexes))))

(defun search-index (store index text)
  (let* ((index (ensure-index-for-type store index)))
    (values
     (montezuma:search index
		       (format nil "!text:\";arc\" text:~a" text)
		       :num-docs 3)
     index)))

(defun ensure-index-for-type (store type)
  (sb-ext:with-locked-hash-table ((indexes store))
    (ensure-gethash type (indexes store)
		   (if (index-path store)
		       (make-instance 'montezuma:index
				      :path (ensure-directories-exist
					     (format nil "~a/~a/"
						     (index-path store)
						     type))
				      :create-p nil
				      :create-if-missing-p t)
		       (make-instance 'montezuma:index)))))

(defgeneric combine-child (parent key value)
  (:method (parent k child)
    (setf (gethash k parent) child))
  (:method (parent k (child string))
    (setf (gethash k parent) child))
  (:method (parent k (children list))
    (combine-child parent k (coerce children 'vector)))
  (:method (parent k (children vector))
    (map nil
         (lambda (idx child)
           (combine-child parent
                          (concat k "::" (princ-to-string idx))
                          child))
         (iota (length children))
         children))
  (:method ((parent hash-table) k (child hash-table))
    (do-hash-table (sk sv child)
      (combine-child parent (concat k "::" sk) sv))))

(defun flatten-hash-table (hash-table)
  (let ((new (fw.lu:empty-hash-table-like hash-table)))
    (do-hash-table (k v hash-table new)
      (combine-child new k v))))

(defgeneric store-message (store message)
  (:method ((store montezuma-store) message)
    (let* ((type (gethash "type" message))
           (index (ensure-index-for-type store type)))
      (montezuma:add-document-to-index index
				       (flatten-hash-table message))
      (montezuma:flush index))))

(defmethod slacker:handle-message :before
    (type (event-pump montezuma-store) ts channel message)
  (declare (ignore type ts channel))
  (store-message event-pump message)
  (values))