mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-12-27 13:53:29 +01:00
276 lines
8.5 KiB
OCaml
276 lines
8.5 KiB
OCaml
|
{
|
||
|
|
|
||
|
|
type kw_type =
|
||
|
|
| TEXT of string
|
||
|
|
| WORD of string
|
||
|
|
| INTEGER of int
|
||
|
|
| FLOAT of float
|
||
|
|
| NONE
|
||
|
|
| ADD_TASK
|
||
|
|
| DEL_TASK
|
||
|
|
| GET_TASK
|
||
|
|
| GET_TASKS
|
||
|
|
| TASK_DONE
|
||
|
|
| DISCONNECT
|
||
|
|
| CONNECT
|
||
|
|
| NEW_JOB
|
||
|
|
| END_JOB
|
||
|
|
| TERMINATE
|
||
|
|
| ABORT
|
||
|
|
| GET_DATA
|
||
|
|
| PUT_DATA
|
||
|
|
| OK
|
||
|
|
| ERROR
|
||
|
|
| SET_STOPPED
|
||
|
|
| SET_RUNNING
|
||
|
|
| SET_WAITING
|
||
|
|
|
||
|
|
type state_tasks = { state : string ; tasks : string list ; }
|
||
|
|
type state_taskids = { state : string ; task_ids : int list ; }
|
||
|
|
type state_taskids_clientid = { state : string ; task_ids : int list ; client_id : int ; }
|
||
|
|
type state_clientid = { state : string ; client_id : int ; }
|
||
|
|
type state_clientid_ntasks = { state : string ; client_id : int ; n_tasks : int}
|
||
|
|
type state_tcp_inproc = { state : string ; push_address_tcp : string ; push_address_inproc : string ; }
|
||
|
|
type psi = { client_id: int ; n_state: int ; n_det: int ; psi_det_size: int ;
|
||
|
|
n_det_generators: int option ; n_det_selectors: int option ; }
|
||
|
|
type state_client_id_key = { state: string ; client_id: int ; key: string }
|
||
|
|
|
||
|
|
type msg =
|
||
|
|
| AddTask_ of state_tasks
|
||
|
|
| DelTask_ of state_taskids
|
||
|
|
| GetTask_ of state_clientid
|
||
|
|
| GetTasks_ of state_clientid_ntasks
|
||
|
|
| TaskDone_ of state_taskids_clientid
|
||
|
|
| Disconnect_ of state_clientid
|
||
|
|
| Connect_ of string
|
||
|
|
| NewJob_ of state_tcp_inproc
|
||
|
|
| EndJob_ of string
|
||
|
|
| Terminate_
|
||
|
|
| Abort_
|
||
|
|
| GetData_ of state_client_id_key
|
||
|
|
| PutData_ of state_client_id_key
|
||
|
|
| Ok_
|
||
|
|
| Error_ of string
|
||
|
|
| SetStopped_
|
||
|
|
| SetRunning_
|
||
|
|
| SetWaiting_
|
||
|
|
}
|
||
|
|
|
||
|
|
let word = [^' ' '\t' '\n']+
|
||
|
|
let text = [^ ' ' '|']+[^ '|']+
|
||
|
|
let integer = ['0'-'9']+
|
||
|
|
let real = '-'? integer '.' integer (['e' 'E'] '-'? integer)?
|
||
|
|
|
||
|
|
let white = [' ' '\t']+
|
||
|
|
|
||
|
|
|
||
|
|
rule get_text = parse
|
||
|
|
| text as t { TEXT t }
|
||
|
|
| eof { TERMINATE }
|
||
|
|
| _ { NONE }
|
||
|
|
|
||
|
|
and get_int = parse
|
||
|
|
| integer as i { INTEGER (int_of_string i) }
|
||
|
|
| eof { TERMINATE }
|
||
|
|
| _ { NONE }
|
||
|
|
|
||
|
|
and get_word = parse
|
||
|
|
| word as w { WORD w }
|
||
|
|
| eof { TERMINATE }
|
||
|
|
| _ { NONE }
|
||
|
|
|
||
|
|
and kw = parse
|
||
|
|
| "add_task" { ADD_TASK }
|
||
|
|
| "del_task" { DEL_TASK }
|
||
|
|
| "get_task" { GET_TASK }
|
||
|
|
| "get_tasks" { GET_TASKS }
|
||
|
|
| "task_done" { TASK_DONE }
|
||
|
|
| "disconnect" { DISCONNECT }
|
||
|
|
| "connect" { CONNECT }
|
||
|
|
| "new_job" { NEW_JOB }
|
||
|
|
| "end_job" { END_JOB }
|
||
|
|
| "put_data" { PUT_DATA }
|
||
|
|
| "get_data" { GET_DATA }
|
||
|
|
| "terminate" { TERMINATE }
|
||
|
|
| "abort" { ABORT }
|
||
|
|
| "ok" { OK }
|
||
|
|
| "error" { ERROR }
|
||
|
|
| "set_stopped" { SET_STOPPED }
|
||
|
|
| "set_running" { SET_RUNNING }
|
||
|
|
| "set_waiting" { SET_WAITING }
|
||
|
|
| _ { NONE }
|
||
|
|
|
||
|
|
|
||
|
|
{
|
||
|
|
let rec read_text ?(accu=[]) lexbuf =
|
||
|
|
let token =
|
||
|
|
get_text lexbuf
|
||
|
|
in
|
||
|
|
match token with
|
||
|
|
| TEXT t -> read_text ~accu:(t::accu) lexbuf
|
||
|
|
| TERMINATE -> List.rev accu
|
||
|
|
| NONE -> read_text ~accu lexbuf
|
||
|
|
| _ -> failwith "Error in MessageLexer (2)"
|
||
|
|
|
||
|
|
and read_word lexbuf =
|
||
|
|
let token =
|
||
|
|
get_word lexbuf
|
||
|
|
in
|
||
|
|
match token with
|
||
|
|
| WORD w -> w
|
||
|
|
| NONE -> read_word lexbuf
|
||
|
|
| _ -> failwith "Error in MessageLexer (3)"
|
||
|
|
|
||
|
|
and read_int lexbuf =
|
||
|
|
let token =
|
||
|
|
get_int lexbuf
|
||
|
|
in
|
||
|
|
match token with
|
||
|
|
| INTEGER i -> i
|
||
|
|
| NONE -> read_int lexbuf
|
||
|
|
| _ -> failwith "Error in MessageLexer (4)"
|
||
|
|
|
||
|
|
and read_ints ?(accu=[]) lexbuf =
|
||
|
|
let token =
|
||
|
|
get_int lexbuf
|
||
|
|
in
|
||
|
|
match token with
|
||
|
|
| INTEGER i -> read_ints ~accu:(i::accu) lexbuf
|
||
|
|
| TERMINATE -> List.rev accu
|
||
|
|
| NONE -> read_ints ~accu lexbuf
|
||
|
|
| _ -> failwith "Error in MessageLexer (4)"
|
||
|
|
|
||
|
|
and parse_rec lexbuf =
|
||
|
|
let token =
|
||
|
|
kw lexbuf
|
||
|
|
in
|
||
|
|
match token with
|
||
|
|
| ADD_TASK ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
let tasks = read_text lexbuf in
|
||
|
|
AddTask_ { state ; tasks }
|
||
|
|
|
||
|
|
| DEL_TASK ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
let task_ids = read_ints lexbuf in
|
||
|
|
DelTask_ { state ; task_ids }
|
||
|
|
|
||
|
|
| GET_TASK ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
let client_id = read_int lexbuf in
|
||
|
|
GetTask_ { state ; client_id }
|
||
|
|
|
||
|
|
| GET_TASKS ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
let client_id = read_int lexbuf in
|
||
|
|
let n_tasks = read_int lexbuf in
|
||
|
|
GetTasks_ { state ; client_id ; n_tasks }
|
||
|
|
|
||
|
|
| TASK_DONE ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
let client_id = read_int lexbuf in
|
||
|
|
let task_ids = read_ints lexbuf in
|
||
|
|
TaskDone_ { state ; task_ids ; client_id }
|
||
|
|
|
||
|
|
| DISCONNECT ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
let client_id = read_int lexbuf in
|
||
|
|
Disconnect_ { state ; client_id }
|
||
|
|
|
||
|
|
| GET_DATA ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
let client_id = read_int lexbuf in
|
||
|
|
let key = read_word lexbuf in
|
||
|
|
GetData_ { state ; client_id ; key }
|
||
|
|
|
||
|
|
| PUT_DATA ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
let client_id = read_int lexbuf in
|
||
|
|
let key = read_word lexbuf in
|
||
|
|
PutData_ { state ; client_id ; key }
|
||
|
|
|
||
|
|
| CONNECT ->
|
||
|
|
let socket = read_word lexbuf in
|
||
|
|
Connect_ socket
|
||
|
|
|
||
|
|
| NEW_JOB ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
let push_address_tcp = read_word lexbuf in
|
||
|
|
let push_address_inproc = read_word lexbuf in
|
||
|
|
NewJob_ { state ; push_address_tcp ; push_address_inproc }
|
||
|
|
|
||
|
|
| END_JOB ->
|
||
|
|
let state = read_word lexbuf in
|
||
|
|
EndJob_ state
|
||
|
|
|
||
|
|
| ERROR ->
|
||
|
|
let message = List.hd (read_text lexbuf) in
|
||
|
|
Error_ message
|
||
|
|
|
||
|
|
| OK -> Ok_
|
||
|
|
| SET_WAITING -> SetWaiting_
|
||
|
|
| SET_RUNNING -> SetRunning_
|
||
|
|
| SET_STOPPED -> SetStopped_
|
||
|
|
| TERMINATE -> Terminate_
|
||
|
|
| ABORT -> Abort_
|
||
|
|
| NONE -> parse_rec lexbuf
|
||
|
|
| _ -> failwith "Error in MessageLexer"
|
||
|
|
|
||
|
|
let parse message =
|
||
|
|
let lexbuf =
|
||
|
|
Lexing.from_string message
|
||
|
|
in
|
||
|
|
parse_rec lexbuf
|
||
|
|
|
||
|
|
|
||
|
|
let debug () =
|
||
|
|
let l = [
|
||
|
|
"add_task state_pouet Task pouet zob" ;
|
||
|
|
"add_task state_pouet Task pouet zob |Task2 zob | Task3 prout" ;
|
||
|
|
"del_task state_pouet 12345" ;
|
||
|
|
"del_task state_pouet 12345 | 6789 | 10 | 11" ;
|
||
|
|
"get_task state_pouet 12" ;
|
||
|
|
"get_tasks state_pouet 12 23" ;
|
||
|
|
"task_done state_pouet 12 12345";
|
||
|
|
"task_done state_pouet 12 12345 | 678 | 91011";
|
||
|
|
"connect tcp";
|
||
|
|
"disconnect state_pouet 12";
|
||
|
|
"new_job state_pouet tcp://test.com:12345 ipc:///dev/shm/x.socket";
|
||
|
|
"end_job state_pouet";
|
||
|
|
"terminate" ;
|
||
|
|
"abort" ;
|
||
|
|
"set_running" ;
|
||
|
|
"set_stopped" ;
|
||
|
|
"set_waiting" ;
|
||
|
|
"ok" ;
|
||
|
|
"error my_error" ;
|
||
|
|
"get_psi 12" ;
|
||
|
|
"put_psi 12 2 1000 10000 800 900" ;
|
||
|
|
"put_psi 12 2 1000 10000"
|
||
|
|
]
|
||
|
|
|> List.map parse
|
||
|
|
in
|
||
|
|
List.map (function
|
||
|
|
| AddTask_ { state ; tasks } -> Printf.sprintf "ADD_TASK state:\"%s\" tasks:{\"%s\"}" state (String.concat "\"}|{\"" tasks)
|
||
|
|
| DelTask_ { state ; task_ids } -> Printf.sprintf "DEL_TASK state:\"%s\" task_ids:{%s}" state (String.concat "|" @@ List.map string_of_int task_ids)
|
||
|
|
| GetTask_ { state ; client_id } -> Printf.sprintf "GET_TASK state:\"%s\" task_id:%d" state client_id
|
||
|
|
| GetTasks_ { state ; client_id ; n_tasks } -> Printf.sprintf "GET_TASKS state:\"%s\" task_id:%d n_tasks:%d" state client_id n_tasks
|
||
|
|
| TaskDone_ { state ; task_ids ; client_id } -> Printf.sprintf "TASK_DONE state:\"%s\" task_ids:{%s} client_id:%d" state (String.concat "|" @@ List.map string_of_int task_ids) client_id
|
||
|
|
| Disconnect_ { state ; client_id } -> Printf.sprintf "DISCONNECT state:\"%s\" client_id:%d" state client_id
|
||
|
|
| Connect_ socket -> Printf.sprintf "CONNECT socket:\"%s\"" socket
|
||
|
|
| NewJob_ { state ; push_address_tcp ; push_address_inproc } -> Printf.sprintf "NEW_JOB state:\"%s\" tcp:\"%s\" inproc:\"%s\"" state push_address_tcp push_address_inproc
|
||
|
|
| EndJob_ state -> Printf.sprintf "END_JOB state:\"%s\"" state
|
||
|
|
| GetData_ { state ; client_id; key } -> Printf.sprintf "GET_DATA state:%s client_id:%d key:%s" state client_id key
|
||
|
|
| PutData_ { state ; client_id ; key } -> Printf.sprintf "PUT_DATA state:%s client_id:%d key:%s" state client_id key
|
||
|
|
| Terminate_ -> "TERMINATE"
|
||
|
|
| Abort_ -> "ABORT"
|
||
|
|
| SetWaiting_ -> "SET_WAITING"
|
||
|
|
| SetStopped_ -> "SET_STOPPED"
|
||
|
|
| SetRunning_ -> "SET_RUNNING"
|
||
|
|
| Ok_ -> "OK"
|
||
|
|
| Error_ s -> Printf.sprintf "ERROR: \"%s\"" s
|
||
|
|
) l
|
||
|
|
|> List.iter print_endline
|
||
|
|
|
||
|
|
}
|