aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-data-service/memcached.scm110
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))