gistfile1.ml

(* Basic OCaml Tokyo Tyrant Client.
 * Currently, only supports get and put, but may eventually add all
 * the exciting other features.
 * 
 * -Cooper Francis.
 *)
#use "topfind";;
#camlp4o;;
#require "lwt";;
#require "unix";;
#require "bitstring.syntax";;
#require "bitstring";;

open Lwt;;
open Bitstring;;

(*Networking and Bitstring Helpers*)
let get_bitstring_length = function
    (cont, offset, length) -> length
;;

let connect_server ip port =
  let makeConnection sockaddr =
    let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0
    in try Lwt_unix.connect sock sockaddr;
        sock
      with exn -> Lwt_unix.close sock; raise exn 
        
  in
  let server_addr = Unix.inet_addr_of_string ip in
  let sockaddr = Unix.ADDR_INET(server_addr, port) in
    makeConnection sockaddr 
;;

let rec really_write out_ch buffer pos len =
  Lwt_unix.write out_ch buffer pos len >>= (fun len' ->
  if len = len' then return () else
  really_write out_ch buffer (pos + len') (len - len'))
;;

let shutdownConnection inchan =
  Unix.shutdown (Unix.descr_of_in_channel inchan) Unix.SHUTDOWN_SEND
;;


(*Get string representations of Tokyo Tyrant error codes.*)
let errorCode x = 
  if x=0 then "success"
  else if x=1 then "invalid operation"
  else if x=2 then "host not found"
  else if x=3 then "connection refused"
  else if x=4 then "send error"
  else if x=5 then "recv error"
  else if x=6 then "existing record"
  else if x=7 then "no record found"
  else if x=9999 then "miscellaneous error"
  else "unknown error"
;;

let magic = 0xC8;;

let makePut key value =
  let putid = 0x10 in
  let bitkey = bitstring_of_string key in
  let keylength = Int32.of_int (get_bitstring_length bitkey) in
  let bitvalue = bitstring_of_string value in
  let valuelength = Int32.of_int (get_bitstring_length bitvalue) in
  let meta = 
    BITSTRING { 
      magic : 8; 
      putid : 8; 
      keylength : 32; 
      valuelength : 32 
    } 
  in
    concat [meta; bitkey; bitvalue]
;;

let makeGet key =
    let getid = 0x20 in
    let bitkey = bitstring_of_string key in
    let keylength = Int32.of_int (get_bitstring_length bitkey) in
    let meta =
      BITSTRING {
        magic : 8;
        getid : 8;
        keylength : 32
      }
    in
      concat [meta; bitkey]
;;

let put sock key value =
  let buf = String.create 8192 in
  let bitstring = makePut key value in
  let query = Bitstring.string_of_bitstring bitstring in
  let len = String.length query in
    really_write sock query 0 len >>= (fun () ->
    Lwt_unix.read sock buf 0 8192 >>= (fun len' ->
    if len' = 0 then return () else begin
      print_endline (String.sub buf 0 len');
      return ()
    end))
;;