simple cache server example in core

tinycache.ml

open Core.Std
open Core_extended.Std
open Async.Std

module Protocol = struct
  module Client_message = struct
    type t = 
      | Get of string
      | Set of string * string
      | Quit with sexp
    let of_string s = 
      Option.try_with @@ fun () -> 
        match String.split ~on:' ' s with
        | "QUIT"::[] -> Quit
        | "GET"::k::[] -> Get k
        | "SET"::k::v::[] -> Set (k,v)
        | _ -> failwith "bad command"
  end
  module Server_message = struct
    type t = 
      | Ok of string
      | Inserted
      | Not_found with sexp
    let to_string = function
      | Inserted -> "INSERTED\r\n"
      | Ok m -> "OK\r\n" ^ m ^ "\r\n"
      | Not_found -> "NOT_FOUND\r\n"
  end
end

module type BoundedCache = sig
  type t
  val create : size:int -> t
  val get : t -> key:string -> string option
  val set : t -> key:string -> data:string -> unit
end

module CacheServer (Cache : BoundedCache) = struct
  open Protocol
  let process t req = 
    let open Client_message in
    match req with
    | Get key ->
      Server_message.(match Cache.get t ~key with
          | None -> Not_found
          | Some x -> Ok x)
    | Set (key, data) ->
      Cache.set t ~key ~data;
      Server_message.Inserted
    | Quit -> assert false

  let run_server ~host ~port ~size = 
    let cache = Cache.create ~size in
    Tcp.Server.create (Tcp.on_port port) @@ fun _ reader writer ->
      Deferred.create (fun finished ->
          let rec loop () =
            Reader.read_line reader >>> function
            | `Ok query ->
              (match Client_message.of_string query with
               | None -> loop ()
               | Some Client_message.Quit -> Ivar.fill finished ()
               | Some req ->
                 let resp = process cache req in
                 resp |> Server_message.to_string |> Writer.write writer;
                 loop ())
            | `Eof -> Ivar.fill finished ()
          in loop ())
end

module Lru = struct
  module L = Cache.Lru
  type t = (string, string) L.t
  let create ~size = L.create None size
  let get t ~key = L.find t key
  let set = L.add
end

let server =
  let module CS = CacheServer(Lru) in
  CS.run_server ~host:"127.0.0.1" ~port:12345 ~size:100

let () = Scheduler.go () |> never_returns