From 0dbf5d67e29fac1b7c5d8b857ad2ef5e6ec6044a Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Fri, 20 Nov 2020 07:21:47 +0100 Subject: [PATCH] Factorize common code of counting method handlers --- src/web/site_voter.ml | 140 +++++++++++++++++++----------------------- 1 file changed, 63 insertions(+), 77 deletions(-) diff --git a/src/web/site_voter.ml b/src/web/site_voter.ml index 40fda10..c68dd99 100644 --- a/src/web/site_voter.ml +++ b/src/web/site_voter.ml @@ -235,92 +235,78 @@ let () = String.send (b, "application/json") >>= (fun x -> return @@ cast_unknown_content_kind x)) +let handle_method uuid question f = + let%lwt l = get_preferred_gettext () in + let open (val l) in + match%lwt find_election uuid with + | None -> election_not_found () + | Some election -> + let questions = election.e_params.e_questions in + if 0 <= question && question < Array.length questions then ( + match questions.(question) with + | Question.NonHomomorphic q -> + f l q + (fun continuation -> + match%lwt Web_persist.get_election_result uuid with + | Some result -> + (Shape.to_shape_array result.result).(question) + |> Shape.to_shape_array + |> Array.map Shape.to_array + |> continuation + | None -> + Pages_common.generic_page ~title:(s_ "Error") + (s_ "The result of this election is not available.") () + >>= Html.send ~code:404 + ) + | Question.Homomorphic _ -> + Pages_common.generic_page ~title:(s_ "Error") + (s_ "This question is homomorphic, this method cannot be applied to its result.") + () + >>= Html.send ~code:403 + ) else ( + Pages_common.generic_page ~title:(s_ "Error") + (s_ "Invalid index for question.") () + >>= Html.send ~code:404 + ) + let () = Any.register ~service:method_schulze (fun (uuid, question) () -> - let%lwt l = get_preferred_gettext () in - let open (val l) in - match%lwt find_election uuid with - | None -> election_not_found () - | Some election -> - let questions = election.e_params.e_questions in - if 0 <= question && question < Array.length questions then ( - match questions.(question) with - | Question.NonHomomorphic q -> + handle_method uuid question + (fun _ q continuation -> + continuation + (fun ballots -> let nchoices = Array.length q.Question_nh_t.q_answers in - (match%lwt Web_persist.get_election_result uuid with - | Some result -> - let ballots = - (Shape.to_shape_array result.result).(question) - |> Shape.to_shape_array - |> Array.map Shape.to_array - in - let schulze = Schulze.compute ~nchoices ballots in - Pages_voter.schulze q schulze >>= Html.send - | None -> - Pages_common.generic_page ~title:(s_ "Error") - (s_ "The result of this election is not available.") - () >>= Html.send ~code:404 - ) - | Question.Homomorphic _ -> - Pages_common.generic_page ~title:(s_ "Error") - (s_ "This question is homomorphic, the Schulze method cannot be applied to its result.") - () >>= Html.send ~code:403 - ) else ( - Pages_common.generic_page ~title:(s_ "Error") - (s_ "Invalid index for question.") - () >>= Html.send ~code:404 - ) + let schulze = Schulze.compute ~nchoices ballots in + Pages_voter.schulze q schulze >>= Html.send + ) + ) ) let () = Any.register ~service:method_mj (fun (uuid, (question, ngrades)) () -> - let%lwt l = get_preferred_gettext () in - let open (val l) in - match%lwt find_election uuid with - | None -> election_not_found () - | Some election -> - let questions = election.e_params.e_questions in - if 0 <= question && question < Array.length questions then ( - match questions.(question) with - | Question.NonHomomorphic q -> - (match ngrades with - | None -> - Pages_voter.majority_judgment_select uuid question - >>= Html.send - | Some ngrades -> - if 0 < ngrades then ( - let nchoices = Array.length q.Question_nh_t.q_answers in - match%lwt Web_persist.get_election_result uuid with - | Some result -> - let ballots = - (Shape.to_shape_array result.result).(question) - |> Shape.to_shape_array - |> Array.map Shape.to_array - in - let mj = Majority_judgment.compute ~nchoices ~ngrades ballots in - Pages_voter.majority_judgment q mj >>= Html.send - | None -> - Pages_common.generic_page ~title:(s_ "Error") - (s_ "The result of this election is not available.") () - >>= Html.send ~code:404 - ) else ( - Pages_common.generic_page ~title:(s_ "Error") - (s_ "The number of grades is invalid") () - >>= Html.send ~code:400 - ) - ) - | Question.Homomorphic _ -> - Pages_common.generic_page ~title:(s_ "Error") - (s_ "This question is homomorphic, the Majority Judgment method cannot be applied to its result.") - () - >>= Html.send ~code:403 - ) else ( - Pages_common.generic_page ~title:(s_ "Error") - (s_ "Invalid index for question.") () - >>= Html.send ~code:404 - ) + handle_method uuid question + (fun l q continuation -> + let open (val l : Web_i18n_sig.GETTEXT) in + match ngrades with + | None -> + Pages_voter.majority_judgment_select uuid question + >>= Html.send + | Some ngrades -> + if ngrades > 0 then ( + continuation + (fun ballots -> + let nchoices = Array.length q.Question_nh_t.q_answers in + let mj = Majority_judgment.compute ~nchoices ~ngrades ballots in + Pages_voter.majority_judgment q mj >>= Html.send + ) + ) else ( + Pages_common.generic_page ~title:(s_ "Error") + (s_ "The number of grades is invalid") () + >>= Html.send ~code:400 + ) + ) ) let content_type_of_file = function -- GitLab