;; Client interface to the Memcached protocol.
;;
;; Based on the Haskell Memcached library by Evan Martin <martine@danga.com>.
;;
;; Copyright 2011 Ivan Raikov.
;;
;; 
;;  Redistribution and use in source and binary forms, with or without
;;  modification, are permitted provided that the following conditions
;;  are met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;  notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above
;;  copyright notice, this list of conditions and the following
;;  disclaimer in the documentation and/or other materials provided
;;  with the distribution.
;; 
;;  - Neither name of the copyright holders nor the names of its
;;  contributors may be used to endorse or promote products derived
;;  from this software without specific prior written permission.
;; 
;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;  POSSIBILITY OF SUCH DAMAGE.
;;


(module memcached

 (connect disconnect stats set add replace get delete incr decr
  (with-server-connection connect disconnect)
  server-handle? server-handle-host server-handle-port)
		   
 (import scheme (except chicken get) )

 (require-library extras data-structures tcp srfi-13 srfi-14 srfi-69)
 (import (only srfi-13 string-prefix? string-tokenize string-drop string-skip)
	 (only srfi-14 char-set:graphic)
	 (only srfi-69 hash)
	 (only extras fprintf read-line)
	 (only data-structures compose intersperse ->string)
	 (only tcp tcp-connect))

 (require-extension s11n)


(define-record-type server-handle
  (make-server-handle host port in out)
  server-handle?
  (host server-handle-host)
  (port server-handle-port)
  (in server-handle-in)
  (out server-handle-out)
  )

;;
;; Returns the first token specified by char-set from the given
;; string, plus the rest of the string.
;;
(define (string-tokenize1 s . token-chars)
  (let-optionals* token-chars
      ((token-chars char-set:graphic) rest) ; (char-set? token-chars)) rest)
      (cond ((string-skip s token-chars) =>
	     (lambda (tend1)
	       (list (substring s 0 tend1) (substring s (+ 1 tend1) ))))
	    (else (list s)))))


;; Get a line, stripping \r\n terminator.
(define (nread-line h . rest)
  (let-optionals rest ((limit #f))
   (let ((in (server-handle-in h)))
    (read-line in limit))))
      

;; Gather results from action until condition is true.
(define (nread-until action h)
  (let recur ((line (nread-line h)) (results '()))
    (let ((results1 (cons line results)))
      (if (action line) (reverse results1)
	  (recur (nread-line h) results1)))))


;; Put out a line with \r\n terminator.
(define (send-line h s)
  (let ((out (server-handle-out h)))
    (fprintf out "~A\r\n" s)))


;; Put out a command (words with terminator) and flush.
(define (send-cmd h lst)
  (let ((out (server-handle-out h))
	(cmd (intersperse (map ->string lst) " ")))
    (let recur ((cmd cmd))
      (if (null? cmd) (fprintf out "\r\n")
	  (begin
	    (fprintf out "~A" (car cmd))
	    (recur (cdr cmd)))))))


(define (connect host port)
  (let-values (((in out) (tcp-connect host port)))
    (make-server-handle host port in out)))


(define (disconnect h)
  (close-input-port (server-handle-in h))
  (close-output-port (server-handle-out h)))


(define (stats h)
  (send-cmd h (list "stats"))
  (let ((lines (nread-until (lambda (x) (string=? x "END")) h))
	(strip-prefix (lambda (x) (or (and (string-prefix? "STAT " x) 
					   (string-drop x 5)) x))))
    (map (compose (lambda (x) (or (and (pair? x) (cons (string->symbol (car x)) (cdr x))) x))
		  string-tokenize1 strip-prefix) lines)))
		  
			  
(define (store action)
  (lambda (h key val . rest)
    (let-optionals rest ((hash hash))
    (let ((flags 0) (exptime 0))
      (let ((data (open-output-string)))
	(serialize val data)
	(close-output-port data)
	(let* ((s   (get-output-string data))
	       (len (string-length s))
	       (cmd (list action (hash key) flags exptime len)))
	  (send-cmd h cmd)
	  (send-line h s)
	  (let ((response (nread-line h)))
	    (string=? response "STORED"))
	  ))
      ))))


(define (get-one-value h)
  (let ((s (nread-line h)))
    (let ((w (string-tokenize s)))
      (and (pair? w) (string=? (car w) "VALUE")
	   (let ((len (string->number (car (cdddr w)))))
	     (let ((data (nread-line h len)))
	       data))))))
	  


(define (incdec cmd)
  (lambda (h key delta . rest)
    (let-optionals rest ((hash hash))
     (send-cmd h (list cmd (hash key) delta))
     (let ((response (nread-line h)))
       (if (string=? response "NOT_FOUND") #f
	   (string->number response))))))


(define set (store "set"))
(define add (store "add"))
(define replace (store "replace"))


(define (get h key . rest)
  (let-optionals rest ((hash hash))
     (let ((cmd (list "get" (hash key))))
       (send-cmd h cmd)
       (let ((val (get-one-value h)))
	 (and val (let ((s (open-input-string val)))
		    (nread-line h)
		    (deserialize s))
	      )))))

(define (delete h key delta . rest)
  (let-optionals rest ((hash hash))
    (send-cmd h (list "delete" (hash key) delta))
    (let ((response (nread-line h)))
      (string=? response "DELETED"))))

(define incr (incdec "incr"))
(define decr (incdec "decr"))

(define-syntax with-server-connection
  (syntax-rules ()
    [(_ h host port cmd ...)
     (let ((h (connect host port)))
       (begin cmd ...)
       (disconnect h))]
    ))


)