open Qptypes type pub_state = | Waiting | Running of string | Stopped let pub_state_of_string = function | "Waiting" -> Waiting | "Stopped" -> Stopped | s -> Running s let string_of_pub_state = function | Waiting -> "Waiting" | Stopped -> "Stopped" | Running s -> s type t = { queue : Queuing_system.t ; state : Message.State.t option ; address_tcp : Address.Tcp.t option ; address_inproc : Address.Inproc.t option ; progress_bar : Progress_bar.t option ; running : bool; accepting_clients : bool; data : (string, string) Hashtbl.t; } let debug_env = try Sys.getenv "QP_TASK_DEBUG" = "1" with Not_found -> false let debug str = if debug_env then Printf.eprintf "TASK : %s%!" str let zmq_context = Zmq.Context.create () let () = Zmq.Context.set_io_threads zmq_context 16 let bind_socket ~socket_type ~socket ~port = let rec loop = function | 0 -> failwith @@ Printf.sprintf "Unable to bind the %s socket to port : %d " socket_type port | -1 -> () | i -> try Zmq.Socket.bind socket @@ Printf.sprintf "tcp://*:%d" port; loop (-1) with | Unix.Unix_error _ -> (Unix.sleep 1 ; loop (i-1) ) | other_exception -> raise other_exception in loop 60 let hostname = lazy ( try Unix.gethostname () with | _ -> "localhost" ) external get_ipv4_address_for_interface : string -> string = "get_ipv4_address_for_interface" ;; let ip_address = lazy ( let interface = try Some (Sys.getenv "QP_NIC") with Not_found -> None in match interface with | None -> begin try let host = Lazy.force hostname |> Unix.gethostbyname in Unix.string_of_inet_addr host.h_addr_list.(0); with | Unix.Unix_error _ -> failwith "Unable to find IP address from host name." end | Some interface -> let result = get_ipv4_address_for_interface interface in if String.sub result 0 5 = "error" then Printf.sprintf "Unable to use network interface %s" interface |> failwith else result ) let reply_ok rep_socket = Message.Ok_msg.create |> Message.Ok_msg.to_string |> Zmq.Socket.send rep_socket let reply_wrong_state rep_socket = Message.Error_msg.create "Wrong state" |> Message.Error_msg.to_string |> Zmq.Socket.send rep_socket let stop ~port = debug "STOP"; let req_socket = Zmq.Socket.create zmq_context Zmq.Socket.req and address = Printf.sprintf "tcp://localhost:%d" port in Zmq.Socket.set_linger_period req_socket 1_000_000; Zmq.Socket.connect req_socket address; Message.Terminate (Message.Terminate_msg.create) |> Message.to_string |> Zmq.Socket.send req_socket ; let msg = Zmq.Socket.recv req_socket |> Message.of_string in let () = match msg with | Message.Ok _ -> () | _ -> failwith "Problem in termination" in Zmq.Socket.set_linger_period req_socket 1_000; Zmq.Socket.close req_socket let new_job msg program_state rep_socket pair_socket = let state = msg.Message.Newjob_msg.state in let progress_bar = Progress_bar.init ~start_value:0. ~end_value:1. ~bar_length:20 ~title:(Message.State.to_string state) in let result = { program_state with state = Some state ; progress_bar = Some progress_bar ; address_tcp = Some msg.Message.Newjob_msg.address_tcp; address_inproc = Some msg.Message.Newjob_msg.address_inproc; accepting_clients = true; } in reply_ok rep_socket; string_of_pub_state Waiting |> Zmq.Socket.send pair_socket ; result let change_pub_state msg program_state rep_socket pair_socket = let msg = match msg with | `Waiting -> Waiting | `Stopped -> Stopped | `Running -> begin let state = match program_state.state with | Some x -> x | None -> failwith "Trying to change pub state while no job is ready" in Running (Message.State.to_string state) end in reply_ok rep_socket; string_of_pub_state msg |> Zmq.Socket.send pair_socket ; program_state let force_state = Message.State.of_string "force" let end_job msg program_state rep_socket pair_socket = let failure () = reply_wrong_state rep_socket; program_state and success () = reply_ok rep_socket; { queue = Queuing_system.create (); state = None ; progress_bar = Progress_bar.clear (); address_tcp = None; address_inproc = None; running = true; accepting_clients = false; data = Hashtbl.create 23; } and wait n = Printf.sprintf "waiting for %d slaves..." n |> Message.Error_msg.create |> Message.Error_msg.to_string |> Zmq.Socket.send rep_socket ; program_state in match program_state.state with | None -> failure () | Some state -> begin if (msg.Message.Endjob_msg.state = force_state) then begin string_of_pub_state Waiting |> Zmq.Socket.send pair_socket ; success () end else if (msg.Message.Endjob_msg.state = state) then begin string_of_pub_state Waiting |> Zmq.Socket.send pair_socket ; if (Queuing_system.number_of_clients program_state.queue = 0) then success () else wait (Queuing_system.number_of_clients program_state.queue) end else failure () end let connect msg program_state rep_socket = let failure () = reply_wrong_state rep_socket; program_state in if (not program_state.accepting_clients) then failure () else match program_state.state with | None -> failure () | Some state -> let push_address = match msg with | Message.Connect_msg.Tcp -> begin match program_state.address_tcp with | Some address -> Address.Tcp address | None -> failwith "Error: No TCP address" end | Message.Connect_msg.Inproc -> begin match program_state.address_inproc with | Some address -> Address.Inproc address | None -> failwith "Error: No inproc address" end | Message.Connect_msg.Ipc -> assert false in let new_queue, client_id = Queuing_system.add_client program_state.queue in Message.ConnectReply (Message.ConnectReply_msg.create ~state:state ~client_id ~push_address) |> Message.to_string |> Zmq.Socket.send rep_socket ; { program_state with queue = new_queue } let disconnect msg program_state rep_socket = let state, client_id = msg.Message.Disconnect_msg.state, msg.Message.Disconnect_msg.client_id in let failure () = reply_wrong_state rep_socket; program_state and success () = let new_program_state = { program_state with queue = Queuing_system.del_client ~client_id program_state.queue } in Message.DisconnectReply (Message.DisconnectReply_msg.create ~state) |> Message.to_string |> Zmq.Socket.send rep_socket ; new_program_state in match program_state.state with | None -> assert false | Some state' -> begin if (state = state') then success () else failure () end let del_task msg program_state rep_socket = let state, task_ids = msg.Message.DelTask_msg.state, msg.Message.DelTask_msg.task_ids in let failure () = reply_wrong_state rep_socket; program_state and success () = let queue = List.fold_left (fun queue task_id -> Queuing_system.del_task ~task_id queue) program_state.queue task_ids in let accepting_clients = (Queuing_system.number_of_queued queue > Queuing_system.number_of_clients queue) in let new_program_state = { program_state with accepting_clients ; queue ; } in let more = (Queuing_system.number_of_tasks queue > 0) in Message.DelTaskReply (Message.DelTaskReply_msg.create ~task_ids ~more) |> Message.to_string |> Zmq.Socket.send ~block:true rep_socket ; (** /!\ Has to be blocking *) new_program_state in match program_state.state with | None -> assert false | Some state' -> begin if (state = state') then success () else failure () end let add_task msg program_state rep_socket = let state, tasks = msg.Message.AddTask_msg.state, msg.Message.AddTask_msg.tasks in let increment_progress_bar = function | Some bar -> Some (Progress_bar.increment_end bar) | None -> None in let result = let new_queue, new_bar = List.fold_left (fun (queue, bar) task -> Queuing_system.add_task ~task queue, increment_progress_bar bar) (program_state.queue, program_state.progress_bar) tasks in { program_state with queue = new_queue; progress_bar = new_bar } in reply_ok rep_socket; result let get_task msg program_state rep_socket pair_socket = let state, client_id = msg.Message.GetTask_msg.state, msg.Message.GetTask_msg.client_id in let failure () = reply_wrong_state rep_socket; program_state and success () = let queue, task_id, task = Queuing_system.pop_task ~client_id program_state.queue in let accepting_clients = (Queuing_system.number_of_queued queue > Queuing_system.number_of_clients queue) in let no_task = Queuing_system.number_of_queued queue = 0 in if no_task then string_of_pub_state Waiting |> Zmq.Socket.send pair_socket else string_of_pub_state (Running (Message.State.to_string state)) |> Zmq.Socket.send pair_socket; let new_program_state = { program_state with queue ; accepting_clients; } in Message.GetTaskReply (Message.GetTaskReply_msg.create ~task ~task_id) |> Message.to_string |> Zmq.Socket.send rep_socket ; new_program_state in match program_state.state with | None -> assert false | Some state' -> begin if (state = state') then success () else failure () end let get_tasks msg program_state rep_socket pair_socket = let state, client_id, n_tasks = msg.Message.GetTasks_msg.state, msg.Message.GetTasks_msg.client_id, Strictly_positive_int.to_int msg.Message.GetTasks_msg.n_tasks in let failure () = reply_wrong_state rep_socket; program_state and success () = let rec build_list accu queue = function | 0 -> queue, (List.rev accu) | n -> let new_queue, task_id, task = Queuing_system.pop_task ~client_id queue in match (task_id, task) with | Some task_id, Some task -> build_list ( (Some task_id, task)::accu ) new_queue (n-1) | _ -> build_list ( (None, "terminate")::accu ) queue 0 in let new_queue, result = build_list [] program_state.queue (n_tasks) in let no_task = Queuing_system.number_of_queued new_queue = 0 in let accepting_clients = (Queuing_system.number_of_queued new_queue > Queuing_system.number_of_clients new_queue) in if no_task then string_of_pub_state Waiting |> Zmq.Socket.send pair_socket else string_of_pub_state (Running (Message.State.to_string state)) |> Zmq.Socket.send pair_socket; let new_program_state = { program_state with queue = new_queue; accepting_clients; } in Message.GetTasksReply (Message.GetTasksReply_msg.create result) |> Message.to_string_list |> Zmq.Socket.send_all rep_socket ; new_program_state in match program_state.state with | None -> assert false | Some state' -> begin if (state = state') then success () else failure () end let task_done msg program_state rep_socket = let state, client_id, task_ids = msg.Message.TaskDone_msg.state, msg.Message.TaskDone_msg.client_id, msg.Message.TaskDone_msg.task_ids in let increment_progress_bar = function | Some bar -> Some (Progress_bar.increment_cur bar) | None -> None in let failure () = reply_wrong_state rep_socket; program_state and success () = let new_queue, new_bar = List.fold_left (fun (queue, bar) task_id -> Queuing_system.end_task ~task_id ~client_id queue, increment_progress_bar bar) (program_state.queue, program_state.progress_bar) task_ids in let accepting_clients = (Queuing_system.number_of_queued new_queue > Queuing_system.number_of_clients new_queue) in let result = { program_state with queue = new_queue; progress_bar = new_bar; accepting_clients } in reply_ok rep_socket; result in match program_state.state with | None -> assert false | Some state' -> begin if (state = state') then success () else failure () end let put_data msg rest_of_msg program_state rep_socket = debug (Message.PutData_msg.to_string msg); let state, key, value = msg.Message.PutData_msg.state, msg.Message.PutData_msg.key, match rest_of_msg with | [ x ] -> x | _ -> failwith "Badly formed put_data message" in let success () = Hashtbl.add program_state.data key value ; Message.PutDataReply (Message.PutDataReply_msg.create ()) |> Message.to_string |> Zmq.Socket.send rep_socket; program_state and failure () = reply_wrong_state rep_socket; program_state in match program_state.state with | None -> assert false | Some state' -> if (state = state') then success () else failure () let get_data msg program_state rep_socket = debug (Message.GetData_msg.to_string msg); let state, key = msg.Message.GetData_msg.state, msg.Message.GetData_msg.key in let success () = let value = try Hashtbl.find program_state.data key with | Not_found -> "\000" in Message.GetDataReply (Message.GetDataReply_msg.create ~value) |> Message.to_string_list |> Zmq.Socket.send_all rep_socket; program_state and failure () = reply_wrong_state rep_socket; program_state in match program_state.state with | None -> assert false | Some state' -> if (state = state') then success () else failure () let terminate program_state rep_socket = reply_ok rep_socket; { program_state with address_tcp = None; address_inproc = None; running = false } let abort program_state rep_socket = let queue, client_id = Queuing_system.add_client program_state.queue in let rec aux accu queue = function | 0 -> (queue, accu) | rest -> let new_queue, task_id, _ = Queuing_system.pop_task ~client_id queue in let new_accu = match task_id with | Some task_id -> task_id::accu | None -> accu in Queuing_system.number_of_queued new_queue |> aux new_accu new_queue in let queue, tasks = aux [] queue 1 in let queue = List.fold_left (fun queue task_id -> Queuing_system.end_task ~task_id ~client_id queue) queue tasks in let queue = List.fold_left (fun queue task_id -> Queuing_system.del_task ~task_id queue) queue tasks in let queue = Queuing_system.del_client ~client_id queue in reply_ok rep_socket; { program_state with queue ; accepting_clients = false; } let error msg program_state rep_socket = Message.Error (Message.Error_msg.create msg) |> Message.to_string |> Zmq.Socket.send rep_socket ; program_state let start_pub_thread ~port = Thread.create (fun () -> let timeout = 1000 in let pair_socket = Zmq.Socket.create zmq_context Zmq.Socket.pair and address = "inproc://pair" in Zmq.Socket.connect pair_socket address; let pub_socket = Zmq.Socket.create zmq_context Zmq.Socket.pub in bind_socket ~socket_type:"PUB" ~socket:pub_socket ~port; let pollitem = Zmq.Poll.mask_of [| (pair_socket, Zmq.Poll.In) |] in let rec run state = let new_state = let polling = Zmq.Poll.poll ~timeout pollitem in if (polling.(0) = Some Zmq.Poll.In) then Zmq.Socket.recv ~block:false pair_socket |> pub_state_of_string else state in Zmq.Socket.send pub_socket @@ string_of_pub_state new_state; match state with | Stopped -> () | _ -> run new_state in run Waiting; Zmq.Socket.set_linger_period pair_socket 1000 ; Zmq.Socket.close pair_socket; Zmq.Socket.set_linger_period pub_socket 1000 ; Zmq.Socket.close pub_socket; ) let run ~port = (** Bind inproc socket for changing state of pub *) let pair_socket = Zmq.Socket.create zmq_context Zmq.Socket.pair and address = "inproc://pair" in Zmq.Socket.bind pair_socket address; let pub_thread = start_pub_thread ~port:(port+1) () in (** Bind REP socket *) let rep_socket = Zmq.Socket.create zmq_context Zmq.Socket.rep in Zmq.Socket.set_linger_period rep_socket 1_000_000; bind_socket "REP" rep_socket port; let initial_program_state = { queue = Queuing_system.create () ; running = true ; state = None; address_tcp = None; address_inproc = None; progress_bar = None ; accepting_clients = false; data = Hashtbl.create 23; } in (** ZMR polling item *) let pollitem = Zmq.Poll.mask_of [| (rep_socket, Zmq.Poll.In) |] in let address = Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port in Printf.printf "Task server running : %s\n%!" address; (** Main loop *) let rec main_loop program_state = function | false -> () | true -> let polling = Zmq.Poll.poll ~timeout:1000 pollitem in if (polling.(0) <> Some Zmq.Poll.In) then main_loop program_state true else begin let program_state = match program_state.progress_bar with | None -> program_state | Some bar -> if bar.Progress_bar.dirty then { program_state with progress_bar = Some (Progress_bar.display bar) } else program_state in (** Extract message *) let raw_message, rest = match Zmq.Socket.recv_all rep_socket with | x :: rest -> x, rest | [] -> failwith "Badly formed message" in let message = Message.of_string raw_message in (** Debug input *) let () = if debug_env then begin Printf.sprintf "q:%d r:%d n:%d c:%d : %s\n%!" (Queuing_system.number_of_queued program_state.queue) (Queuing_system.number_of_running program_state.queue) (Queuing_system.number_of_tasks program_state.queue) (Queuing_system.number_of_clients program_state.queue) (Message.to_string message) |> debug end in let new_program_state = try match program_state.state, message with | _ , Message.Terminate _ -> terminate program_state rep_socket | _ , Message.Abort _ -> abort program_state rep_socket | _ , Message.PutData x -> put_data x rest program_state rep_socket | _ , Message.GetData x -> get_data x program_state rep_socket | None , Message.Newjob x -> new_job x program_state rep_socket pair_socket | _ , Message.Newjob _ -> error "A job is already running" program_state rep_socket | Some _, Message.Endjob x -> end_job x program_state rep_socket pair_socket | Some _, Message.SetRunning -> change_pub_state `Running program_state rep_socket pair_socket | _, Message.SetWaiting -> change_pub_state `Waiting program_state rep_socket pair_socket | _, Message.SetStopped -> change_pub_state `Stopped program_state rep_socket pair_socket | None , _ -> error "No job is running" program_state rep_socket | Some _, Message.Connect x -> connect x program_state rep_socket | Some _, Message.Disconnect x -> disconnect x program_state rep_socket | Some _, Message.AddTask x -> add_task x program_state rep_socket | Some _, Message.DelTask x -> del_task x program_state rep_socket | Some _, Message.GetTask x -> get_task x program_state rep_socket pair_socket | Some _, Message.GetTasks x -> get_tasks x program_state rep_socket pair_socket | Some _, Message.TaskDone x -> task_done x program_state rep_socket | _ , _ -> error ("Invalid message : "^(Message.to_string message)) program_state rep_socket with | Failure f -> error (f^" : "^raw_message) program_state rep_socket | Assert_failure (f,i,j) -> error (Printf.sprintf "%s:%d:%d : %s" f i j raw_message) program_state rep_socket in main_loop new_program_state new_program_state.running end in main_loop initial_program_state true; Zmq.Socket.send pair_socket @@ string_of_pub_state Stopped; Thread.join pub_thread; Zmq.Socket.close rep_socket