WIPwip-memcached

1 files changed, 110 insertions, 0 deletions

diff --git a/guix-data-service/memcached.scm b/guix-data-service/memcached.scm
new file mode 100644
index 0000000..2690040
--- /dev/null
+++ b/guix-data-service/memcached.scm
@@ -0,0 +1,110 @@
+;;; Simple memcached client implementation
+
+;; Copyright (C)  2012 Free Software Foundation, Inc.
+;; Copyright (C)  2019 Christopher Baines <mail@cbaines.net>
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+(define-module (guix-data-service memcached)
+  #:use-module (rnrs bytevectors)
+  #:use-module (fibers)
+  #:use-module (fibers channels)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match))
+
+(define (server-error port msg . args)
+  (close-port port)
+  (apply error msg args))
+
+(define (parse-int port val)
+  (let ((num (string->number val)))
+    (unless (and num (integer? num) (exact? num) (>= num 0))
+      (server-error port "Expected a non-negative integer: ~s" val))
+    num))
+
+(define (make-item flags bv)
+  (vector flags bv))
+(define (item-flags item)
+  (vector-ref item 0))
+(define (item-bv item)
+  (vector-ref item 1))
+
+(define (memcached-get port . keys)
+  (put-string port "get ")
+  (put-string port (string-join keys " "))
+  (put-string port "\r\n")
+  (force-output port)
+  (let lp ((vals '()))
+    (let ((line (read-line port)))
+      (when (eof-object? line)
+        (server-error port "Expected a response to 'get', got EOF"))
+      (match (string-split (string-trim-right line) #\space)
+        (("VALUE" key flags length)
+         (let* ((flags (parse-int port flags))
+                (length (parse-int port length)))
+           (unless (member key keys)
+             (server-error port "Unknown key: ~a" key))
+           (when (assoc key vals)
+             (server-error port "Already have response for key: ~a" key))
+           (let ((bv (get-bytevector-n port length)))
+             (unless (= (bytevector-length bv) length)
+               (server-error port "Expected ~A bytes, got ~A" length bv))
+             (when (eqv? (peek-char port) #\return)
+               (read-char port))
+             (unless (eqv? (read-char port) #\newline)
+               (server-error port "Expected \\n"))
+             (lp (acons key (make-item flags bv) vals)))))
+        (("END")
+         (reverse vals))
+        (_
+         (server-error port "Bad line: ~A" line))))))
+
+(define* (memcached-set port key flags exptime bytes #:key noreply?)
+  (put-string port "set ")
+  (put-string port key)
+  (put-char port #\space)
+  (put-string port (number->string flags))
+  (put-char port #\space)
+  (put-string port (number->string exptime))
+  (put-char port #\space)
+  (put-string port (number->string (bytevector-length bytes)))
+  (when noreply?
+    (put-string port " noreply"))
+  (put-string port "\r\n")
+  (put-bytevector port bytes)
+  (put-string port "\r\n")
+  (force-output port)
+  (let ((line (read-line port)))
+    (match line
+      ((? eof-object?)
+       (server-error port "EOF while expecting response from server"))
+      ("STORED\r" #t)
+      ("NOT_STORED\r" #t)
+      (_
+       (server-error port "Unexpected response from server: ~A" line)))))
+
+(define (connect-to-memcached addrinfo)
+  (let ((port (socket (addrinfo:fam addrinfo)
+                      (addrinfo:socktype addrinfo)
+                      (addrinfo:protocol addrinfo))))
+    ;; Disable Nagle's algorithm.  We buffer ourselves.
+    (setsockopt port IPPROTO_TCP TCP_NODELAY 1)
+    (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
+    (setvbuf port 'block 1024)
+    (connect port (addrinfo:addr addrinfo))
+    port))