memcache/memcache.lisp

   1 ;;; -*- Mode: Common-Lisp -*-
   2
   3 ;;; Copyright (c) 2006, Abhijit 'quasi' Rao.  All rights reserved.
   4 ;;; Copyright (c) 2006, Cleartrip Travel Services.
   5 ;;; Copyright (c) 2011 Kevin Rosenberg
   6
   7 ;;; Redistribution and use in source and binary forms, with or without
   8 ;;; modification, are permitted provided that the following conditions
   9 ;;; are met:
  10
  11 ;;;   * Redistributions of source code must retain the above copyright
  12 ;;;     notice, this list of conditions and the following disclaimer.
  13
  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.
  18
  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.
  30
  31 (in-package #:memcache)
  32
  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)))))
  42
  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)
  49     (error () nil))
  50   (let ((stats (handler-case (mc-stats :memcache memcache)
  51                  (error () nil))))
  52     (if stats
  53         (setf (slot-value memcache 'memcached-server-storage-size) (mc-stats-limit-maxbytes stats))
  54         (setf (slot-value memcache 'memcached-server-storage-size) -1))))
  55
  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))
  60
  61
  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)
  69           (,up ,use-pool)
  70           (,us (if ,up
  71                    (if *pool-get-trys?*
  72                        (mc-get-from-pool-with-try :memcache ,mc)
  73                        (mc-get-from-pool :memcache ,mc))
  74                    (mc-make-pool-item :memcache ,mc))))
  75      (unwind-protect
  76           (when ,us
  77             (let ((,stream (usocket:socket-stream ,us)))
  78               (handler-case
  79                   (progn ,@body)
  80                 (error (c)
  81                   (when ,up
  82                     (mc-chuck-from-pool ,us ,mc))
  83                   (error c)))))
  84        (if ,up
  85            (mc-put-in-pool ,us :memcache ,mc)
  86            (ignore-errors (usocket:socket-close ,mc)))))))
  87
  88 (defun send-mc-command (s &rest args &aux started)
  89   (flet ((write-string-bytes (str stream)
  90            (loop for char across str
  91                  do (write-byte (char-code char) stream))))
  92     (dolist (arg args)
  93       (unless (null arg)
  94         (if started
  95             (write-byte (char-code #\space) s)
  96             (setq started t))
  97         (typecase arg
  98           (string (write-string-bytes arg s))
  99           (character (write-byte (char-code arg) s))
 100           (t (write-string-bytes (princ-to-string arg) s)))))
 101     (write-string-bytes +crlf+ s)
 102     (force-output s)))
 103
 104
 105 ;;;
 106 ;;;
 107 ;;; Memcached API functionality
 108 ;;;
 109 ;;;
 110
 111 (defun mc-store (key data &key (memcache *memcache*) ((:command command) :set) ((:exptime exptime) 0)
 112                             ((:use-pool use-pool) *use-pool*) (cas-unique) (flags 0))
 113   "Stores data in the memcached server using the :command command.
 114 key => key by which the data is stored. this is of type SIMPLE-STRING
 115 data => data to be stored into the cache. data is a sequence of type (UNSIGNED-BYTE 8)
 116 length => size of data
 117 memcache => The instance of class memcache which represnts the memcached we want to use.
 118 command => The storage command we want to use.  There are 3 available : set, add & replace.
 119 exptime => The time in seconds when this data expires.  0 is never expire."
 120   (declare (type fixnum exptime) (type simple-string key))
 121   (when (and (eq command :cas) (not (integerp cas-unique)))
 122     (error "CAS command, but CAS-UNIQUE not set."))
 123   (let ((len (length data)))
 124     (with-pool-maybe (s memcache use-pool)
 125       (send-mc-command
 126        s
 127        (ecase command
 128          (:set "set")
 129          (:add "add")
 130          (:replace "replace")
 131          (:append "append")
 132          (:prepend "prepend")
 133          (:cas "cas"))
 134        key flags exptime len (when (eq command :cas) cas-unique))
 135       (write-sequence data s)
 136       (send-mc-command s)
 137       (read-crlf-line s))))
 138
 139 (defun mc-get (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
 140                            (command :get))
 141   "Retrive value for key from memcached server.
 142 keys-list => is a list of the keys, seperated by whitespace, by which data is stored in memcached
 143 memcache => The instance of class memcache which represnts the memcached we want to use.
 144
 145 Returns a list of lists where each list has three elements key, flags, and value
 146 key is of type SIMPLE-STRING
 147 value is of type (UNSIGNED-BYTE 8)"
 148   (let* ((multp (listp key-or-keys))
 149          (keys-list (if multp key-or-keys (list key-or-keys)))
 150          (res
 151            (with-pool-maybe (s memcache use-pool)
 152              (apply 'send-mc-command s (ecase command
 153                                          (:get "get")
 154                                          (:gets "gets"))
 155                     keys-list)
 156              (loop for x = (read-crlf-line s)
 157                    until (string-equal x "END")
 158                    collect (let* ((status-line (delimited-string-to-list x))
 159                                   (flags (parse-integer (third status-line)))
 160                                   (len (parse-integer (fourth status-line)))
 161                                   (cas-unique (when (eq command :gets)
 162                                                 (parse-integer (fifth status-line))))
 163                                   (seq (make-sequence '(vector (unsigned-byte 8)) len)))
 164                              (read-sequence seq s)
 165                              (read-crlf-line s)
 166                              (if (eq command :gets)
 167                                  (list (second status-line) flags seq cas-unique)
 168                                  (list (second status-line) flags seq)))))))
 169     (if multp
 170         res
 171         (car res))))
 172
 173 (defun mc-del (key &key (memcache *memcache*) ((:time time) 0) (use-pool *use-pool*))
 174   "Deletes a particular 'key' and it's associated data from the memcached server"
 175   (declare (type fixnum time))
 176   (with-pool-maybe (s memcache use-pool)
 177     (send-mc-command s "delete" key time)
 178     (read-crlf-line s)))
 179
 180 (defun incr-or-decr (cmd key delta memcache use-pool)
 181   (declare (type fixnum delta))
 182   (let* ((res (with-pool-maybe (s memcache use-pool)
 183                 (send-mc-command s cmd key delta)
 184                 (read-crlf-line s)))
 185          (int (ignore-errors (parse-integer res))))
 186     (or int res)))
 187
 188 (defun mc-incr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*))
 189   "Implements the INCR command.  Increments the value of a key.
 190 Please read memcached documentation for more information.
 191 key is a string
 192 delta is an integer"
 193   (incr-or-decr "incr" key delta memcache use-pool))
 194
 195 (defun mc-decr (key &key (memcache *memcache*) (delta 1) (use-pool *use-pool*))
 196   "Implements the DECR command.  Decrements the value of a key.
 197  Please read memcached documentation for more information."
 198   (incr-or-decr "decr" key delta memcache use-pool))
 199
 200 (defun mc-stats-raw (&key (memcache *memcache*) (use-pool *use-pool*) args
 201                      &aux results)
 202   "Returns Raw stats data from memcached server to be used by the mc-stats function"
 203   (with-pool-maybe (s memcache use-pool)
 204     (send-mc-command s "stats" args)
 205     (with-output-to-string (str)
 206       (loop for line = (read-crlf-line s)
 207             do (push line results)
 208             until (or (string-equal "END" line)
 209                       (string-equal "ERROR" line)))))
 210   (nreverse results))
 211
 212 (defun mc-get-stat (key stats)
 213   (when (stringp key) (setq key (ensure-keyword key)))
 214   (get-alist key (mc-stats-all-stats stats)))
 215
 216 ;;; Collects statistics from the memcached server
 217 (defun mc-stats (&key (memcache *memcache*) (use-pool *use-pool*))
 218   "Returns a struct of type memcache-stats which contains internal statistics from the
 219 memcached server instance.  Please refer to documentation of memcache-stats for detailed
 220 information about each slot"
 221   (let* ((result (mc-stats-raw :memcache memcache :use-pool use-pool))
 222          (split (loop with xx = nil
 223                       for x in result
 224                       do (setf xx (delimited-string-to-list x))
 225                       when (and (string= (first xx) "STAT") (second xx))
 226                         collect (cons (second xx) (third xx))))
 227          (all-stats (sort split (lambda (a b) (string-greaterp (car a) (car b)))))
 228          (results))
 229     (dolist (r all-stats)
 230       (push (cons (ensure-keyword (car r))
 231                   (let* ((val (cdr r))
 232                          (int (ignore-errors (parse-integer val)))
 233                          (float (unless int (ignore-errors (parse-float val)))))
 234                     (cond
 235                       ((integerp int) int)
 236                       ((numberp float) float)
 237                       (t val))))
 238             results))
 239     (make-memcache-stats
 240      :all-stats results
 241      :pid (get-alist :pid results)
 242      :uptime (get-alist :uptime results)
 243      :time (get-alist :time results)
 244      :version (get-alist :version results)
 245      :rusage-user (get-alist :rusage_user results)
 246      :rusage-system (get-alist :rusage_system results)
 247      :curr-items (get-alist :curr_items results)
 248      :curr-items-total (get-alist :curr_items_tot results)
 249      :curr-connections (get-alist :curr_connections results)
 250      :total-connections (get-alist :total_connections results)
 251      :connection-structures (get-alist :connection_structures results)
 252      :cmd-get (get-alist :cmd_get results)
 253      :cmd-set (get-alist :cmd_set results)
 254      :get-hits (get-alist :get_hits results)
 255      :get-misses (get-alist :get_misses results)
 256      :bytes-read (get-alist :bytes_read results)
 257      :bytes-written (get-alist :bytes_written results)
 258      :limit-maxbytes (get-alist :limit_maxbytes results)
 259      )))
 260
 261
 262 ;;; Error Conditions
 263
 264 (define-condition memcached-server-unreachable (error)
 265   ())
 266
 267 (define-condition memcache-pool-empty (error)
 268   ())
 269
 270 (define-condition cannot-make-pool-object (error)
 271   ())
 272
 273 (define-condition bad-pool-object (error)
 274   ())
 275
 276 ;;;
 277 ;;;
 278 ;;; Memcached Pooled Access
 279 ;;;
 280 ;;;
 281
 282 (defclass memcache-connection-pool ()
 283   ((name
 284     :initarg :name
 285     :reader name
 286     :initform "Connection Pool"
 287     :type simple-string
 288     :documentation "Name of this pool")
 289    (pool
 290     :initform (make-queue)
 291     :accessor pool)
 292    (pool-lock
 293     :reader pool-lock
 294     :initform (make-lock "Memcache Connection Pool Lock"))
 295    (max-capacity
 296     :initarg :max-capacity
 297     :reader max-capacity
 298     :initform 2
 299     :type fixnum
 300     :documentation "Total capacity of the pool to hold pool objects")
 301    (current-size
 302     :accessor current-size
 303     :initform 0)
 304    (currently-in-use
 305     :accessor currently-in-use
 306     :initform 0
 307     :type fixnum
 308     :documentation "Pool objects currently in Use")
 309    (total-uses
 310     :accessor total-uses
 311     :initform 0
 312     :documentation "Total uses of the pool")
 313    (total-created
 314     :accessor total-created
 315     :initform 0
 316     :type fixnum
 317     :documentation "Total pool objects created")
 318    (pool-grow-requests
 319     :initform 0
 320     :accessor pool-grow-requests
 321     :type fixnum
 322     :documentation "Pool Grow Request pending Action")
 323    (pool-grow-lock
 324     :initform (make-lock "Pool Grow Lock")
 325     :reader pool-grow-lock))
 326   (:documentation "A memcached connection pool object"))
 327
 328 (defmethod print-object ((mcp memcache-connection-pool) stream)
 329   (print-unreadable-object (mcp stream :type t :identity t)
 330     (format stream "Capacity:~d, Currently in use:~d"
 331           (when (slot-boundp mcp 'max-capacity) (max-capacity mcp))
 332           (when (slot-boundp mcp 'currently-in-use) (currently-in-use mcp)))))
 333
 334 (defun mc-put-in-pool (conn &key (memcache *memcache*))
 335   (with-lock-held ((pool-lock (pool memcache)))
 336     (enqueue (pool (pool memcache)) conn)
 337     (decf (currently-in-use (pool memcache)))))
 338
 339 (defun mc-get-from-pool (&key (memcache *memcache*))
 340   "Returns a pool object from pool."
 341   (let (pool-object (state t))
 342     (with-lock-held ((pool-lock (pool memcache)))
 343       (if (queue-empty-p (pool (pool memcache)))
 344           (setf state nil)
 345           (progn (incf (currently-in-use (pool memcache)))
 346                  (incf (total-uses (pool memcache)))
 347                  (setf pool-object (dequeue (pool (pool memcache)))))))
 348     (if state
 349         pool-object
 350         (error 'memcache-pool-empty))))
 351
 352 (defun mc-get-from-pool-with-try (&key (memcache *memcache*) (tries 5) (try-interval 1))
 353   ""
 354   (let ((tr 1))
 355     (loop
 356        (progn (when (> tr tries)
 357                 (return nil))
 358               (let ((conn (handler-case (mc-get-from-pool :memcache memcache)
 359                             (memcache-pool-empty () nil))))
 360                 (if (not conn)
 361                     (progn (incf tr)
 362                            (warn "memcache ~a : Connection Pool Empty! I will try again after ~d secs." (name memcache) try-interval)
 363                            (process-sleep try-interval))
 364                     (return conn)))))))
 365
 366 (defun mc-pool-init (&key (memcache *memcache*))
 367   "Cleans up the pool for this particular instance of memcache
 368 & reinits it with POOL-SIZE number of objects required by this pool"
 369   (mc-pool-cleanup memcache)
 370   (dotimes (i (pool-size memcache))
 371     (mc-pool-grow-request memcache))
 372   (mc-pool-grow memcache))
 373
 374 (defun mc-make-pool-item (&key (memcache *memcache*))
 375   (handler-case (usocket:socket-connect (ip memcache) (port memcache) :element-type '(unsigned-byte 8))
 376     (usocket:socket-error () (error 'memcached-server-unreachable))
 377     (error () (error 'cannot-make-pool-object))))
 378
 379 (defun mc-pool-grow (memcache)
 380   (let (grow-count pool-item-list)
 381     (with-lock-held ((pool-grow-lock (pool memcache)))
 382       (setf grow-count (pool-grow-requests (pool memcache)))
 383       (setf pool-item-list (remove nil (loop for x from 1 to grow-count
 384                                           collect (mc-make-pool-item :memcache memcache))))
 385       (loop for x from 1 to (length pool-item-list)
 386          do (with-lock-held ((pool-lock (pool memcache)))
 387               (enqueue (pool (pool memcache)) (pop pool-item-list))
 388               (incf (total-created (pool memcache)))
 389               (incf (current-size (pool memcache))))
 390          do (decf (pool-grow-requests (pool memcache)))))))
 391
 392 (defun mc-destroy-pool-item (pool-item)
 393   (ignore-errors (usocket:socket-close pool-item)))
 394
 395 (defun mc-pool-grow-request (memcache)
 396   (with-lock-held ((pool-grow-lock (pool memcache)))
 397     (if (> (max-capacity (pool memcache)) (+ (current-size (pool memcache))
 398                                              (pool-grow-requests (pool memcache))))
 399         (incf (pool-grow-requests (pool memcache)))
 400         (warn "memcache: Pool is at capacity."))))
 401
 402 (defun mc-chuck-from-pool (object memcache)
 403   (mc-destroy-pool-item object)
 404   (with-lock-held ((pool-lock (pool memcache)))
 405     (decf (current-size (pool memcache))))
 406   #|(loop while (mc-pool-grow-request memcache))
 407   (mc-pool-grow memcache)|#
 408   (mc-pool-init :memcache memcache))
 409
 410 (defun mc-pool-cleanup (memcache)
 411   (with-lock-held ((pool-lock (pool memcache)))
 412     (with-lock-held ((pool-grow-lock (pool memcache)))
 413       (loop
 414          when (queue-empty-p (pool (pool memcache)))
 415          do (return)
 416          else do (mc-destroy-pool-item (dequeue (pool (pool memcache)))))
 417       (setf (current-size (pool memcache)) 0
 418             (currently-in-use (pool memcache)) 0
 419             (pool-grow-requests (pool memcache)) 0
 420             (total-created (pool memcache)) 0
 421             (total-uses (pool memcache)) 0))))