Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
B
belenios
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
1
Issues
1
List
Boards
Labels
Service Desk
Milestones
Merge Requests
1
Merge Requests
1
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
belenios
belenios
Commits
494a4d54
Commit
494a4d54
authored
Aug 28, 2017
by
Stephane Glondu
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Add Web_common.{read,write}_file and use them
parent
b785f4aa
Changes
5
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
116 additions
and
107 deletions
+116
-107
src/web/web_common.ml
src/web/web_common.ml
+20
-0
src/web/web_common.mli
src/web/web_common.mli
+3
-0
src/web/web_election.ml
src/web/web_election.ml
+2
-3
src/web/web_persist.ml
src/web/web_persist.ml
+31
-55
src/web/web_site.ml
src/web/web_site.ml
+60
-49
No files found.
src/web/web_common.ml
View file @
494a4d54
...
...
@@ -238,3 +238,23 @@ let email_rex = Pcre.regexp
let
is_email
x
=
try
ignore
(
Pcre
.
pcre_exec
~
rex
:
email_rex
x
);
true
with
Not_found
->
false
let
get_fname
uuid
x
=
match
uuid
with
|
None
->
x
|
Some
uuid
->
let
(
/
)
=
Filename
.
concat
in
!
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
let
write_file
?
uuid
x
lines
=
Lwt_io
.(
with_file
Output
(
get_fname
uuid
x
)
(
fun
oc
->
Lwt_list
.
iter_s
(
write_line
oc
)
lines
)
)
src/web/web_common.mli
View file @
494a4d54
...
...
@@ -101,3 +101,6 @@ val string_of_languages : string list option -> string
val
languages_of_string
:
string
->
string
list
val
is_email
:
string
->
bool
val
read_file
:
?
uuid
:
uuid
->
string
->
string
list
option
Lwt
.
t
val
write_file
:
?
uuid
:
uuid
->
string
->
string
list
->
unit
Lwt
.
t
src/web/web_election.ml
View file @
494a4d54
...
...
@@ -65,15 +65,14 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
send_email
email
subject
body
let
do_cast
rawballot
(
user
,
date
)
=
let
voters
=
Lwt_io
.
lines_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"voters.txt"
)
in
let
%
lwt
voters
=
Lwt_stream
.
to_list
voters
in
let
%
lwt
voters
=
read_file
~
uuid
"voters.txt"
in
let
%
lwt
email
,
login
=
let
rec
loop
=
function
|
x
::
xs
->
let
email
,
login
=
split_identity
x
in
if
login
=
user
.
user_name
then
return
(
email
,
login
)
else
loop
xs
|
[]
->
fail
UnauthorizedVoter
in
loop
voters
in
loop
(
match
voters
with
Some
xs
->
xs
|
None
->
[]
)
in
let
user
=
string_of_user
user
in
let
%
lwt
state
=
Web_persist
.
get_election_state
uuid
in
...
...
src/web/web_persist.ml
View file @
494a4d54
...
...
@@ -30,11 +30,9 @@ open Web_common
let
(
/
)
=
Filename
.
concat
let
get_election_result
uuid
=
try
%
lwt
Lwt_io
.
chars_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"result.json"
)
|>
Lwt_stream
.
to_string
>>=
fun
x
->
return
@@
Some
(
result_of_string
(
Yojson
.
Safe
.
from_lexbuf
~
stream
:
true
)
x
)
with
_
->
return_none
match
%
lwt
read_file
~
uuid
"result.json"
with
|
Some
[
x
]
->
return
(
Some
(
result_of_string
Yojson
.
Safe
.
read_json
x
))
|
_
->
return_none
type
election_state
=
[
`Open
...
...
@@ -56,19 +54,15 @@ let set_election_state x s =
let
past
=
datetime_of_string
"
\"
2015-10-01 00:00:00.000000
\"
"
let
set_election_date
uuid
d
=
let
dates
=
{
e_finalization
=
d
}
in
Lwt_io
.(
with_file
Output
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"dates.json"
)
(
fun
oc
->
write_line
oc
(
string_of_election_dates
dates
)
))
let
dates
=
string_of_election_dates
{
e_finalization
=
d
}
in
write_file
~
uuid
"dates.json"
[
dates
]
let
get_election_date
uuid
=
try
%
lwt
Lwt_io
.
chars_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"dates.json"
)
|>
Lwt_stream
.
to_string
>>=
fun
x
->
let
dates
=
election_dates_of_string
x
in
return
dates
.
e_finalization
with
_
->
return
past
match
%
lwt
read_file
~
uuid
"dates.json"
with
|
Some
[
x
]
->
let
dates
=
election_dates_of_string
x
in
return
dates
.
e_finalization
|
_
->
return
past
let
election_pds
=
Ocsipersist
.
open_table
"election_pds"
...
...
@@ -93,13 +87,9 @@ let set_auth_config x c =
Ocsipersist
.
add
auth_configs
(
key_of_uuid_option
x
)
c
let
get_raw_election
uuid
=
try
%
lwt
let
lines
=
Lwt_io
.
lines_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"election.json"
)
in
begin
match
%
lwt
Lwt_stream
.
to_list
lines
with
|
x
::
_
->
return
@@
Some
x
|
[]
->
return_none
end
with
_
->
return_none
match
%
lwt
read_file
~
uuid
"election.json"
with
|
Some
[
x
]
->
return
(
Some
x
)
|
_
->
return_none
let
empty_metadata
=
{
e_owner
=
None
;
...
...
@@ -112,11 +102,9 @@ let empty_metadata = {
let
return_empty_metadata
=
return
empty_metadata
let
get_election_metadata
uuid
=
try
%
lwt
Lwt_io
.
chars_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"metadata.json"
)
|>
Lwt_stream
.
to_string
>>=
fun
x
->
return
@@
metadata_of_string
x
with
_
->
return_empty_metadata
match
%
lwt
read_file
~
uuid
"metadata.json"
with
|
Some
[
x
]
->
return
(
metadata_of_string
x
)
|
_
->
return_empty_metadata
let
get_elections_by_owner
user
=
Lwt_unix
.
files_of_directory
!
spool_dir
|>
...
...
@@ -137,11 +125,7 @@ let get_elections_by_owner user =
Lwt_stream
.
to_list
let
get_voters
uuid
=
try
%
lwt
let
lines
=
Lwt_io
.
lines_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"voters.txt"
)
in
let
%
lwt
lines
=
Lwt_stream
.
to_list
lines
in
return
@@
Some
lines
with
_
->
return_none
read_file
~
uuid
"voters.txt"
let
get_passwords
uuid
=
let
csv
=
...
...
@@ -160,25 +144,15 @@ let get_passwords uuid =
return
@@
Some
res
let
get_public_keys
uuid
=
try
%
lwt
let
lines
=
Lwt_io
.
lines_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"public_keys.jsons"
)
in
let
%
lwt
lines
=
Lwt_stream
.
to_list
lines
in
return
@@
Some
lines
with
_
->
return_none
read_file
~
uuid
"public_keys.jsons"
let
get_private_keys
uuid
=
try
%
lwt
let
lines
=
Lwt_io
.
lines_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"private_keys.jsons"
)
in
let
%
lwt
lines
=
Lwt_stream
.
to_list
lines
in
return
@@
Some
lines
with
_
->
return_none
read_file
~
uuid
"private_keys.jsons"
let
get_threshold
uuid
=
try
%
lwt
Lwt_io
.
chars_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"threshold.json"
)
|>
Lwt_stream
.
to_string
>>=
fun
x
->
return
(
Some
x
)
with
_
->
return_none
match
%
lwt
read_file
~
uuid
"threshold.json"
with
|
Some
[
x
]
->
return
(
Some
x
)
|
_
->
return_none
module
Ballots
=
Map
.
Make
(
String
)
...
...
@@ -190,13 +164,15 @@ end
module
BallotsCache
=
Ocsigen_cache
.
Make
(
BallotsCacheTypes
)
let
raw_get_ballots_archived
uuid
=
try
%
lwt
let
ballots
=
Lwt_io
.
lines_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
"ballots.jsons"
)
in
Lwt_stream
.
fold
(
fun
b
accu
->
let
hash
=
sha256_b64
b
in
Ballots
.
add
hash
b
accu
)
ballots
Ballots
.
empty
with
_
->
return
Ballots
.
empty
match
%
lwt
read_file
~
uuid
"ballots.jsons"
with
|
Some
bs
->
return
(
List
.
fold_left
(
fun
accu
b
->
let
hash
=
sha256_b64
b
in
Ballots
.
add
hash
b
accu
)
Ballots
.
empty
bs
)
|
None
->
return
Ballots
.
empty
let
archived_ballots_cache
=
new
BallotsCache
.
cache
raw_get_ballots_archived
10
...
...
src/web/web_site.ml
View file @
494a4d54
...
...
@@ -205,10 +205,12 @@ let finalize_election uuid se =
(* inject credentials *)
let
%
lwt
()
=
let
fname
=
!
spool_dir
/
uuid_s
^
".public_creds.txt"
in
Lwt_io
.
lines_of_file
fname
|>
Lwt_stream
.
iter_s
B
.
inject_cred
>>
B
.
update_files
()
>>
Lwt_unix
.
unlink
fname
match
%
lwt
read_file
fname
with
|
Some
xs
->
Lwt_list
.
iter_s
B
.
inject_cred
xs
>>
B
.
update_files
()
>>
Lwt_unix
.
unlink
fname
|
None
->
return_unit
in
(* create file with private keys, if any *)
let
%
lwt
()
=
...
...
@@ -635,8 +637,6 @@ let is_identity x =
try
ignore
(
Pcre
.
pcre_exec
~
rex
:
identity_rex
x
);
true
with
Not_found
->
false
module
SSet
=
Set
.
Make
(
PString
)
let
merge_voters
a
b
f
=
let
existing
=
List
.
fold_left
(
fun
accu
sv
->
SSet
.
add
sv
.
sv_id
accu
...
...
@@ -768,15 +768,19 @@ let handle_credentials_post token creds =
)
>>
let
%
lwt
()
=
let
i
=
ref
1
in
Lwt_stream
.
iter
(
fun
x
->
try
let
x
=
G
.
of_string
x
in
if
not
(
G
.
check
x
)
then
raise
Exit
;
incr
i
with
_
->
Printf
.
ksprintf
failwith
"invalid credential at line %d"
!
i
)
(
Lwt_io
.
lines_of_file
fname
)
match
%
lwt
read_file
fname
with
|
Some
xs
->
return
(
List
.
iter
(
fun
x
->
try
let
x
=
G
.
of_string
x
in
if
not
(
G
.
check
x
)
then
raise
Exit
;
incr
i
with
_
->
Printf
.
ksprintf
failwith
"invalid credential at line %d"
!
i
)
xs
)
|
None
->
return_unit
in
let
()
=
se
.
se_metadata
<-
{
se
.
se_metadata
with
e_cred_authority
=
None
}
in
let
()
=
se
.
se_public_creds_received
<-
true
in
...
...
@@ -818,7 +822,6 @@ let () =
~
absolute
:
true
~
service
:
election_home
(
uuid
,
()
)
|>
rewrite_prefix
in
let
module
S
=
Set
.
Make
(
PString
)
in
let
module
G
=
(
val
Group
.
of_string
se
.
se_group
:
GROUP
)
in
let
module
CD
=
Credential
.
MakeDerive
(
G
)
in
let
%
lwt
creds
=
...
...
@@ -843,10 +846,10 @@ let () =
Printf
.
sprintf
L
.
mail_credential_subject
title
in
let
%
lwt
()
=
send_email
email
subject
body
in
return
@@
S
.
add
pub_cred
accu
)
S
.
empty
se
.
se_voters
return
@@
S
Set
.
add
pub_cred
accu
)
S
Set
.
empty
se
.
se_voters
in
let
creds
=
S
.
elements
creds
in
let
creds
=
S
Set
.
elements
creds
in
let
fname
=
!
spool_dir
/
raw_string_of_uuid
uuid
^
".public_creds.txt"
in
let
%
lwt
()
=
Lwt_io
.
with_file
...
...
@@ -1262,27 +1265,33 @@ let () =
Any
.
register
~
service
:
election_missing_voters
(
fun
(
uuid
,
()
)
()
->
with_site_user
(
fun
u
->
let
uuid_s
=
raw_string_of_uuid
uuid
in
let
%
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid
in
if
metadata
.
e_owner
=
Some
u
then
(
let
voters
=
Lwt_io
.
lines_of_file
(
!
spool_dir
/
uuid_s
/
string_of_election_file
ESVoters
)
let
%
lwt
voters
=
match
%
lwt
read_file
~
uuid
(
string_of_election_file
ESVoters
)
with
|
Some
vs
->
return
(
List
.
fold_left
(
fun
accu
v
->
let
_
,
login
=
split_identity
v
in
SSet
.
add
login
accu
)
SSet
.
empty
vs
)
|
None
->
return
SSet
.
empty
in
let
module
S
=
Set
.
Make
(
PString
)
in
let
%
lwt
voters
=
Lwt_stream
.
fold
(
fun
v
accu
->
let
_
,
login
=
split_identity
v
in
S
.
add
login
accu
)
voters
S
.
empty
in
let
records
=
Lwt_io
.
lines_of_file
(
!
spool_dir
/
uuid_s
/
string_of_election_file
ESRecords
)
let
%
lwt
voters
=
match
%
lwt
read_file
~
uuid
(
string_of_election_file
ESRecords
)
with
|
Some
rs
->
return
(
List
.
fold_left
(
fun
accu
r
->
let
s
=
Pcre
.
exec
~
rex
r
in
let
v
=
Pcre
.
get_substring
s
1
in
SSet
.
remove
v
accu
)
voters
rs
)
|
None
->
return
voters
in
let
%
lwt
voters
=
Lwt_stream
.
fold
(
fun
r
accu
->
let
s
=
Pcre
.
exec
~
rex
r
in
let
v
=
Pcre
.
get_substring
s
1
in
S
.
remove
v
accu
)
records
voters
in
let
buf
=
Buffer
.
create
128
in
S
.
iter
(
fun
v
->
S
Set
.
iter
(
fun
v
->
Buffer
.
add_string
buf
v
;
Buffer
.
add_char
buf
'\n'
)
voters
;
...
...
@@ -1299,15 +1308,19 @@ let () =
let
%
lwt
w
=
find_election
uuid
in
let
%
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid
in
if
metadata
.
e_owner
=
Some
u
then
(
let
records
=
Lwt_io
.
lines_of_file
(
!
spool_dir
/
raw_string_of_uuid
uuid
/
string_of_election_file
ESRecords
)
let
%
lwt
records
=
match
%
lwt
read_file
~
uuid
(
string_of_election_file
ESRecords
)
with
|
Some
rs
->
return
(
List
.
rev_map
(
fun
r
->
let
s
=
Pcre
.
exec
~
rex
r
in
let
date
=
Pcre
.
get_substring
s
1
in
let
voter
=
Pcre
.
get_substring
s
2
in
(
date
,
voter
)
)
rs
)
|
None
->
return
[]
in
let
%
lwt
records
=
Lwt_stream
.
fold
(
fun
r
accu
->
let
s
=
Pcre
.
exec
~
rex
r
in
let
date
=
Pcre
.
get_substring
s
1
in
let
voter
=
Pcre
.
get_substring
s
2
in
(
date
,
voter
)
::
accu
)
records
[]
in
T
.
pretty_records
w
(
List
.
rev
records
)
()
>>=
Html5
.
send
)
else
forbidden
()
)
...
...
@@ -1451,10 +1464,8 @@ let handle_election_tally_release (uuid, ()) () =
in
let
result
=
E
.
compute_result
ntallied
et
pds
combinator
in
let
%
lwt
()
=
let
open
Lwt_io
in
with_file
~
mode
:
Output
(
!
spool_dir
/
uuid_s
/
string_of_election_file
ESResult
)
(
fun
oc
->
Lwt_io
.
write_line
oc
(
string_of_result
W
.
G
.
write
result
))
let
result
=
string_of_result
W
.
G
.
write
result
in
write_file
~
uuid
(
string_of_election_file
ESResult
)
[
result
]
in
let
%
lwt
()
=
Web_persist
.
set_election_state
uuid
(
`Tallied
result
.
result
)
in
let
%
lwt
()
=
Ocsipersist
.
remove
election_tokens_decrypt
uuid_s
in
...
...
@@ -1525,9 +1536,9 @@ let () =
if the (single) key is known *)
let
skfile
=
!
spool_dir
/
raw_string_of_uuid
uuid
/
"private_key.json"
in
if
npks
=
1
&&
Sys
.
file_exists
skfile
then
(
let
%
lwt
sk
=
Lwt_io
.
lines_of_file
skfile
|>
Lwt_stream
.
to_list
in
let
%
lwt
sk
=
read_file
skfile
in
let
sk
=
match
sk
with
|
[
sk
]
->
number_of_string
sk
|
Some
[
sk
]
->
number_of_string
sk
|
_
->
failwith
"several private keys are available"
in
let
tally
=
encrypted_tally_of_string
W
.
G
.
read
tally
in
...
...
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