;; Client interface to the Memcached protocol.
;;
;; Based on the Haskell Memcached library by Evan Martin <martine@danga.com>.
;;
;; Copyright 2011-2019 Ivan Raikov, Seth Alves.
;;
;;
;;  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 cas replace append-to prepend-to
          disconnect stats set add 
          get gets delete incr decr
          (with-server-connection connect disconnect)
          server-handle? server-handle-host server-handle-port)

 (import scheme (chicken base)
         (only srfi-13 string-prefix? string-tokenize string-drop string-skip)
         (only srfi-14 char-set:graphic)
         (only (chicken format) fprintf)
         (only (chicken tcp) tcp-connect)
         (only (chicken io) read-string read-line)
         (only (chicken string) ->string)
         base64)



(define-record-type server-handle
  (make-server-handle host port in out
                      key-encoder key-decoder value-encoder value-decoder)
  server-handle?
  (host server-handle-host)
  (port server-handle-port)
  (in server-handle-in)
  (out server-handle-out)
  (key-encoder server-handle-key-encoder)
  (key-decoder server-handle-key-decoder)
  (value-encoder server-handle-value-encoder)
  (value-decoder server-handle-value-decoder)
  )

;;
;; 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)))


(define (write-to-string obj)
  (let ((s (open-output-string)))
    (write obj s)
    (let ((result (get-output-string s)))
      (close-output-port s)
      result)))

(define (read-from-string s)
  (read (open-input-string 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 . rest)
  (let-optionals rest ((key-encoder base64-encode)
                       (key-decoder base64-decode)
                       (value-encoder write-to-string)
                       (value-decoder read-from-string))
    (let-values (((in out) (tcp-connect host port)))
      (make-server-handle host port in out
                          key-encoder key-decoder
                          value-encoder value-decoder))))


(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 #!key (exptime 0) (flags 0))
    (let ((key-encoder (server-handle-key-encoder h))
          (value-encoder (server-handle-value-encoder h)))
      (let* ((s   (value-encoder val))
             (len (string-length s))
             (cmd (list action (key-encoder key) flags exptime len)))
        (send-cmd h cmd)
        (send-line h s)
        (let ((response (nread-line h)))
          (string=? response "STORED"))
        ))
    ))


(define (cas h key val cas-unique  #!key (exptime 0) (flags 0))
  (let* ((key-encoder (server-handle-key-encoder h))
         (value-encoder (server-handle-value-encoder h))
         (s   (value-encoder val))
         (len (string-length s))
         (cmd (list "cas" (key-encoder key) flags exptime len cas-unique)))
    (send-cmd h cmd)
    (send-line h s)
    (let ((response (nread-line h)))
      (cond ((string=? response "STORED") #t)
            ((string=? response "NOT_STORED") 'not-stored)
            ((string=? response "EXISTS") 'exists)
            ((string=? response "NOT_FOUND") 'not-found)
            (else #f)))))


(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 (read-string len (server-handle-in h))))
               data))))))


(define (incdec cmd)
  (lambda (h key delta)
    (let ((key-encoder (server-handle-key-encoder h)))
      (send-cmd h (list cmd (key-encoder 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 append-to (store "append"))
(define prepend-to (store "prepend"))


(define (gets h keys)
  (let* ((key-encoder (server-handle-key-encoder h))
         (key-decoder (server-handle-key-decoder h))
         (value-decoder (server-handle-value-decoder h))
         (cmd (cons "gets" (map key-encoder keys))))
    (send-cmd h cmd)
    (let loop ((results '()))
      (let* ((s (nread-line h))
             (w (string-tokenize s)))
        (cond ((not (list? w)) #f)
              ((string=? (car w) "END") (reverse results))
              ((not (= (length w) 5)) #f)
              ((not (string=? (car w) "VALUE")) #f)
              (else
               (let* ((key-encoded (list-ref w 1))
                      (key (key-decoder key-encoded))
                      (flags (string->number (list-ref w 2)))
                      (len (string->number (list-ref w 3)))
                      (cas-unique (string->number (list-ref w 4)))
                      (val (read-string len (server-handle-in h)))
                      (data (value-decoder val)))
                 (nread-line h) ;; eat \r\n
                 (loop (cons (list key flags data cas-unique)
                             results)))
               ))
        ))
    ))

(define (get h key)
  (let ((gets-result (gets h (list key))))
    (cond ((null? gets-result) #f)
          (else
           (list-ref (car gets-result) 2)))))

(define (delete h key)
  (let ((key-encoder (server-handle-key-encoder h)))
    (send-cmd h (list "delete" (key-encoder key)))
    (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))]
    ))

)