cl-memstore 1.1.0-1 / usr / share / common-lisp / source / memstore / src / memstore.lisp

;; -*- Mode: Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FILE IDENTIFICATION
;;
;; Name:          memstore.lisp
;; Purpose:       Memstore primary functions
;; Date Started:  July 2011
;;
;; Copyright (c) 2011 Kevin M. Rosenberg
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. Neither the name of the author nor the names of the contributors
;;    may be used to endorse or promote products derived from this software
;;   without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;; SUCH DAMAGE.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package #:memstore)

(defconstant +flag-wstring+  (ash 1 0)
  "Bit set if stored with write-to-string.")
(defconstant +flag-clstore+ (ash 1 1)
  "Bit set if stored with cl-store.")
(defconstant +flag-zlib+ (ash 1 2)
  "Bit set if data compressed with zlib.")

(defvar *compression-savings* 0.20
  "Compression required before saving compressed value.")
(defvar *compression-enabled* t
  "Determines if compression is enabled.")
(defvar *compression-threshold* 5000
  "Minimum size of object before attempting compression.")
(defvar *debug* nil
  "Controls output of debugging messages.")
(defvar *namespace* "ms:"
  "String to prepend to keys for memcache. Default is 'ms:'.")
(defvar *encoding* (flex:make-external-format :utf-8)
  "Character encoding to use with converting strings to octets.")


(defun serialize-clstore (obj)
  "Converts a Lisp object into a vector of octets using CL-STORE."
  (let ((s (make-in-memory-output-stream :element-type 'octet)))
    (cl-store:store obj s)
    (get-output-stream-sequence s)))

(defun deserialize-clstore (data)
  "Restores a Lisp object from a vector of octets using CL-STORE."
  (let ((s (make-in-memory-input-stream data)))
    (cl-store:restore s)))

(defun serialize-string (obj)
  "Tries to write object to string, then convert to vector of octets
Catches error while using *print-readably*. Returns nil if unable to
 write to string."
  (let* ((*print-readably* t)
         (str (ignore-errors (write-to-string obj))))
    (when (stringp str)
      (flex:string-to-octets str :external-format *encoding*))))

(defun deserialize-string (str)
  (multiple-value-bind (obj pos)
      (read-from-string (flex:octets-to-string str :external-format *encoding*))
    (declare (ignore pos))
    obj))

(defun ms-serialize (obj &key (compression-enabled *compression-enabled*)
                        (compression-threshold *compression-threshold*))
  "Converts a lisp object into a vector of octets.
Returns a cons of (flags . data)."
  (let* ((flags 0)
         (data
           (cond
             ((stringp obj)
              (flex:string-to-octets obj :external-format :utf8))
             (t
              (let ((ser (serialize-string obj)))
                (etypecase ser
                  (vector
                   (setq flags (logior flags +flag-wstring+))
                   ser)
                 (null
                  (setq flags (logior flags +flag-clstore+))
                  (serialize-clstore obj)))))))
         (dlen (length data)))
    (when *debug*
      (format t "Compression enabled:~A compression-threshold:~A dlen:~D~%"
              compression-enabled compression-threshold dlen))
    (when (and compression-enabled compression-threshold
               (> dlen compression-threshold))
      (multiple-value-bind (compressed clen) (compress data)
        (when *debug*
          (format t "clen:~D cmin:~A~%" clen (* dlen (- 1 *compression-savings*))))
        (when (< clen (* dlen (- 1 *compression-savings*)))
          (setq data compressed)
          (setq flags (logior flags +flag-zlib+)))))
    (when *debug*
      (format t "flags:~D dlen:~D data:~S~%" flags (length data) data))
    (cons flags data)))

(defun ms-deserialize (ser)
  "Converts a cons of storage flags and vector of octets into a lisp object."
  (let ((flags (car ser))
        (data (cdr ser)))
    (when (plusp (logand flags +flag-zlib+))
      (setq data (uncompress data)))
    (cond
      ((plusp (logand flags +flag-clstore+))
       (deserialize-clstore data))
      ((plusp (logand flags +flag-wstring+))
       (deserialize-string data))
      (t
       (flex:octets-to-string data :external-format :utf8)))))


(defun make-key (key)
  "Prepends the *namespace* to a key."
  (concatenate 'string *namespace* key))

(defun remove-namespace (key)
  "Strips the current *namespace* from beginning of key."
  (subseq key (length *namespace*)))

(defun ms-store (key obj &key (memcache *memcache*) (command :set)
                            (exptime 0) (use-pool *use-pool*)
                            (compression-enabled *compression-enabled*)
                            (compression-threshold *compression-threshold*))
  "Stores an object in cl-memcached. Tries to print-readably object
to a string for storage. If unable to do so, uses cl-store to serialize
object. Optionally compresses value if meets compression criteria."
  (let ((ser (ms-serialize obj :compression-enabled compression-enabled
                            :compression-threshold compression-threshold)))
    (mc-store (make-key key) (cdr ser)
                           :memcache memcache
                           :command command :exptime exptime
                           :use-pool use-pool :flags (car ser))))

(defun get-objects (keys-list &key (memcache *memcache*) (use-pool *use-pool*)
                    (command :get))
  "Retrieves a list of objects from memcache from the keys in KEYS-LIST."
  (let ((items (mc-get
                (mapcar 'make-key keys-list)
                :memcache memcache
                :use-pool use-pool
                :command command)))
    (mapcar (lambda (item)
              (let ((key (first item))
                    (flags (second item))
                    (data (third item)))
                (ecase command
                  (:get
                   (list (remove-namespace key) (ms-deserialize (cons flags data))))
                  (:gets
                   (list (remove-namespace key) (ms-deserialize (cons flags data)) (fourth item))))))
            items)))

(defun ms-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
                   (command :get))
  "Lisp objects are restored by memcache server. A key, or list of keys,
is used to identify objects. Command is either :get or :gets. The latter
is used to get memcached's unique object number for storage with :cas."
  (let* ((multp (listp key-or-keys))
         (keys (if multp key-or-keys (list key-or-keys)))
         (items (get-objects keys :memcache memcache :use-pool use-pool
                                  :command command)))
    (if multp
        items
        (if items
            (let ((item (car items)))
              (ecase command
                (:get
                 (values (second item) t))
                (:gets
                 (values (second item) t (third item)))))
            (values nil nil)))))

(defun ms-del (key &key (memcache *memcache*) (use-pool *use-pool*) (time 0))
  "Deletes a keyed object from memcache. Key is prepended with *namespace*."
  (mc-del (make-key key) :memcache memcache :use-pool use-pool :time time))

(defun ms-incr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
  "Increments a keyed integer object. Key is prepended with *namespace*."
  (mc-incr (make-key key) :memcache memcache :use-pool use-pool :delta delta))

(defun ms-decr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
  "Decrements a keyed integer object. Key is prepended with *namespace*."
  (mc-decr (make-key key) :memcache memcache :use-pool use-pool :delta delta))