diff options
| -rw-r--r-- | guix-data-service/memcached.scm | 110 |
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)) |