Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Open sidebar
belenios
belenios
Commits
6c62906c
Commit
6c62906c
authored
Nov 14, 2019
by
Stephane Glondu
Committed by
Stéphane Glondu
Nov 14, 2019
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Change (mostly) style of exception catching
parent
58a4ded7
Changes
7
Hide whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
97 additions
and
114 deletions
+97
-114
src/tool/tool_cmdline.ml
src/tool/tool_cmdline.ml
+15
-17
src/tool/tool_js_pd.ml
src/tool/tool_js_pd.ml
+2
-2
src/tool/tool_js_questions.ml
src/tool/tool_js_questions.ml
+2
-2
src/tool/tool_verifydiff.ml
src/tool/tool_verifydiff.ml
+4
-3
src/web/web_common.ml
src/web/web_common.ml
+13
-18
src/web/web_persist.ml
src/web/web_persist.ml
+11
-14
src/web/web_site.ml
src/web/web_site.ml
+50
-58
No files found.
src/tool/tool_cmdline.ml
View file @
6c62906c
...
...
@@ -33,14 +33,16 @@ let stream_to_list s =
let
lines_of_file
fname
=
let
ic
=
open_in
fname
in
Stream
.
from
(
fun
_
->
try
Some
(
input_line
ic
)
with
End_of_file
->
close_in
ic
;
None
)
match
input_line
ic
with
|
line
->
Some
line
|
exception
End_of_file
->
close_in
ic
;
None
)
let
lines_of_stdin
()
=
Stream
.
from
(
fun
_
->
try
Some
(
input_line
stdin
)
with
End_of_file
->
None
match
input_line
stdin
with
|
line
->
Some
line
|
exception
End_of_file
->
None
)
let
string_of_file
f
=
...
...
@@ -86,12 +88,11 @@ let get_mandatory_opt name = function
|
None
->
failcmd
"%s is mandatory"
name
let
wrap_main
f
=
try
let
()
=
f
()
in
`Ok
()
with
|
Cmdline_error
e
->
`Error
(
true
,
e
)
|
Failure
e
->
`Error
(
false
,
e
)
|
e
->
`Error
(
false
,
Printexc
.
to_string
e
)
match
f
()
with
|
()
->
`Ok
()
|
exception
Cmdline_error
e
->
`Error
(
true
,
e
)
|
exception
Failure
e
->
`Error
(
false
,
e
)
|
exception
e
->
`Error
(
false
,
Printexc
.
to_string
e
)
module
type
CMDLINER_MODULE
=
sig
val
cmds
:
(
unit
Cmdliner
.
Term
.
t
*
Cmdliner
.
Term
.
info
)
list
...
...
@@ -297,8 +298,7 @@ module Election : CMDLINER_MODULE = struct
let
get_threshold
()
=
let
file
=
"threshold.json"
in
Printf
.
eprintf
"I: loading %s...
\n
%!"
file
;
try
Some
(
string_of_file
(
X
.
dir
/
file
))
with
_
->
None
try
Some
(
string_of_file
(
X
.
dir
/
file
))
with
_
->
None
let
get_public_keys
()
=
load_from_file
(
fun
x
->
x
)
(
X
.
dir
/
"public_keys.jsons"
)
|>
...
...
@@ -307,14 +307,12 @@ module Election : CMDLINER_MODULE = struct
let
get_public_creds
()
=
let
file
=
"public_creds.txt"
in
Printf
.
eprintf
"I: loading %s...
\n
%!"
file
;
try
Some
(
lines_of_file
(
X
.
dir
/
file
))
with
_
->
None
try
Some
(
lines_of_file
(
X
.
dir
/
file
))
with
_
->
None
let
get_ballots
()
=
let
file
=
"ballots.jsons"
in
Printf
.
eprintf
"I: loading %s...
\n
%!"
file
;
try
Some
(
lines_of_file
(
X
.
dir
/
file
))
with
_
->
None
try
Some
(
lines_of_file
(
X
.
dir
/
file
))
with
_
->
None
let
get_result
()
=
load_from_file
(
fun
x
->
x
)
(
X
.
dir
/
"result.json"
)
|>
function
...
...
src/tool/tool_js_pd.ml
View file @
6c62906c
...
...
@@ -84,8 +84,8 @@ let compute_partial_decryption _ =
(
partial_decryption_key_of_string
epk
)
.
pdk_decryption_key
|
None
->
basic_check_private_key
pk_str
;
try
number_of_string
pk_str
with
e
->
try
number_of_string
pk_str
with
|
e
->
Printf
.
ksprintf
failwith
"Error in format of private key: %s"
(
Printexc
.
to_string
e
)
in
...
...
src/tool/tool_js_questions.ml
View file @
6c62906c
...
...
@@ -43,8 +43,8 @@ let extractQuestion q =
p2
##
querySelector
(
Js
.
string
selector
)
>>=
fun
x
->
Dom_html
.
CoerceTo
.
input
x
>>=
fun
x
->
let
x
=
Js
.
to_string
x
##.
value
in
try
return
(
int_of_string
x
)
with
_
->
failwith
(
error_msg
^
": "
^
x
^
"."
)
try
return
(
int_of_string
x
)
with
|
_
->
failwith
(
error_msg
^
": "
^
x
^
"."
)
in
p2
##
querySelector
(
Js
.
string
".question_blank"
)
>>=
fun
q_blank
->
Dom_html
.
CoerceTo
.
input
q_blank
>>=
fun
q_blank
->
...
...
src/tool/tool_verifydiff.ml
View file @
6c62906c
...
...
@@ -31,9 +31,10 @@ let stream_to_list s =
let
lines_of_file
fname
=
let
ic
=
open_in
fname
in
Stream
.
from
(
fun
_
->
try
Some
(
input_line
ic
)
with
End_of_file
->
close_in
ic
;
None
)
match
input_line
ic
with
|
line
->
Some
line
|
exception
End_of_file
->
close_in
ic
;
None
)
let
string_of_file
f
=
lines_of_file
f
|>
stream_to_list
|>
String
.
concat
"
\n
"
...
...
src/web/web_common.ml
View file @
6c62906c
...
...
@@ -303,11 +303,10 @@ let send_email recipient subject body =
let
return_path
=
!
Web_config
.
return_path
in
let
sendmail
=
sendmail
?
return_path
in
let
rec
loop
()
=
try
%
lwt
Lwt_preemptive
.
detach
sendmail
contents
with
Unix
.
Unix_error
(
Unix
.
EAGAIN
,
_
,
_
)
->
let
%
lwt
()
=
Lwt_unix
.
sleep
1
.
in
loop
()
try
%
lwt
Lwt_preemptive
.
detach
sendmail
contents
with
|
Unix
.
Unix_error
(
Unix
.
EAGAIN
,
_
,
_
)
->
let
%
lwt
()
=
Lwt_unix
.
sleep
1
.
in
loop
()
in
loop
()
let
split_identity
x
=
...
...
@@ -330,8 +329,7 @@ let languages_of_string x =
Pcre
.
split
x
let
pcre_exec_opt
~
rex
x
=
try
Some
(
Pcre
.
exec
~
rex
x
)
with
Not_found
->
None
try
Some
(
Pcre
.
exec
~
rex
x
)
with
Not_found
->
None
let
email_rex
=
"[A-Z0-9._%+-]+@[A-Z0-9.-]+
\\
.[A-Z]{2,}"
...
...
@@ -354,11 +352,9 @@ let extract_email =
)
let
file_exists
x
=
try
%
lwt
let
%
lwt
()
=
Lwt_unix
.(
access
x
[
R_OK
])
in
return
true
with
_
->
return
false
match
%
lwt
Lwt_unix
.(
access
x
[
R_OK
])
with
|
()
->
return
true
|
exception
_
->
return
false
let
get_fname
uuid
x
=
match
uuid
with
...
...
@@ -368,10 +364,9 @@ let get_fname uuid x =
!
Web_config
.
spool_dir
/
raw_string_of_uuid
uuid
/
x
let
read_file
?
uuid
x
=
try
%
lwt
let
%
lwt
lines
=
Lwt_io
.
lines_of_file
(
get_fname
uuid
x
)
|>
Lwt_stream
.
to_list
in
return
(
Some
lines
)
with
_
->
return_none
match
%
lwt
Lwt_io
.
lines_of_file
(
get_fname
uuid
x
)
|>
Lwt_stream
.
to_list
with
|
lines
->
return_some
lines
|
exception
_
->
return_none
let
write_file
?
uuid
x
lines
=
let
fname
=
get_fname
uuid
x
in
...
...
@@ -386,8 +381,8 @@ let write_file ?uuid x lines =
Lwt_unix
.
rename
fname_new
fname
let
cleanup_file
f
=
try
%
lwt
Lwt_unix
.
unlink
f
with
_
->
return_unit
try
%
lwt
Lwt_unix
.
unlink
f
with
|
_
->
return_unit
let
rmdir
dir
=
let
command
=
"rm"
,
[
|
"rm"
;
"-rf"
;
dir
|
]
in
...
...
src/web/web_persist.ml
View file @
6c62906c
...
...
@@ -47,10 +47,9 @@ let get_election_result uuid =
let
set_election_result_hidden
uuid
hidden
=
match
hidden
with
|
None
->
(
try
%
lwt
Lwt_unix
.
unlink
(
!
Web_config
.
spool_dir
/
raw_string_of_uuid
uuid
/
"hide_result"
)
with
_
->
return_unit
)
(
try
%
lwt
Lwt_unix
.
unlink
(
!
Web_config
.
spool_dir
/
raw_string_of_uuid
uuid
/
"hide_result"
)
with
|
_
->
return_unit
)
|
Some
d
->
write_file
~
uuid
"hide_result"
[
string_of_datetime
d
]
let
get_election_result_hidden
uuid
=
...
...
@@ -129,9 +128,8 @@ let set_election_auto_dates uuid x =
let
set_election_state
uuid
s
=
match
s
with
|
`Archived
->
(
try
%
lwt
Lwt_unix
.
unlink
(
!
Web_config
.
spool_dir
/
raw_string_of_uuid
uuid
/
"state.json"
)
with
_
->
return_unit
(
try
%
lwt
Lwt_unix
.
unlink
(
!
Web_config
.
spool_dir
/
raw_string_of_uuid
uuid
/
"state.json"
)
with
|
_
->
return_unit
)
|
_
->
write_file
~
uuid
"state.json"
[
string_of_election_state
s
]
...
...
@@ -326,13 +324,12 @@ let get_ballot_hashes uuid =
StringMap
.
bindings
ballots
|>
List
.
map
fst
|>
return
|
_
->
let
uuid_s
=
raw_string_of_uuid
uuid
in
try
%
lwt
let
ballots
=
Lwt_unix
.
files_of_directory
(
!
Web_config
.
spool_dir
/
uuid_s
/
"ballots"
)
in
let
%
lwt
ballots
=
Lwt_stream
.
to_list
ballots
in
let
ballots
=
List
.
filter
(
fun
x
->
x
<>
"."
&&
x
<>
".."
)
ballots
in
return
(
List
.
rev_map
unurlize
ballots
)
with
Unix
.
Unix_error
(
Unix
.
ENOENT
,
"opendir"
,
_
)
->
return
[]
match
%
lwt
Lwt_unix
.
files_of_directory
(
!
Web_config
.
spool_dir
/
uuid_s
/
"ballots"
)
|>
Lwt_stream
.
to_list
with
|
ballots
->
let
ballots
=
List
.
filter
(
fun
x
->
x
<>
"."
&&
x
<>
".."
)
ballots
in
return
(
List
.
rev_map
unurlize
ballots
)
|
exception
Unix
.
Unix_error
(
Unix
.
ENOENT
,
"opendir"
,
_
)
->
return
[]
let
get_ballot_by_hash
uuid
hash
=
match
%
lwt
get_election_state
uuid
with
...
...
src/web/web_site.ml
View file @
6c62906c
...
...
@@ -530,16 +530,16 @@ let with_draft_election ?(save = true) uuid f =
match
%
lwt
Web_persist
.
get_draft_election
uuid
with
|
None
->
fail_http
404
|
Some
se
->
if
se
.
se_owner
=
u
then
(
try
%
lwt
let
%
lwt
r
=
f
se
in
let
%
lwt
()
=
if
save
then
Web_persist
.
set_draft_election
uuid
se
else
return_unit
in
return
r
with
e
->
let
msg
=
match
e
with
Failure
s
->
s
|
_
->
Printexc
.
to_string
e
in
let
service
=
preapply
election_draft
uuid
in
T
.
generic_page
~
title
:
"Error"
~
service
msg
()
>>=
Html
.
send
)
else
forbidden
()
if
se
.
se_owner
=
u
then
(
match
%
lwt
f
se
with
|
r
->
let
%
lwt
()
=
if
save
then
Web_persist
.
set_draft_election
uuid
se
else
return_unit
in
return
r
|
exception
e
->
let
msg
=
match
e
with
Failure
s
->
s
|
_
->
Printexc
.
to_string
e
in
let
service
=
preapply
election_draft
uuid
in
T
.
generic_page
~
title
:
"Error"
~
service
msg
()
>>=
Html
.
send
)
else
forbidden
()
)
)
...
...
@@ -887,8 +887,7 @@ let () =
)
let
wrap_handler
f
=
try
%
lwt
f
()
with
try
%
lwt
f
()
with
|
e
->
T
.
generic_page
~
title
:
"Error"
(
Printexc
.
to_string
e
)
()
>>=
Html
.
send
let
handle_credentials_post
uuid
token
creds
=
...
...
@@ -1077,11 +1076,10 @@ let () =
Any
.
register
~
service
:
election_draft_create
(
fun
uuid
()
->
with_draft_election
~
save
:
false
uuid
(
fun
se
->
try
%
lwt
let
%
lwt
()
=
validate_election
uuid
se
in
redir_preapply
election_admin
uuid
()
with
e
->
T
.
new_election_failure
(
`Exception
e
)
()
>>=
Html
.
send
match
%
lwt
validate_election
uuid
se
with
|
()
->
redir_preapply
election_admin
uuid
()
|
exception
e
->
T
.
new_election_failure
(
`Exception
e
)
()
>>=
Html
.
send
)
)
...
...
@@ -1238,24 +1236,26 @@ let () =
let
()
=
Any
.
register
~
service
:
election_home
(
fun
(
uuid
,
()
)
()
->
try
%
lwt
let
%
lwt
w
=
find_election
uuid
in
let
%
lwt
()
=
Eliom_reference
.
unset
Web_state
.
ballot
in
match
%
lwt
Eliom_reference
.
get
Web_state
.
cast_confirmed
with
|
Some
result
->
let
%
lwt
()
=
Eliom_reference
.
unset
Web_state
.
cast_confirmed
in
let
%
lwt
()
=
Eliom_reference
.
unset
Web_state
.
election_user
in
T
.
cast_confirmed
w
~
result
()
>>=
Html
.
send
|
None
->
let
%
lwt
state
=
Web_persist
.
get_election_state
uuid
in
T
.
election_home
w
state
()
>>=
Html
.
send
with
Not_found
->
let
%
lwt
lang
=
Eliom_reference
.
get
Web_state
.
language
in
let
module
L
=
(
val
Web_i18n
.
get_lang
lang
)
in
T
.
generic_page
~
title
:
L
.
not_yet_open
~
service
:
(
preapply
election_home
(
uuid
,
()
))
L
.
come_back_later
()
>>=
Html
.
send
)
match
%
lwt
find_election
uuid
with
|
w
->
let
%
lwt
()
=
Eliom_reference
.
unset
Web_state
.
ballot
in
(
match
%
lwt
Eliom_reference
.
get
Web_state
.
cast_confirmed
with
|
Some
result
->
let
%
lwt
()
=
Eliom_reference
.
unset
Web_state
.
cast_confirmed
in
let
%
lwt
()
=
Eliom_reference
.
unset
Web_state
.
election_user
in
T
.
cast_confirmed
w
~
result
()
>>=
Html
.
send
|
None
->
let
%
lwt
state
=
Web_persist
.
get_election_state
uuid
in
T
.
election_home
w
state
()
>>=
Html
.
send
)
|
exception
Not_found
->
let
%
lwt
lang
=
Eliom_reference
.
get
Web_state
.
language
in
let
module
L
=
(
val
Web_i18n
.
get_lang
lang
)
in
T
.
generic_page
~
title
:
L
.
not_yet_open
~
service
:
(
preapply
election_home
(
uuid
,
()
))
L
.
come_back_later
()
>>=
Html
.
send
)
let
get_cont_state
cont
=
let
redir
=
match
cont
with
...
...
@@ -1321,19 +1321,17 @@ let election_set_result_hidden f uuid x =
with_site_user
(
fun
u
->
let
%
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid
in
if
metadata
.
e_owner
=
Some
u
then
(
try
%
lwt
let
%
lwt
()
=
Web_persist
.
set_election_result_hidden
uuid
(
f
x
)
in
redir_preapply
election_admin
uuid
()
with
|
Failure
msg
->
match
%
lwt
Web_persist
.
set_election_result_hidden
uuid
(
f
x
)
with
|
()
->
redir_preapply
election_admin
uuid
()
|
exception
Failure
msg
->
let
service
=
preapply
election_admin
uuid
in
T
.
generic_page
~
title
:
"Error"
~
service
msg
()
>>=
Html
.
send
)
else
forbidden
()
)
let
parse_datetime_from_post
x
=
try
datetime_of_string
(
"
\"
"
^
x
^
".000000
\"
"
)
with
_
->
Printf
.
ksprintf
failwith
"%s is not a valid date!"
x
try
datetime_of_string
(
"
\"
"
^
x
^
".000000
\"
"
)
with
|
_
->
Printf
.
ksprintf
failwith
"%s is not a valid date!"
x
let
()
=
Any
.
register
~
service
:
election_hide_result
...
...
@@ -1425,10 +1423,9 @@ let () =
with_site_user
(
fun
u
->
let
%
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid
in
if
metadata
.
e_owner
=
Some
u
then
(
try
%
lwt
let
%
lwt
()
=
Web_persist
.
replace_credential
uuid
old
new_
in
String
.
send
(
"OK"
,
"text/plain"
)
with
BeleniosWebError
e
->
match
%
lwt
Web_persist
.
replace_credential
uuid
old
new_
with
|
()
->
String
.
send
(
"OK"
,
"text/plain"
)
|
exception
BeleniosWebError
e
->
let
%
lwt
lang
=
Eliom_reference
.
get
Web_state
.
language
in
let
l
=
Web_i18n
.
get_lang
lang
in
String
.
send
(
"Error: "
^
explain_error
l
e
,
"text/plain"
)
...
...
@@ -1479,15 +1476,11 @@ let () =
T
.
generic_page
~
title
:
L
.
cookies_are_blocked
L
.
please_enable_them
()
>>=
Html
.
send
|
Some
ballot
->
match
try
let
ballot
=
ballot_of_string
Yojson
.
Safe
.
read_json
ballot
in
Some
ballot
.
election_uuid
with
_
->
None
with
|
None
->
match
ballot_of_string
Yojson
.
Safe
.
read_json
ballot
with
|
exception
_
->
T
.
generic_page
~
title
:
"Error"
"Ill-formed ballot"
()
>>=
Html
.
send
|
Some
uuid
->
|
ballot
->
let
uuid
=
ballot
.
election_uuid
in
match
%
lwt
Web_persist
.
get_draft_election
uuid
with
|
Some
_
->
redir_preapply
election_draft
uuid
()
|
None
->
redir_preapply
election_login
((
uuid
,
()
)
,
None
)
()
...
...
@@ -1554,10 +1547,9 @@ let () =
|
None
->
forbidden
()
|
Some
user
->
let
%
lwt
result
=
try
%
lwt
let
%
lwt
hash
=
cast_ballot
uuid
~
rawballot
~
user
in
return
(
Ok
hash
)
with
BeleniosWebError
e
->
return
(
Error
e
)
match
%
lwt
cast_ballot
uuid
~
rawballot
~
user
with
|
hash
->
return
(
Ok
hash
)
|
exception
BeleniosWebError
e
->
return
(
Error
e
)
in
let
%
lwt
()
=
Eliom_reference
.
set
Web_state
.
cast_confirmed
(
Some
result
)
in
redir_preapply
election_home
(
uuid
,
()
)
()
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment