Summary: Not used feature and with no obvious roadmap anymore. Reviewed By: jberdine, jvillard Differential Revision: D17855860 fbshipit-source-id: fd75b9d62master
Nikos Gorogiannis
5 years ago
committed by
Facebook Github Bot
parent
765e0bf2f4
commit
432d391a32
@ -1,181 +0,0 @@
|
||||
(*
|
||||
* Copyright (c) Facebook, Inc. and its affiliates.
|
||||
*
|
||||
* This source code is licensed under the MIT license found in the
|
||||
* LICENSE file in the root directory of this source tree.
|
||||
*)
|
||||
open! IStd
|
||||
module L = Logging
|
||||
|
||||
(** unix socket name, always relative to the master [results_dir] *)
|
||||
let memcached_socket_relative = "memcached.socket"
|
||||
|
||||
(** find the results_dir of the top-level infer process *)
|
||||
let results_dir = Config.toplevel_results_dir
|
||||
|
||||
(** log file for memcached *)
|
||||
let memcached_log = results_dir ^ "/memcached.log"
|
||||
|
||||
(** binary name -- assumed to be on path *)
|
||||
let memcached_bin = "memcached"
|
||||
|
||||
(** shell to use for redirecting memcached's output to the log *)
|
||||
let shell = "sh"
|
||||
|
||||
type server = {input: In_channel.t; output: Out_channel.t}
|
||||
|
||||
(** Unix socket *paths* have a historical length limit of ~100 chars (!?*@&*$). However, this only applies
|
||||
to the argument passed in the system call to create the socket, not to the actual path.
|
||||
Thus a workaround is to cd into the parent dir of the socket and then use it, hence this function. *)
|
||||
let in_results_dir ~f = Utils.do_in_dir ~dir:results_dir ~f
|
||||
|
||||
let fail_on response_line = L.die InternalError "Unexpected server response: %s" response_line
|
||||
|
||||
let send server str = Out_channel.output_string server.output str
|
||||
|
||||
let eol = "\r\n"
|
||||
|
||||
let send_eol server = send server eol
|
||||
|
||||
let flush_server server = Out_channel.flush server.output
|
||||
|
||||
let send_line server str = send server str ; send_eol server ; flush_server server
|
||||
|
||||
let recv_line server =
|
||||
match In_channel.input_line ~fix_win_eol:true server.input with
|
||||
| None ->
|
||||
fail_on "No response"
|
||||
| Some line ->
|
||||
line
|
||||
|
||||
|
||||
let expect_line server lines =
|
||||
match recv_line server with
|
||||
| x when List.exists lines ~f:(String.equal x) ->
|
||||
()
|
||||
| response ->
|
||||
fail_on response
|
||||
|
||||
|
||||
(** socket to memcached server *)
|
||||
let server : server option ref = ref None
|
||||
|
||||
let with_server ~f =
|
||||
match !server with
|
||||
| None ->
|
||||
L.die InternalError "Asked to perform socket operation without live connection.@."
|
||||
| Some s ->
|
||||
f s
|
||||
|
||||
|
||||
let disconnect () =
|
||||
with_server ~f:(fun s ->
|
||||
server := None ;
|
||||
Unix.shutdown_connection s.input ;
|
||||
(* For some reason the below sometimes throws -- wrong docs? *)
|
||||
(* In_channel.close s.input ; *)
|
||||
Out_channel.close s.output )
|
||||
|
||||
|
||||
let connect () =
|
||||
if Option.is_some !server then
|
||||
L.die InternalError "Asked to connect memcached while already connected.@." ;
|
||||
in_results_dir ~f:(fun () ->
|
||||
let input, output = Unix.open_connection (ADDR_UNIX memcached_socket_relative) in
|
||||
server := Some {input; output} )
|
||||
|
||||
|
||||
let stats server =
|
||||
let rec aux acc = match recv_line server with "END" -> List.rev acc | l -> aux (l :: acc) in
|
||||
send_line server "stats" ; aux []
|
||||
|
||||
|
||||
let stop pid () =
|
||||
connect () ;
|
||||
let stats = with_server ~f:stats in
|
||||
disconnect () ;
|
||||
Signal.send Signal.term (`Pid pid) |> ignore ;
|
||||
Unix.wait (`Pid pid) |> ignore ;
|
||||
in_results_dir ~f:(fun () -> Unix.remove memcached_socket_relative) ;
|
||||
Out_channel.(with_file memcached_log ~append:true ~f:(fun ch -> output_lines ch stats))
|
||||
|
||||
|
||||
let start () =
|
||||
let socket_exists () =
|
||||
in_results_dir ~f:(fun () -> Sys.file_exists_exn memcached_socket_relative)
|
||||
in
|
||||
if Option.is_some !server then
|
||||
L.die InternalError "Connection is open but asked to start memcached.@." ;
|
||||
(* Unix sockets can be shadowed, so avoid creating a new socket/server if there is one already *)
|
||||
if socket_exists () then ()
|
||||
else
|
||||
let verbosity = match Config.debug_level_analysis with 0 -> "" | 1 -> "-v" | _ -> "-vv" in
|
||||
let cmd =
|
||||
Printf.sprintf "exec %s %s -Bascii -C -m%d -s%s > %s 2>&1" memcached_bin verbosity
|
||||
Config.memcached_size_mb memcached_socket_relative memcached_log
|
||||
in
|
||||
let pid = in_results_dir ~f:(Unix.fork_exec ~prog:shell ~argv:[shell; "-c"; cmd]) in
|
||||
(* Wait until socket is open -- NB this waits for 0.05s not 0.05ns *)
|
||||
while not (socket_exists ()) do
|
||||
Unix.nanosleep 0.05 |> ignore
|
||||
done ;
|
||||
Epilogues.register ~description:"Shutdown Memcached daemon" ~f:(stop pid)
|
||||
|
||||
|
||||
module type Value = sig
|
||||
type t
|
||||
|
||||
val label : string
|
||||
end
|
||||
|
||||
module type Server = sig
|
||||
module Value : Value
|
||||
|
||||
val get : key:string -> Value.t option
|
||||
|
||||
val set : key:string -> Value.t -> unit
|
||||
end
|
||||
|
||||
module Make (V : Value) : Server with module Value = V = struct
|
||||
module Value = V
|
||||
|
||||
let set_ =
|
||||
let buffer = ref (Bytes.create 1024) in
|
||||
let rec try_to_buffer value =
|
||||
try Marshal.to_buffer !buffer 0 (Bytes.length !buffer) value []
|
||||
with Failure _ ->
|
||||
(* double buffer length *)
|
||||
buffer := Bytes.create (2 * Bytes.length !buffer) ;
|
||||
try_to_buffer value
|
||||
in
|
||||
fun server ~key value ->
|
||||
let value_length = try_to_buffer value in
|
||||
Printf.fprintf server.output "set %s:%s 0 0 %d%s" Value.label key value_length eol ;
|
||||
Out_channel.output server.output ~buf:!buffer ~pos:0 ~len:value_length ;
|
||||
send_eol server ;
|
||||
flush_server server ;
|
||||
expect_line server ["STORED"; "SERVER_ERROR object too large for cache"]
|
||||
|
||||
|
||||
let get_ server ~key =
|
||||
Printf.fprintf server.output "get %s:%s%s" Value.label key eol ;
|
||||
flush_server server ;
|
||||
let value_line = recv_line server in
|
||||
match String.split value_line ~on:' ' with
|
||||
| ["END"] ->
|
||||
None
|
||||
| ["VALUE"; _key'; _flags; _bytes] ->
|
||||
let value : Value.t = Marshal.from_channel server.input in
|
||||
(* eat up the trailing eol *)
|
||||
expect_line server [""] ;
|
||||
expect_line server ["END"] ;
|
||||
Some value
|
||||
| _ ->
|
||||
fail_on value_line
|
||||
|
||||
|
||||
let get ~key = with_server ~f:(get_ ~key)
|
||||
|
||||
(* TODO: do this on background thread to avoid blocking on the response *)
|
||||
let set ~key value = with_server ~f:(fun s -> set_ s ~key value)
|
||||
end
|
||||
@ -1,39 +0,0 @@
|
||||
(*
|
||||
* Copyright (c) Facebook, Inc. and its affiliates.
|
||||
*
|
||||
* This source code is licensed under the MIT license found in the
|
||||
* LICENSE file in the root directory of this source tree.
|
||||
*)
|
||||
open! IStd
|
||||
|
||||
(** Interface for managing a (single) memcached daemon and getting/setting OCaml values *)
|
||||
|
||||
val connect : unit -> unit
|
||||
(** connect to a running memcached server -- only call this from processes which do not fork *)
|
||||
|
||||
val disconnect : unit -> unit
|
||||
(** disconnect after having connected first *)
|
||||
|
||||
val start : unit -> unit
|
||||
(** start a memcached daemon and set up an epilogue to kill it on exit -- only for top-level *)
|
||||
|
||||
(** type to marshal, plus a unique label that will be colon-prepended to a key,
|
||||
roughly signifying a table *)
|
||||
module type Value = sig
|
||||
type t
|
||||
|
||||
val label : string
|
||||
end
|
||||
|
||||
module type Server = sig
|
||||
module Value : Value
|
||||
|
||||
val get : key:string -> Value.t option
|
||||
(** get a value, [None] means no [key] exists *)
|
||||
|
||||
val set : key:string -> Value.t -> unit
|
||||
(** set a [key]/value pair. NB we swallow failures due to exceeding max value size currently.
|
||||
This will need to be changed before memcached is used as a primary store. *)
|
||||
end
|
||||
|
||||
module Make (V : Value) : Server with module Value = V
|
||||
Loading…
Reference in new issue