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 write-string-bytes (string stream)
  89   (loop for char across string
  90      do (write-byte (char-code char) stream)))
  91
  92 (defun send-mc-command (s &rest args &aux started)
  93   (dolist (arg args)
  94     (unless (null arg)
  95       (if started
  96           (write-byte (char-code #\space) s)
  97           (setq started t))
  98       (typecase arg
  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)
 107   (force-output s))
 108
 109
 110 ;;;
 111 ;;;
 112 ;;; Memcached API functionality
 113 ;;;
 114 ;;;
 115
 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)
 118                  no-reply)
 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)
 131       (send-mc-command
 132        s
 133        (ecase command
 134          (:set "set")
 135          (:add "add")
 136          (:replace "replace")
 137          (:append "append")
 138          (:prepend "prepend")
 139          (:cas "cas"))
 140        key flags exptime len (when (eq command :cas) cas-unique) (when no-reply "noreply"))
 141       (write-sequence data s)
 142       (send-mc-command s)
 143       (if no-reply
 144           (values)
 145           (read-crlf-line s)))))
 146
 147 (defun mc-get (key-or-keys &key (memcache *memcache*) (use-pool *use-pool*)
 148                            (command :get))
 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.
 152
 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)))
 158          (res
 159            (with-pool-maybe (s memcache use-pool)
 160              (apply 'send-mc-command s (ecase command
 161                                          (:get "get")
 162                                          (:gets "gets"))
 163                     keys-list)
 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)
 173                              (read-crlf-line s)
 174                              (if (eq command :gets)
 175                                  (list (second status-line) flags seq cas-unique)
 176                                  (list (second status-line) flags seq)))))))
 177     (if multp
 178         res
 179         (car res))))
 180
 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"))
 186     (if no-reply
 187         (values)
 188         (read-crlf-line s))))
 189
 190
 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"))
 195                 (if no-reply
 196                     (values)
 197                     (read-crlf-line s))))
 198          (int (unless no-reply
 199                 (ignore-errors (parse-integer res)))))
 200     (or int res)))
 201
 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")
 205                 (read-crlf-line s)))
 206          (split (delimited-string-to-list raw)))
 207     (when (string-equal (first split) "VERSION")
 208       (second split))))
 209
 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"))
 214                (if no-reply
 215                    (values)
 216                    (read-crlf-line s)))))
 217     res))
 218
 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)
 222                (if time
 223                    (send-mc-command s "flush_all" time (when no-reply "noreply"))
 224                    (send-mc-command s "flush_all" (when no-reply "noreply")))
 225                (if no-reply
 226                    (values)
 227                    (read-crlf-line s)))))
 228     res))
 229
 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.
 233 key is a string
 234 delta is an integer"
 235   (incr-or-decr "incr" key delta memcache use-pool no-reply))
 236
 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))
 241
 242 (defun mc-stats-raw (&key (memcache *memcache*) (use-pool *use-pool*) args
 243                      &aux results)
 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)))))
 252   (nreverse results))
 253
 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)))
 257
 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
 265                       for x in result
 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)))))
 270          (results))
 271     (dolist (r all-stats)
 272       (push (cons (ensure-keyword (car r))
 273                   (let* ((val (cdr r))
 274                          (int (ignore-errors (parse-integer val)))
 275                          (float (unless int (ignore-errors (parse-float val)))))
 276                     (cond
 277                       ((integerp int) int)
 278                       ((numberp float) float)
 279                       (t val))))
 280             results))
 281     (make-memcache-stats
 282      :all-stats results
 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)
 301      )))
 302
 303
 304 ;;; Error Conditions
 305
 306 (define-condition memcached-server-unreachable (error)
 307   ((error :initarg :error)))
 308
 309 (define-condition memcache-pool-empty (error)
 310   ())
 311
 312 (define-condition cannot-make-pool-object (error)
 313   ((error :initarg :error)))
 314
 315 (define-condition bad-pool-object (error)
 316   ())
 317
 318 ;;;
 319 ;;;
 320 ;;; Memcached Pooled Access
 321 ;;;
 322 ;;;
 323
 324 (defclass memcache-connection-pool ()
 325   ((name
 326     :initarg :name
 327     :reader name
 328     :initform "Connection Pool"
 329     :type simple-string
 330     :documentation "Name of this pool")
 331    (pool
 332     :initform (make-queue)
 333     :accessor pool)
 334    (pool-lock
 335     :reader pool-lock
 336     :initform (make-lock "Memcache Connection Pool Lock"))
 337    (max-capacity
 338     :initarg :max-capacity
 339     :reader max-capacity
 340     :initform 2
 341     :type fixnum
 342     :documentation "Total capacity of the pool to hold pool objects")
 343    (current-size
 344     :accessor current-size
 345     :initform 0)
 346    (currently-in-use
 347     :accessor currently-in-use
 348     :initform 0
 349     :type fixnum
 350     :documentation "Pool objects currently in Use")
 351    (total-uses
 352     :accessor total-uses
 353     :initform 0
 354     :documentation "Total uses of the pool")
 355    (total-created
 356     :accessor total-created
 357     :initform 0
 358     :type fixnum
 359     :documentation "Total pool objects created")
 360    (pool-grow-requests
 361     :initform 0
 362     :accessor pool-grow-requests
 363     :type fixnum
 364     :documentation "Pool Grow Request pending Action")
 365    (pool-grow-lock
 366     :initform (make-lock "Pool Grow Lock")
 367     :reader pool-grow-lock))
 368   (:documentation "A memcached connection pool object"))
 369
 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)))))
 375
 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)))))
 380
 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)))
 386           (setf state nil)
 387           (progn (incf (currently-in-use (pool memcache)))
 388                  (incf (total-uses (pool memcache)))
 389                  (setf pool-object (dequeue (pool (pool memcache)))))))
 390     (if state
 391         pool-object
 392         (error 'memcache-pool-empty))))
 393
 394 (defun mc-get-from-pool-with-try (&key (memcache *memcache*) (tries 5) (try-interval 1))
 395   ""
 396   (let ((tr 1))
 397     (loop
 398        (progn (when (> tr tries)
 399                 (return nil))
 400               (let ((conn (handler-case (mc-get-from-pool :memcache memcache)
 401                             (memcache-pool-empty () nil))))
 402                 (if (not conn)
 403                     (progn (incf tr)
 404                            (warn "memcache ~a : Connection Pool Empty! I will try again after ~d secs." (name memcache) try-interval)
 405                            (process-sleep try-interval))
 406                     (return conn)))))))
 407
 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))
 415
 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))))
 420
 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)))))))
 433
 434 (defun mc-destroy-pool-item (pool-item)
 435   (ignore-errors (usocket:socket-close pool-item)))
 436
 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."))))
 443
 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))
 451
 452 (defun mc-pool-cleanup (memcache)
 453   (with-lock-held ((pool-lock (pool memcache)))
 454     (with-lock-held ((pool-grow-lock (pool memcache)))
 455       (loop
 456          when (queue-empty-p (pool (pool memcache)))
 457          do (return)
 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))))