Commit 190bd86c authored by Stephane Glondu's avatar Stephane Glondu

Create List and Option submodules in Common

parent 2a50dddd
......@@ -144,26 +144,32 @@ module String = struct
xn >= sn && String.sub x 0 sn = s
end
let rec list_join sep = function
| [] -> []
| [x] -> [x]
| x :: xs -> x :: sep :: list_join sep xs
let rec list_filter_map f = function
| [] -> []
| x :: xs ->
let ys = list_filter_map f xs in
match f x with
| None -> ys
| Some y -> y :: ys
let option_get x default_value = match x with
| None -> default_value
| Some x -> x
let option_map f = function
| Some x -> Some (f x)
| None -> None
module List = struct
include List
let rec join sep = function
| [] -> []
| [x] -> [x]
| x :: xs -> x :: sep :: join sep xs
let rec filter_map f = function
| [] -> []
| x :: xs ->
let ys = filter_map f xs in
match f x with
| None -> ys
| Some y -> y :: ys
end
module Option = struct
let get x default_value = match x with
| None -> default_value
| Some x -> x
let map f = function
| Some x -> Some (f x)
| None -> None
end
let save_to filename writer x =
let oc = open_out filename in
......
......@@ -48,11 +48,16 @@ module String : sig
val startswith : string -> string -> bool
end
val list_join : 'a -> 'a list -> 'a list
val list_filter_map : ('a -> 'b option) -> 'a list -> 'b list
module List : sig
include module type of List
val join : 'a -> 'a list -> 'a list
val filter_map : ('a -> 'b option) -> 'a list -> 'b list
end
val option_get : 'a option -> 'a -> 'a
val option_map : ('a -> 'b) -> 'a option -> 'b option
module Option : sig
val get : 'a option -> 'a -> 'a
val map : ('a -> 'b) -> 'a option -> 'b option
end
val save_to : string -> (Bi_outbuf.t -> 'a -> unit) -> 'a -> unit
......
......@@ -302,7 +302,7 @@ module Election : CMDLINER_MODULE = struct
let get_public_keys () =
load_from_file (fun x -> x) (X.dir/"public_keys.jsons") |>
option_map Array.of_list
Option.map Array.of_list
let get_public_creds () =
let file = "public_creds.txt" in
......
......@@ -77,7 +77,7 @@ module Make (P : PARSED_PARAMS) : S = struct
let public_keys_with_pok =
match threshold with
| None ->
get_public_keys () |> option_map @@
get_public_keys () |> Option.map @@
Array.map (trustee_public_key_of_string G.read)
| Some t -> Some t.t_verification_keys
......@@ -90,7 +90,7 @@ module Make (P : PARSED_PARAMS) : S = struct
| _ -> ()
let public_keys =
option_map (
Option.map (
Array.map (fun pk -> pk.trustee_public_key)
) public_keys_with_pok
......@@ -103,7 +103,7 @@ module Make (P : PARSED_PARAMS) : S = struct
module GSet = Map.Make (G)
let public_creds = lazy (
get_public_creds () |> option_map (fun creds ->
get_public_creds () |> Option.map (fun creds ->
let res = ref GSet.empty in
Stream.iter (fun x -> res := GSet.add (G.of_string x) false !res) creds;
res
......@@ -111,7 +111,7 @@ module Make (P : PARSED_PARAMS) : S = struct
)
let ballots = lazy (
get_ballots () |> option_map (fun ballots ->
get_ballots () |> Option.map (fun ballots ->
let res = ref [] in
Stream.iter (fun x ->
res := (ballot_of_string G.read x, sha256_b64 x) :: !res
......@@ -140,7 +140,7 @@ module Make (P : PARSED_PARAMS) : S = struct
else Printf.ksprintf failwith "ballot %s failed tests" hash
let ballots_check = lazy (
Lazy.force ballots |> option_map (List.iter cast)
Lazy.force ballots |> Option.map (List.iter cast)
)
let encrypted_tally =
......@@ -156,7 +156,7 @@ module Make (P : PARSED_PARAMS) : S = struct
let vote privcred ballot =
let sk =
privcred |> option_map (fun cred ->
privcred |> Option.map (fun cred ->
let module CD = Credential.MakeDerive (G) in
CD.derive election.e_params.e_uuid cred
)
......
......@@ -247,7 +247,7 @@ let validate_election uuid se =
(match metadata.e_auth_config with
| Some [{auth_system = "password"; _}] ->
let db =
list_filter_map (fun v ->
List.filter_map (fun v ->
let _, login = split_identity v.sv_id in
match v.sv_password with
| Some (salt, hashed) -> Some [login; salt; hashed]
......@@ -2117,17 +2117,17 @@ let extract_automatic_data_validated uuid_s =
match state with
| `Open | `Closed | `EncryptedTally _ ->
let%lwt t = Web_persist.get_election_date `Validation uuid in
let t = option_get t default_validation_date in
let t = Option.get t default_validation_date in
let next_t = datetime_add t (day days_to_delete) in
return @@ Some (`Delete, uuid, next_t, name, contact)
| `Tallied _ ->
let%lwt t = Web_persist.get_election_date `Tally uuid in
let t = option_get t default_tally_date in
let t = Option.get t default_tally_date in
let next_t = datetime_add t (day days_to_archive) in
return @@ Some (`Archive, uuid, next_t, name, contact)
| `Archived ->
let%lwt t = Web_persist.get_election_date `Archive uuid in
let t = option_get t default_archive_date in
let t = Option.get t default_archive_date in
let next_t = datetime_add t (day days_to_delete) in
return @@ Some (`Delete, uuid, next_t, name, contact)
......@@ -2146,7 +2146,7 @@ let get_next_actions_draft () =
let name = se.se_questions.t_name in
let contact = se.se_metadata.e_contact in
let%lwt t = Web_persist.get_election_date `Creation uuid in
let t = option_get t default_creation_date in
let t = Option.get t default_creation_date in
let next_t = datetime_add t (day days_to_delete) in
return ((`Destroy se, uuid, next_t, name, contact) :: accu)
) election_stable []
......
......@@ -78,7 +78,7 @@ let make_login_box ~site auth links =
List.map (fun name ->
a ~a:[a_id ("login_" ^ name)]
~service:(L.login (Some name)) [pcdata name] ()
) |> list_join (pcdata ", ")
) |> List.join (pcdata ", ")
in
div (
[pcdata "Log in: ["] @ auth_systems @ [pcdata "]"]
......@@ -549,7 +549,7 @@ let election_draft uuid se () =
a ~service:election_draft_confirm [pcdata "Create election"] uuid;
] in
let form_destroy =
let t = option_get se.se_creation_date default_creation_date in
let t = Option.get se.se_creation_date default_creation_date in
let t = datetime_add t (day 365) in
post_form
~service:election_draft_destroy
......@@ -1902,7 +1902,7 @@ let election_admin election metadata state get_tokens_decrypt () =
let%lwt archive_date = match state with
| `Tallied _ ->
let%lwt t = Web_persist.get_election_date `Tally uuid in
let t = datetime_add (option_get t default_tally_date) (day days_to_archive) in
let t = datetime_add (Option.get t default_tally_date) (day days_to_archive) in
return @@
div [
pcdata "This election will be automatically archived after ";
......@@ -1929,15 +1929,15 @@ let election_admin election metadata state get_tokens_decrypt () =
| `Open | `Closed | `EncryptedTally _ ->
let%lwt t = Web_persist.get_election_date `Validation uuid in
let dt = day days_to_delete in
return @@ datetime_add (option_get t default_validation_date) dt
return @@ datetime_add (Option.get t default_validation_date) dt
| `Tallied _ ->
let%lwt t = Web_persist.get_election_date `Tally uuid in
let dt = day (days_to_archive + days_to_delete) in
return @@ datetime_add (option_get t default_tally_date) dt
return @@ datetime_add (Option.get t default_tally_date) dt
| `Archived ->
let%lwt t = Web_persist.get_election_date `Archive uuid in
let dt = day days_to_delete in
return @@ datetime_add (option_get t default_archive_date) dt
return @@ datetime_add (Option.get t default_archive_date) dt
in
let div_delete =
div [
......@@ -2416,7 +2416,7 @@ let login_choose auth_systems service () =
auth_systems |>
List.map (fun name ->
a ~service:(service name) [pcdata name] ()
) |> list_join (pcdata ", ")
) |> List.join (pcdata ", ")
in
let content = [
div [p (
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment