src/memstore.lisp

   1 ;; -*- Mode: Lisp -*-
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;; FILE IDENTIFICATION
   4 ;;
   5 ;; Name:          memstore.lisp
   6 ;; Purpose:       Memstore primary functions
   7 ;; Date Started:  July 2011
   8 ;;
   9 ;; Copyright (c) 2011 Kevin M. Rosenberg
  10 ;; All rights reserved.
  11 ;;
  12 ;; Redistribution and use in source and binary forms, with or without
  13 ;; modification, are permitted provided that the following conditions
  14 ;; are met:
  15 ;; 1. Redistributions of source code must retain the above copyright
  16 ;;    notice, this list of conditions and the following disclaimer.
  17 ;; 2. Redistributions in binary form must reproduce the above copyright
  18 ;;    notice, this list of conditions and the following disclaimer in the
  19 ;;    documentation and/or other materials provided with the distribution.
  20 ;; 3. Neither the name of the author nor the names of the contributors
  21 ;;    may be used to endorse or promote products derived from this software
  22 ;;   without specific prior written permission.
  23 ;;
  24 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND
  25 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  26 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  27 ;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
  28 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  29 ;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  30 ;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  31 ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  32 ;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  33 ;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  34 ;; SUCH DAMAGE.
  35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36
  37 (in-package #:memstore)
  38
  39 (defconstant +flag-wstring+  (ash 1 0)
  40   "Bit set if stored with write-to-string.")
  41 (defconstant +flag-clstore+ (ash 1 1)
  42   "Bit set if stored with cl-store.")
  43 (defconstant +flag-zlib+ (ash 1 2)
  44   "Bit set if data compressed with zlib.")
  45
  46 (defvar *compression-savings* 0.20
  47   "Compression required before saving compressed value.")
  48 (defvar *compression-enabled* t
  49   "Determines if compression is enabled.")
  50 (defvar *compression-threshold* 5000
  51   "Minimum size of object before attempting compression.")
  52 (defvar *debug* nil
  53   "Controls output of debugging messages.")
  54 (defvar *namespace* "ms:"
  55   "String to prepend to keys for memcache. Default is 'ms:'.")
  56 (defvar *encoding* (flex:make-external-format :utf-8)
  57   "Character encoding to use with converting strings to octets.")
  58
  59
  60 (defun serialize-clstore (obj)
  61   "Converts a Lisp object into a vector of octets using CL-STORE."
  62   (let ((s (make-in-memory-output-stream :element-type 'octet)))
  63     (cl-store:store obj s)
  64     (get-output-stream-sequence s)))
  65
  66 (defun deserialize-clstore (data)
  67   "Restores a Lisp object from a vector of octets using CL-STORE."
  68   (let ((s (make-in-memory-input-stream data)))
  69     (cl-store:restore s)))
  70
  71 (defun serialize-string (obj)
  72   "Tries to write object to string, then convert to vector of octets
  73 Catches error while using *print-readably*. Returns nil if unable to
  74  write to string."
  75   (let* ((*print-readably* t)
  76          (str (ignore-errors (write-to-string obj))))
  77     (when (stringp str)
  78       (flex:string-to-octets str :external-format *encoding*))))
  79
  80 (defun deserialize-string (str)
  81   (multiple-value-bind (obj pos)
  82       (read-from-string (flex:octets-to-string str :external-format *encoding*))
  83     (declare (ignore pos))
  84     obj))
  85
  86 (defun ms-serialize (obj &key (compression-enabled *compression-enabled*)
  87                         (compression-threshold *compression-threshold*))
  88   "Converts a lisp object into a vector of octets.
  89 Returns a cons of (flags . data)."
  90   (let* ((flags 0)
  91          (data
  92            (cond
  93              ((stringp obj)
  94               (flex:string-to-octets obj :external-format :utf8))
  95              (t
  96               (let ((ser (serialize-string obj)))
  97                 (etypecase ser
  98                   (vector
  99                    (setq flags (logior flags +flag-wstring+))
 100                    ser)
 101                  (null
 102                   (setq flags (logior flags +flag-clstore+))
 103                   (serialize-clstore obj)))))))
 104          (dlen (length data)))
 105     (when *debug*
 106       (format t "Compression enabled:~A compression-threshold:~A dlen:~D~%"
 107               compression-enabled compression-threshold dlen))
 108     (when (and compression-enabled compression-threshold
 109                (> dlen compression-threshold))
 110       (multiple-value-bind (compressed clen) (compress data)
 111         (when *debug*
 112           (format t "clen:~D cmin:~A~%" clen (* dlen (- 1 *compression-savings*))))
 113         (when (< clen (* dlen (- 1 *compression-savings*)))
 114           (setq data compressed)
 115           (setq flags (logior flags +flag-zlib+)))))
 116     (when *debug*
 117       (format t "flags:~D dlen:~D data:~S~%" flags (length data) data))
 118     (cons flags data)))
 119
 120 (defun ms-deserialize (ser)
 121   "Converts a cons of storage flags and vector of octets into a lisp object."
 122   (let ((flags (car ser))
 123         (data (cdr ser)))
 124     (when (plusp (logand flags +flag-zlib+))
 125       (setq data (uncompress data)))
 126     (cond
 127       ((plusp (logand flags +flag-clstore+))
 128        (deserialize-clstore data))
 129       ((plusp (logand flags +flag-wstring+))
 130        (deserialize-string data))
 131       (t
 132        (flex:octets-to-string data :external-format :utf8)))))
 133
 134
 135 (defun make-key (key)
 136   "Prepends the *namespace* to a key."
 137   (concatenate 'string *namespace* key))
 138
 139 (defun remove-namespace (key)
 140   "Strips the current *namespace* from beginning of key."
 141   (subseq key (length *namespace*)))
 142
 143 (defun ms-store (key obj &key (memcache *memcache*) (command :set)
 144                             (exptime 0) (use-pool *use-pool*)
 145                             (compression-enabled *compression-enabled*)
 146                             (compression-threshold *compression-threshold*))
 147   "Stores an object in cl-memcached. Tries to print-readably object
 148 to a string for storage. If unable to do so, uses cl-store to serialize
 149 object. Optionally compresses value if meets compression criteria."
 150   (let ((ser (ms-serialize obj :compression-enabled compression-enabled
 151                             :compression-threshold compression-threshold)))
 152     (mc-store (make-key key) (cdr ser)
 153                            :memcache memcache
 154                            :command command :exptime exptime
 155                            :use-pool use-pool :flags (car ser))))
 156
 157 (defun get-objects (keys-list &key (memcache *memcache*) (use-pool *use-pool*)
 158                     (command :get))
 159   "Retrieves a list of objects from memcache from the keys in KEYS-LIST."
 160   (let ((items (mc-get
 161                 (mapcar 'make-key keys-list)
 162                 :memcache memcache
 163                 :use-pool use-pool
 164                 :command command)))
 165     (mapcar (lambda (item)
 166               (let ((key (first item))
 167                     (flags (second item))
 168                     (data (third item)))
 169                 (ecase command
 170                   (:get
 171                    (list (remove-namespace key) (ms-deserialize (cons flags data))))
 172                   (:gets
 173                    (list (remove-namespace key) (ms-deserialize (cons flags data)) (fourth item))))))
 174             items)))
 175
 176 (defun ms-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
 177                    (command :get))
 178   "Lisp objects are restored by memcache server. A key, or list of keys,
 179 is used to identify objects. Command is either :get or :gets. The latter
 180 is used to get memcached's unique object number for storage with :cas."
 181   (let* ((multp (listp key-or-keys))
 182          (keys (if multp key-or-keys (list key-or-keys)))
 183          (items (get-objects keys :memcache memcache :use-pool use-pool
 184                                   :command command)))
 185     (if multp
 186         items
 187         (if items
 188             (let ((item (car items)))
 189               (ecase command
 190                 (:get
 191                  (values (second item) t))
 192                 (:gets
 193                  (values (second item) t (third item)))))
 194             (values nil nil)))))
 195
 196 (defun ms-del (key &key (memcache *memcache*) (use-pool *use-pool*) (time 0))
 197   "Deletes a keyed object from memcache. Key is prepended with *namespace*."
 198   (mc-del (make-key key) :memcache memcache :use-pool use-pool :time time))
 199
 200 (defun ms-incr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
 201   "Increments a keyed integer object. Key is prepended with *namespace*."
 202   (mc-incr (make-key key) :memcache memcache :use-pool use-pool :delta delta))
 203
 204 (defun ms-decr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
 205   "Decrements a keyed integer object. Key is prepended with *namespace*."
 206   (mc-decr (make-key key) :memcache memcache :use-pool use-pool :delta delta))
 207
 208