src/memstore.lisp

   1 ;; -*- Mode: Lisp -*-
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;; FILE IDENTIFICATION
   4 ;;
   5 ;; Name:          main.lisp
   6 ;; Purpose:       memstore main 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 (defvar *realm* "ms:")
  54 (defvar *encoding* (flex:make-external-format :utf-8))
  55
  56
  57 (defun serialize-clstore (obj)
  58   (let ((s (make-in-memory-output-stream :element-type 'octet)))
  59     (cl-store:store obj s)
  60     (get-output-stream-sequence s)))
  61
  62 (defun deserialize-clstore (data)
  63   (let ((s (make-in-memory-input-stream data)))
  64     (cl-store:restore s)))
  65
  66 (defun serialize-string (obj)
  67   "Tries to write object to string, then convert to vector of octets
  68 Catches error while using *print-readably*. Returns nil if unable to
  69  write to string."
  70   (let* ((*print-readably* t)
  71          (str (ignore-errors (write-to-string obj))))
  72     (when (stringp str)
  73       (flex:string-to-octets str :external-format *encoding*))))
  74
  75 (defun deserialize-string (str)
  76   (multiple-value-bind (obj pos)
  77       (read-from-string (flex:octets-to-string str :external-format *encoding*))
  78     (declare (ignore pos))
  79     obj))
  80
  81 (defun serialize (obj &key (compression-enabled *compression-enabled*)
  82                         (compression-threshold *compression-threshold*))
  83   "Converts a lisp object into a vector of octets.
  84 Returns a cons of (flags . data)."
  85   (let* ((flags 0)
  86          (data
  87            (cond
  88              ((stringp obj)
  89               (flex:string-to-octets obj :external-format :utf8))
  90              (t
  91               (let ((ser (serialize-string obj)))
  92                 (etypecase ser
  93                   (vector
  94                    (setq flags (logior flags +flag-wstring+))
  95                    ser)
  96                  (null
  97                   (setq flags (logior flags +flag-clstore+))
  98                   (serialize-clstore obj)))))))
  99          (dlen (length data)))
 100     (when *debug*
 101       (format t "Compression enabled:~A compression-threshold:~A dlen:~D~%"
 102               compression-enabled compression-threshold dlen))
 103     (when (and compression-enabled compression-threshold
 104                (> dlen compression-threshold))
 105       (multiple-value-bind (compressed clen) (zlib:compress data :fixed)
 106         (when *debug*
 107           (format t "clen:~D cmin:~A~%" clen (* dlen (- 1 *compression-savings*))))
 108         (when (< clen (* dlen (- 1 *compression-savings*)))
 109           (setq data compressed)
 110           (setq flags (logior flags +flag-zlib+)))))
 111     (when *debug*
 112       (format t "flags:~D dlen:~D data:~S~%" flags (length data) data))
 113     (cons flags data)))
 114
 115 (defun deserialize (ser)
 116   "Converts a cons of storage flags and vector of octets into a lisp object."
 117   (let ((flags (car ser))
 118         (data (cdr ser)))
 119     (when (plusp (logand flags +flag-zlib+))
 120       (setq data (zlib:uncompress data)))
 121     (cond
 122       ((plusp (logand flags +flag-clstore+))
 123        (deserialize-clstore data))
 124       ((plusp (logand flags +flag-wstring+))
 125        (deserialize-string data))
 126       (t
 127        (flex:octets-to-string data :external-format :utf8)))))
 128
 129
 130 (defun make-key (key)
 131   (concatenate 'string *realm* key))
 132
 133 (defun remove-realm (key)
 134   (subseq key (length *realm*)))
 135
 136 (defun mem-store (key obj &key (memcache *memcache*) (command :set)
 137                             (exptime 0) (use-pool *use-pool*)
 138                             (compression-enabled *compression-enabled*)
 139                             (compression-threshold *compression-threshold*))
 140   "Stores an object in cl-memcached. Tries to print-readably object
 141 to a string for storage. If unable to do so, uses cl-store to serialize
 142 object. Optionally compresses value if meets compression criteria."
 143   (let ((ser (serialize obj :compression-enabled compression-enabled
 144                             :compression-threshold compression-threshold)))
 145     (mc-store (make-key key) (cdr ser)
 146                            :memcache memcache
 147                            :command command :exptime exptime
 148                            :use-pool use-pool :flags (car ser))))
 149
 150 (defun get-objects (keys-list &key (memcache *memcache*) (use-pool *use-pool*)
 151                                 (command :get))
 152   (let ((items (mc-get
 153                 (mapcar 'make-key keys-list)
 154                 :memcache memcache
 155                 :use-pool use-pool
 156                 :command command)))
 157     (mapcar (lambda (item)
 158               (let ((key (first item))
 159                     (flags (second item))
 160                     (data (third item)))
 161                 (ecase command
 162                   (:get
 163                    (list (remove-realm key) (deserialize (cons flags data))))
 164                   (:gets
 165                    (list (remove-realm key) (deserialize (cons flags data)) (fourth item))))))
 166             items)))
 167
 168 (defun mem-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
 169                                   (command :get))
 170   (let* ((multp (listp key-or-keys))
 171          (keys (if multp key-or-keys (list key-or-keys)))
 172          (items (get-objects keys :memcache memcache :use-pool use-pool
 173                                   :command command)))
 174     (if multp
 175         items
 176         (if items
 177             (let ((item (car items)))
 178               (ecase command
 179                 (:get
 180                  (values (second item) t))
 181                 (:gets
 182                  (values (second item) t (third item)))))
 183             (values nil nil)))))
 184
 185 (defun mem-del (key &key (memcache *memcache*) (use-pool *use-pool*) (time 0))
 186   (mc-del (make-key key) :memcache memcache :use-pool use-pool :time time))
 187
 188 (defun mem-incr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
 189   (mc-incr (make-key key) :memcache memcache :use-pool use-pool :delta delta))
 190
 191 (defun mem-decr (key &key (memcache *memcache*) (use-pool *use-pool*) (delta 1))
 192   (mc-decr (make-key key) :memcache memcache :use-pool use-pool :delta delta))
 193
 194