2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 ;; Purpose: Memstore primary functions
7 ;; Date Started: July 2011
9 ;; Copyright (c) 2011 Kevin M. Rosenberg
10 ;; All rights reserved.
12 ;; Redistribution and use in source and binary forms, with or without
13 ;; modification, are permitted provided that the following conditions
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.
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
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37 (in-package #:memstore)
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.")
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.")
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.")
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)))
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)))
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
75 (let* ((*print-readably* t)
76 (str (ignore-errors (write-to-string obj))))
78 (flex:string-to-octets str :external-format *encoding*))))
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))
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)."
94 (flex:string-to-octets obj :external-format :utf8))
96 (let ((ser (serialize-string obj)))
99 (setq flags (logior flags +flag-wstring+))
102 (setq flags (logior flags +flag-clstore+))
103 (serialize-clstore obj)))))))
104 (dlen (length data)))
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)
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+)))))
117 (format t "flags:~D dlen:~D data:~S~%" flags (length data) data))
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))
124 (when (plusp (logand flags +flag-zlib+))
125 (setq data (uncompress data)))
127 ((plusp (logand flags +flag-clstore+))
128 (deserialize-clstore data))
129 ((plusp (logand flags +flag-wstring+))
130 (deserialize-string data))
132 (flex:octets-to-string data :external-format :utf8)))))
135 (defun make-key (key)
136 "Prepends the *namespace* to a key."
137 (concatenate 'string *namespace* key))
139 (defun remove-namespace (key)
140 "Strips the current *namespace* from beginning of key."
141 (subseq key (length *namespace*)))
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)
154 :command command :exptime exptime
155 :use-pool use-pool :flags (car ser))))
157 (defun get-objects (keys-list &key (memcache *memcache*) (use-pool *use-pool*)
159 "Retrieves a list of objects from memcache from the keys in KEYS-LIST."
161 (mapcar 'make-key keys-list)
165 (mapcar (lambda (item)
166 (let ((key (first item))
167 (flags (second item))
171 (list (remove-namespace key) (ms-deserialize (cons flags data))))
173 (list (remove-namespace key) (ms-deserialize (cons flags data)) (fourth item))))))
176 (defun ms-restore (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
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
188 (let ((item (car items)))
191 (values (second item) t))
193 (values (second item) t (third item)))))
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))
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))
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))