X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhbugs%2Fbroker%2Fhbugs_broker.ml;h=2ff8b98349dbf11853fbff1b676b706195b7c0df;hb=1fb8d0192e1f7ee891c53dc282c9c9f111e63e3c;hp=87a60bba7c093513e77bca8d4074b0573b7266d9;hpb=6a72ec9c2e81e6558a0163877129cc6227948e3e;p=helm.git diff --git a/helm/hbugs/broker/hbugs_broker.ml b/helm/hbugs/broker/hbugs_broker.ml index 87a60bba7..2ff8b9834 100644 --- a/helm/hbugs/broker/hbugs_broker.ml +++ b/helm/hbugs/broker/hbugs_broker.ml @@ -53,16 +53,28 @@ let return_xml_msg body outchan = Http_daemon.respond ~headers:["Content-Type", "text/xml"] ~body outchan ;; let parse_musing_id = function - | Musing_started (_, musing_id) -> musing_id + | Musing_started (_, musing_id) -> + prerr_endline ("#### Started musing ID: " ^ musing_id); + musing_id | Musing_aborted (_, musing_id) -> musing_id - | _ -> assert false + | msg -> + prerr_endline (sprintf "Assertion failed, received msg: %s" + (Hbugs_messages.string_of_msg msg)); + assert false ;; let do_critical = let mutex = Mutex.create () in fun action -> try - Mutex.lock mutex; let res = Lazy.force action in Mutex.unlock mutex; res +(* debug_print "Acquiring lock ..."; *) + Mutex.lock mutex; +(* debug_print "Lock Acquired!"; *) + let res = Lazy.force action in +(* debug_print "Releaseing lock ..."; *) + Mutex.unlock mutex; +(* debug_print "Lock released!"; *) + res with e -> Mutex.unlock mutex; raise e ;; @@ -84,9 +96,9 @@ let dump_registries () = String.concat "\n" (List.map (fun o -> o#dump) registries) in -let handle_msg outchan = function - +let handle_msg outchan msg = (* messages from clients *) + (match msg with | Help -> Hbugs_messages.respond_msg (Usage usage_string) outchan @@ -133,6 +145,10 @@ let handle_msg outchan = function | State_change (client_id, new_state) -> do_critical (lazy ( if clients#isAuthenticated client_id then begin let active_musings = musings#getByClientId client_id in + prerr_endline (sprintf "ACTIVE MUSINGS: %s" (String.concat ", " active_musings)); + if List.length active_musings = 0 then + prerr_endline ("No active musings for client " ^ client_id); + prerr_endline "CSC: State change!!!" ; let stop_answers = List.map (* collect Abort_musing message's responses *) (fun id -> (* musing id *) @@ -141,24 +157,33 @@ let handle_msg outchan = function ~url:(tutors#getUrl tutor) (Abort_musing (my_own_id, id))) active_musings in + let stopped_musing_ids = List.map parse_musing_id stop_answers in List.iter musings#unregister active_musings; - let started_musing_ids = - List.map (* register new musings and collect their ids *) - (fun tutor_id -> - let res = - Hbugs_messages.submit_req - ~url:(tutors#getUrl tutor_id) - (Start_musing (my_own_id, new_state)) - in - let musing_id = parse_musing_id res in - musings#register musing_id client_id tutor_id; - musing_id) - (clients#getSubscription client_id) - in - let stopped_musing_ids = List.map parse_musing_id stop_answers in - Hbugs_messages.respond_msg - (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids)) - outchan + (match new_state with + | Some new_state -> (* need to start new musings *) + let subscriptions = clients#getSubscription client_id in + if List.length subscriptions = 0 then + prerr_endline ("No subscriptions for client " ^ client_id); + let started_musing_ids = + List.map (* register new musings and collect their ids *) + (fun tutor_id -> + let res = + Hbugs_messages.submit_req + ~url:(tutors#getUrl tutor_id) + (Start_musing (my_own_id, new_state)) + in + let musing_id = parse_musing_id res in + musings#register musing_id client_id tutor_id; + musing_id) + subscriptions + in + Hbugs_messages.respond_msg + (State_accepted (my_own_id, stopped_musing_ids, started_musing_ids)) + outchan + | None -> (* no need to start new musings *) + Hbugs_messages.respond_msg + (State_accepted (my_own_id, stopped_musing_ids, [])) + outchan) end else Hbugs_messages.respond_exc "forbidden" client_id outchan )) @@ -179,32 +204,41 @@ let handle_msg outchan = function end else Hbugs_messages.respond_exc "forbidden" tutor_id outchan )) + | Musing_completed (tutor_id, musing_id, result) -> do_critical (lazy ( - if tutors#isAuthenticated tutor_id then begin + if not (tutors#isAuthenticated tutor_id) then begin (* unauthorized *) + Hbugs_messages.respond_exc "forbidden" tutor_id outchan; + end else if not (musings#isActive musing_id) then begin (* too late *) + Hbugs_messages.respond_msg (Too_late (my_own_id, musing_id)) outchan; + end else begin (* all is ok: autorhized and on time *) (match result with | Sorry -> () - | Eureka extras -> + | Eureka hint -> + let client_url = + clients#getUrl (fst (musings#getByMusingId musing_id)) + in let res = - let hint = (* TODO decidere la hint *) "hint!!!!" in - let url = - clients#getUrl (fst (musings#getByMusingId musing_id)) - in - Hbugs_messages.submit_req ~url (Hint (my_own_id, hint)) + Hbugs_messages.submit_req ~url:client_url (Hint (my_own_id, hint)) in - ignore res (* TODO mi interessa la risposta? *) - ); + (match res with + | Wow _ -> () (* ok: client is happy with our hint *) + | unexpected_msg -> + prerr_endline + (sprintf + "Warning: unexpected msg from client: %s\nExpected was: Wow" + (Hbugs_messages.string_of_msg msg)))); Hbugs_messages.respond_msg (Thanks (my_own_id, musing_id)) outchan; musings#unregister musing_id - end else - Hbugs_messages.respond_exc "forbidden" tutor_id outchan + end )) | msg -> (* unexpected message *) debug_print "Unknown message!"; Hbugs_messages.respond_exc - "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan + "unexpected_msg" (Hbugs_messages.string_of_msg msg) outchan) in -let handle_msg outchan = (* debugging wrapper around 'handle_msg' *) +(* (* DEBUGGING wrapper around 'handle_msg' *) +let handle_msg outchan = if debug then (fun msg -> (* filter handle_msg through a function which dumps input messages *) @@ -213,6 +247,7 @@ let handle_msg outchan = (* debugging wrapper around 'handle_msg' *) else handle_msg outchan in +*) (* thread action *) let callback (req: Http_types.request) outchan = @@ -222,7 +257,9 @@ let callback (req: Http_types.request) outchan = (match req#path with (* TODO write help message *) | "/help" -> return_xml_msg " not yet written " outchan - | "/act" -> handle_msg outchan (Hbugs_messages.msg_of_string req#body) + | "/act" -> + let msg = Hbugs_messages.msg_of_string req#body in + handle_msg outchan msg | "/dump" -> if debug then Http_daemon.respond ~body:(dump_registries ()) outchan