1 ;;; -*- Mode: Common-Lisp -*-
3 ;;; Copyright (c) 2006, Abhijit 'quasi' Rao. All rights reserved.
4 ;;; Copyright (c) 2006, Cleartrip Travel Services.
5 ;;; Copyright (c) 2011 Kevin Rosenberg
7 ;;; Redistribution and use in source and binary forms, with or without
8 ;;; modification, are permitted provided that the following conditions
11 ;;; * Redistributions of source code must retain the above copyright
12 ;;; notice, this list of conditions and the following disclaimer.
14 ;;; * Redistributions in binary form must reproduce the above
15 ;;; copyright notice, this list of conditions and the following
16 ;;; disclaimer in the documentation and/or other materials
17 ;;; provided with the distribution.
19 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
20 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
21 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
23 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
24 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
25 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
27 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
28 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
29 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 (in-package #:memcache)
33 (defmethod print-object ((mc memcache) stream)
34 (print-unreadable-object (mc stream :type t :identity t)
35 (format stream "~A on ~A:~A ~AMB"
36 (when (slot-boundp mc 'name) (name mc))
37 (when (slot-boundp mc 'ip) (ip mc))
38 (when (slot-boundp mc 'port) (port mc))
39 (when (and (slot-boundp mc 'memcached-server-storage-size)
40 (numberp (slot-value mc 'memcached-server-storage-size)))
41 (/ (memcached-server-storage-size mc) 1024 1024)))))
43 (defmethod initialize-instance :after ((memcache memcache) &rest initargs)
44 (declare (ignore initargs))
45 (setf (slot-value memcache 'pool) (make-instance 'memcache-connection-pool
46 :name (concatenate 'simple-string (name memcache) " - Connection Pool")
47 :max-capacity (pool-size memcache)))
48 (handler-case (mc-pool-init :memcache memcache)
50 (let ((stats (handler-case (mc-stats :memcache memcache)
53 (setf (slot-value memcache 'memcached-server-storage-size) (mc-stats-limit-maxbytes stats))
54 (setf (slot-value memcache 'memcached-server-storage-size) -1))))
56 (defun make-memcache-instance (&key (ip "127.0.0.1") (port 11211)
57 (name "Memcache") (pool-size 5))
58 "Creates an instance of class MEMCACHE which represents a memcached server."
59 (make-instance 'memcache :name name :ip ip :port port :pool-size pool-size))
62 (defmacro with-pool-maybe ((stream memcache use-pool) &body body)
63 "Macro to wrap the use-pool/dont-use-pool stuff and the cleanup
64 around a body of actual action statements"
65 (let ((mc (gensym "MEMCACHE-"))
66 (up (gensym "USE-POOL-"))
67 (us (gensym "USOCKET-")))
68 `(let* ((,mc ,memcache)
72 (mc-get-from-pool-with-try :memcache ,mc)
73 (mc-get-from-pool :memcache ,mc))
74 (mc-make-pool-item :memcache ,mc))))
77 (let ((,stream (usocket:socket-stream ,us)))
82 (mc-chuck-from-pool ,us ,mc))
85 (mc-put-in-pool ,us :memcache ,mc)
86 (ignore-errors (usocket:socket-close ,mc)))))))
88 (defun write-string-bytes (string stream)
89 (loop for char across string
90 do (write-byte (char-code char) stream)))
92 (defun send-mc-command (s &rest args &aux started)
96 (write-byte (char-code #\space) s)
99 #+nil (keyword (if (eq :no-reply arg)
100 (write-string-bytes "noreply" s)
101 (write-string-bytes (string-downcase
102 (symbol-name arg)) s)))
103 (string (write-string-bytes arg s))
104 (character (write-byte (char-code arg) s))
105 (t (write-string-bytes (princ-to-string arg) s)))))
106 (write-string-bytes +crlf+ s)
112 ;;; Memcached API functionality
116 (defun mc-store (key data &key (memcache *memcache*) ((:command command) :set) ((:exptime exptime) 0)
117 ((:use-pool use-pool) *use-pool*) (cas-unique) (flags 0)
119 "Stores data in the memcached server using the :command command.
120 key => key by which the data is stored. this is of type SIMPLE-STRING
121 data => data to be stored into the cache. data is a sequence of type (UNSIGNED-BYTE 8)
122 length => size of data
123 memcache => The instance of class memcache which represnts the memcached we want to use.
124 command => The storage command we want to use. There are 3 available : set, add & replace.
125 exptime => The time in seconds when this data expires. 0 is never expire."
126 (declare (type fixnum exptime) (type simple-string key))
127 (when (and (eq command :cas) (not (integerp cas-unique)))
128 (error "CAS command, but CAS-UNIQUE not set."))
129 (let ((len (length data)))
130 (with-pool-maybe (s memcache use-pool)
140 key flags exptime len (when (eq command :cas) cas-unique) (when no-reply "noreply"))
141 (write-sequence data s)
145 (read-crlf-line s)))))
147 (defun mc-get (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
149 "Retrive value for key from memcached server.
150 keys-list => is a list of the keys, seperated by whitespace, by which data is stored in memcached
151 memcache => The instance of class memcache which represnts the memcached we want to use.
153 Returns a list of lists where each list has three elements key, flags, and value
154 key is of type SIMPLE-STRING
155 value is of type (UNSIGNED-BYTE 8)"
156 (let* ((multp (listp key-or-keys))
157 (keys-list (if multp key-or-keys (list key-or-keys)))
159 (with-pool-maybe (s memcache use-pool)
160 (apply 'send-mc-command s (ecase command
164 (loop for x = (read-crlf-line s)
165 until (string-equal x "END")
166 collect (let* ((status-line (delimited-string-to-list x))
167 (flags (parse-integer (third status-line)))
168 (len (parse-integer (fourth status-line)))
169 (cas-unique (when (eq command :gets)
170 (parse-integer (fifth status-line))))
171 (seq (make-sequence '(vector (unsigned-byte 8)) len)))
172 (read-sequence seq s)
174 (if (eq command :gets)
175 (list (second status-line) flags seq cas-unique)
176 (list (second status-line) flags seq)))))))
181 (defun mc-del (key &key (memcache *memcache*) ((:time time) 0) (use-pool *use-pool*) (no-reply))
182 "Deletes a particular 'key' and it's associated data from the memcached server"
183 (declare (type fixnum time))
184 (with-pool-maybe (s memcache use-pool)
185 (send-mc-command s "delete" key time (when no-reply "noreply"))
188 (read-crlf-line s))))
191 (defun incr-or-decr (cmd key delta memcache use-pool no-reply)
192 (declare (type fixnum delta))
193 (let* ((res (with-pool-maybe (s memcache use-pool)
194 (send-mc-command s cmd key delta (if no-reply "noreply"))
197 (read-crlf-line s))))
198 (int (unless no-reply
199 (ignore-errors (parse-integer res)))))
202 (defun mc-version (&key (memcache *memcache*) (use-pool *use-pool*))
203 (let* ((raw (with-pool-maybe (s memcache use-pool)
204 (send-mc-command s "version")
206 (split (delimited-string-to-list raw)))
207 (when (string-equal (first split) "VERSION")
210 (defun mc-verbosity (v &key (memcache *memcache*) (use-pool *use-pool*) (no-reply))
211 (declare (type integer v))
212 (let ((res (with-pool-maybe (s memcache use-pool)
213 (send-mc-command s "verbosity" v (when no-reply "noreply"))
216 (read-crlf-line s)))))
219 (defun mc-flush-all (&key (time nil) (memcache *memcache*) (use-pool *use-pool*) (no-reply))
220 (declare (type (or null integer) time))
221 (let ((res (with-pool-maybe (s memcache use-pool)
223 (send-mc-command s "flush_all" time (when no-reply "noreply"))
224 (send-mc-command s "flush_all" (when no-reply "noreply")))
227 (read-crlf-line s)))))
230 (defun mc-incr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*) (no-reply))
231 "Implements the INCR command. Increments the value of a key.
232 Please read memcached documentation for more information.
235 (incr-or-decr "incr" key delta memcache use-pool no-reply))
237 (defun mc-decr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*) (no-reply))
238 "Implements the DECR command. Decrements the value of a key.
239 Please read memcached documentation for more information."
240 (incr-or-decr "decr" key delta memcache use-pool no-reply))
242 (defun mc-stats-raw (&key (memcache *memcache*) (use-pool *use-pool*) args
244 "Returns Raw stats data from memcached server to be used by the mc-stats function"
245 (with-pool-maybe (s memcache use-pool)
246 (send-mc-command s "stats" args)
247 (with-output-to-string (str)
248 (loop for line = (read-crlf-line s)
249 do (push line results)
250 until (or (string-equal "END" line)
251 (string-equal "ERROR" line)))))
254 (defun mc-get-stat (key stats)
255 (when (stringp key) (setq key (ensure-keyword key)))
256 (get-alist key (mc-stats-all-stats stats)))
258 ;;; Collects statistics from the memcached server
259 (defun mc-stats (&key (memcache *memcache*) (use-pool *use-pool*))
260 "Returns a struct of type memcache-stats which contains internal statistics from the
261 memcached server instance. Please refer to documentation of memcache-stats for detailed
262 information about each slot"
263 (let* ((result (mc-stats-raw :memcache memcache :use-pool use-pool))
264 (split (loop with xx = nil
266 do (setf xx (delimited-string-to-list x))
267 when (and (string= (first xx) "STAT") (second xx))
268 collect (cons (second xx) (third xx))))
269 (all-stats (sort split (lambda (a b) (string-greaterp (car a) (car b)))))
271 (dolist (r all-stats)
272 (push (cons (ensure-keyword (car r))
274 (int (ignore-errors (parse-integer val)))
275 (float (unless int (ignore-errors (parse-float val)))))
278 ((numberp float) float)
283 :pid (get-alist :pid results)
284 :uptime (get-alist :uptime results)
285 :time (get-alist :time results)
286 :version (get-alist :version results)
287 :rusage-user (get-alist :rusage_user results)
288 :rusage-system (get-alist :rusage_system results)
289 :curr-items (get-alist :curr_items results)
290 :curr-items-total (get-alist :curr_items_tot results)
291 :curr-connections (get-alist :curr_connections results)
292 :total-connections (get-alist :total_connections results)
293 :connection-structures (get-alist :connection_structures results)
294 :cmd-get (get-alist :cmd_get results)
295 :cmd-set (get-alist :cmd_set results)
296 :get-hits (get-alist :get_hits results)
297 :get-misses (get-alist :get_misses results)
298 :bytes-read (get-alist :bytes_read results)
299 :bytes-written (get-alist :bytes_written results)
300 :limit-maxbytes (get-alist :limit_maxbytes results)
306 (define-condition memcached-server-unreachable (error)
307 ((error :initarg :error)))
309 (define-condition memcache-pool-empty (error)
312 (define-condition cannot-make-pool-object (error)
313 ((error :initarg :error)))
315 (define-condition bad-pool-object (error)
320 ;;; Memcached Pooled Access
324 (defclass memcache-connection-pool ()
328 :initform "Connection Pool"
330 :documentation "Name of this pool")
332 :initform (make-queue)
336 :initform (make-lock "Memcache Connection Pool Lock"))
338 :initarg :max-capacity
342 :documentation "Total capacity of the pool to hold pool objects")
344 :accessor current-size
347 :accessor currently-in-use
350 :documentation "Pool objects currently in Use")
354 :documentation "Total uses of the pool")
356 :accessor total-created
359 :documentation "Total pool objects created")
362 :accessor pool-grow-requests
364 :documentation "Pool Grow Request pending Action")
366 :initform (make-lock "Pool Grow Lock")
367 :reader pool-grow-lock))
368 (:documentation "A memcached connection pool object"))
370 (defmethod print-object ((mcp memcache-connection-pool) stream)
371 (print-unreadable-object (mcp stream :type t :identity t)
372 (format stream "Capacity:~d, Currently in use:~d"
373 (when (slot-boundp mcp 'max-capacity) (max-capacity mcp))
374 (when (slot-boundp mcp 'currently-in-use) (currently-in-use mcp)))))
376 (defun mc-put-in-pool (conn &key (memcache *memcache*))
377 (with-lock-held ((pool-lock (pool memcache)))
378 (enqueue (pool (pool memcache)) conn)
379 (decf (currently-in-use (pool memcache)))))
381 (defun mc-get-from-pool (&key (memcache *memcache*))
382 "Returns a pool object from pool."
383 (let (pool-object (state t))
384 (with-lock-held ((pool-lock (pool memcache)))
385 (if (queue-empty-p (pool (pool memcache)))
387 (progn (incf (currently-in-use (pool memcache)))
388 (incf (total-uses (pool memcache)))
389 (setf pool-object (dequeue (pool (pool memcache)))))))
392 (error 'memcache-pool-empty))))
394 (defun mc-get-from-pool-with-try (&key (memcache *memcache*) (tries 5) (try-interval 1))
398 (progn (when (> tr tries)
400 (let ((conn (handler-case (mc-get-from-pool :memcache memcache)
401 (memcache-pool-empty () nil))))
404 (warn "memcache ~a : Connection Pool Empty! I will try again after ~d secs." (name memcache) try-interval)
405 (process-sleep try-interval))
408 (defun mc-pool-init (&key (memcache *memcache*))
409 "Cleans up the pool for this particular instance of memcache
410 & reinits it with POOL-SIZE number of objects required by this pool"
411 (mc-pool-cleanup memcache)
412 (dotimes (i (pool-size memcache))
413 (mc-pool-grow-request memcache))
414 (mc-pool-grow memcache))
416 (defun mc-make-pool-item (&key (memcache *memcache*))
417 (handler-case (usocket:socket-connect (ip memcache) (port memcache) :element-type '(unsigned-byte 8))
418 (usocket:socket-error (e) (error 'memcached-server-unreachable :error e))
419 (error (e) (error 'cannot-make-pool-object :error e))))
421 (defun mc-pool-grow (memcache)
422 (let (grow-count pool-item-list)
423 (with-lock-held ((pool-grow-lock (pool memcache)))
424 (setf grow-count (pool-grow-requests (pool memcache)))
425 (setf pool-item-list (remove nil (loop for x from 1 to grow-count
426 collect (mc-make-pool-item :memcache memcache))))
427 (loop for x from 1 to (length pool-item-list)
428 do (with-lock-held ((pool-lock (pool memcache)))
429 (enqueue (pool (pool memcache)) (pop pool-item-list))
430 (incf (total-created (pool memcache)))
431 (incf (current-size (pool memcache))))
432 do (decf (pool-grow-requests (pool memcache)))))))
434 (defun mc-destroy-pool-item (pool-item)
435 (ignore-errors (usocket:socket-close pool-item)))
437 (defun mc-pool-grow-request (memcache)
438 (with-lock-held ((pool-grow-lock (pool memcache)))
439 (if (> (max-capacity (pool memcache)) (+ (current-size (pool memcache))
440 (pool-grow-requests (pool memcache))))
441 (incf (pool-grow-requests (pool memcache)))
442 (warn "memcache: Pool is at capacity."))))
444 (defun mc-chuck-from-pool (object memcache)
445 (mc-destroy-pool-item object)
446 (with-lock-held ((pool-lock (pool memcache)))
447 (decf (current-size (pool memcache))))
448 #|(loop while (mc-pool-grow-request memcache))
449 (mc-pool-grow memcache)|#
450 (mc-pool-init :memcache memcache))
452 (defun mc-pool-cleanup (memcache)
453 (with-lock-held ((pool-lock (pool memcache)))
454 (with-lock-held ((pool-grow-lock (pool memcache)))
456 when (queue-empty-p (pool (pool memcache)))
458 else do (mc-destroy-pool-item (dequeue (pool (pool memcache)))))
459 (setf (current-size (pool memcache)) 0
460 (currently-in-use (pool memcache)) 0
461 (pool-grow-requests (pool memcache)) 0
462 (total-created (pool memcache)) 0
463 (total-uses (pool memcache)) 0))))