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
7a2769b3
Commit
7a2769b3
authored
Mar 18, 2016
by
Stephane Glondu
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Remove WEB_PARAMS and WEB_ELECTION_DATA signatures
parent
88eefa23
Changes
8
Hide whitespace changes
Inline
Side-by-side
Showing
8 changed files
with
111 additions
and
125 deletions
+111
-125
src/web/web_election.ml
src/web/web_election.ml
+7
-8
src/web/web_election.mli
src/web/web_election.mli
+1
-1
src/web/web_persist.ml
src/web/web_persist.ml
+14
-4
src/web/web_persist.mli
src/web/web_persist.mli
+1
-1
src/web/web_signatures.mli
src/web/web_signatures.mli
+2
-12
src/web/web_site.ml
src/web/web_site.ml
+57
-70
src/web/web_templates.ml
src/web/web_templates.ml
+17
-17
src/web/web_templates.mli
src/web/web_templates.mli
+12
-12
No files found.
src/web/web_election.ml
View file @
7a2769b3
...
...
@@ -51,13 +51,12 @@ Results will be published on the election page
--
\n
Belenios"
module
Make
(
D
:
WEB_
ELECTION_DATA
)
(
M
:
RANDOM
with
type
'
a
t
=
'
a
Lwt
.
t
)
:
WEB_ELECTION
=
struct
module
Make
(
D
:
ELECTION_DATA
)
(
M
:
RANDOM
with
type
'
a
t
=
'
a
Lwt
.
t
)
:
WEB_ELECTION
=
struct
let
uuid
=
Uuidm
.
to_string
D
.
election
.
e_params
.
e_uuid
module
D
=
D
include
D
module
E
=
Election
.
MakeElection
(
G
)(
M
)
module
G
=
D
.
G
module
E
=
Election
.
MakeElection
(
G
)
(
M
)
module
B
:
WEB_BALLOT_BOX
=
struct
...
...
@@ -127,7 +126,7 @@ module Make (D : WEB_ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB
match
old_cred
,
old_record
with
|
None
,
None
->
(* first vote *)
if
E
.
check_ballot
election
ballot
then
(
if
E
.
check_ballot
D
.
election
ballot
then
(
let
hash
=
sha256_b64
rawballot
in
Ocsipersist
.
add
cred_table
credential
(
Some
hash
)
>>
Ocsipersist
.
add
ballots_table
hash
rawballot
>>
...
...
@@ -140,7 +139,7 @@ module Make (D : WEB_ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB
|
Some
h
,
Some
(
_
,
old_credential
)
->
(* revote *)
if
credential
=
old_credential
then
(
if
E
.
check_ballot
election
ballot
then
(
if
E
.
check_ballot
D
.
election
ballot
then
(
Ocsipersist
.
remove
ballots_table
h
>>
let
hash
=
sha256_b64
rawballot
in
Ocsipersist
.
add
cred_table
credential
(
Some
hash
)
>>
...
...
@@ -179,7 +178,7 @@ module Make (D : WEB_ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB
Ocsipersist
.
add
cred_table
new_
None
let
do_write
f
=
Lwt_io
.(
with_file
~
mode
:
Output
(
dir
/
string_of_election_file
f
))
Lwt_io
.(
with_file
~
mode
:
Output
(
!
spool_dir
/
uuid
/
string_of_election_file
f
))
let
do_write_ballots
()
=
do_write
ESBallots
(
fun
oc
->
...
...
@@ -233,7 +232,7 @@ module Make (D : WEB_ELECTION_DATA) (M : RANDOM with type 'a t = 'a Lwt.t) : WEB
let
ballot
=
ballot_of_string
G
.
read
rawballot
in
let
ciphertext
=
E
.
extract_ciphertext
ballot
in
return
(
n
+
1
,
E
.
combine_ciphertexts
accu
ciphertext
))
ballots_table
(
0
,
E
.
neutral_ciphertext
election
)
ballots_table
(
0
,
E
.
neutral_ciphertext
D
.
election
)
in
let
tally
=
string_of_encrypted_tally
G
.
write
tally
in
Lwt_mutex
.
with_lock
mutex
(
fun
()
->
...
...
src/web/web_election.mli
View file @
7a2769b3
...
...
@@ -22,4 +22,4 @@
open
Signatures
open
Web_signatures
module
Make
(
D
:
WEB_
ELECTION_DATA
)
(
M
:
RANDOM
with
type
'
a
t
=
'
a
Lwt
.
t
)
:
WEB_ELECTION
module
Make
(
D
:
ELECTION_DATA
)
(
M
:
RANDOM
with
type
'
a
t
=
'
a
Lwt
.
t
)
:
WEB_ELECTION
src/web/web_persist.ml
View file @
7a2769b3
...
...
@@ -96,19 +96,29 @@ let get_raw_election uuid =
end
with
_
->
return_none
let
empty_metadata
=
{
e_owner
=
None
;
e_auth_config
=
None
;
e_cred_authority
=
None
;
e_trustees
=
None
;
}
let
return_empty_metadata
=
return
empty_metadata
let
get_election_metadata
uuid
=
try_lwt
Lwt_io
.
chars_of_file
(
!
spool_dir
/
uuid
/
"metadata.json"
)
|>
Lwt_stream
.
to_string
>>=
fun
x
->
return
@@
Some
(
metadata_of_string
x
)
with
_
->
return_
none
return
@@
metadata_of_string
x
with
_
->
return_
empty_metadata
let
get_elections_by_owner
user
=
Lwt_unix
.
files_of_directory
!
spool_dir
|>
Lwt_stream
.
filter_s
(
fun
x
->
if
x
=
"."
||
x
=
".."
then
return
false
else
match_lwt
get_election_metadata
x
with
|
Some
m
->
return
(
m
.
e_owner
=
Some
user
)
lwt
metadata
=
get_election_metadata
x
in
match
metadata
.
e_owner
with
|
Some
o
->
return
(
o
=
user
)
|
None
->
return
false
)
|>
Lwt_stream
.
to_list
...
...
src/web/web_persist.mli
View file @
7a2769b3
...
...
@@ -43,7 +43,7 @@ val get_auth_config : string -> (string * (string * string list)) list Lwt.t
val
set_auth_config
:
string
->
(
string
*
(
string
*
string
list
))
list
->
unit
Lwt
.
t
val
get_raw_election
:
string
->
string
option
Lwt
.
t
val
get_election_metadata
:
string
->
metadata
option
Lwt
.
t
val
get_election_metadata
:
string
->
metadata
Lwt
.
t
val
get_election_result
:
string
->
Yojson
.
Safe
.
json
result
option
Lwt
.
t
val
get_elections_by_owner
:
user
->
string
list
Lwt
.
t
...
...
src/web/web_signatures.mli
View file @
7a2769b3
...
...
@@ -68,18 +68,8 @@ module type WEB_BALLOT_BOX = sig
number of ballots and the hash of the encrypted tally. *)
end
module
type
WEB_PARAMS
=
sig
val
metadata
:
metadata
val
dir
:
string
end
module
type
WEB_ELECTION_DATA
=
sig
include
ELECTION_DATA
include
WEB_PARAMS
end
module
type
WEB_ELECTION
=
sig
module
D
:
WEB_ELECTION_DATA
module
E
:
ELECTION
with
type
elt
=
D
.
G
.
t
and
type
'
a
m
=
'
a
Lwt
.
t
module
G
:
GROUP
module
E
:
ELECTION
with
type
elt
=
G
.
t
and
type
'
a
m
=
'
a
Lwt
.
t
module
B
:
WEB_BALLOT_BOX
end
src/web/web_site.ml
View file @
7a2769b3
...
...
@@ -26,7 +26,6 @@ open Signatures
open
Common
open
Web_serializable_j
open
Web_common
open
Web_signatures
open
Web_services
let
source_file
=
ref
"belenios.tar.gz"
...
...
@@ -51,30 +50,16 @@ let election_credtokens = Ocsipersist.open_table "site_credtokens"
module
T
=
Web_templates
let
web_election_data
(
raw_election
,
web_params
)
=
let
params
=
Group
.
election_params_of_string
raw_election
in
let
module
D
=
struct
include
(
val
params
:
ELECTION_DATA
)
include
(
val
web_params
:
WEB_PARAMS
)
end
in
(
module
D
:
WEB_ELECTION_DATA
)
let
raw_find_election
uuid
=
lwt
raw_election
=
Web_persist
.
get_raw_election
uuid
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid
in
match
raw_election
,
metadata
with
|
Some
raw_election
,
Some
metadata
->
let
module
P
=
struct
let
dir
=
!
spool_dir
/
uuid
let
metadata
=
metadata
end
in
let
web_params
=
(
module
P
:
WEB_PARAMS
)
in
return
(
web_election_data
(
raw_election
,
web_params
))
|
_
,
_
->
Lwt
.
fail
Not_found
match
raw_election
with
|
Some
raw_election
->
return
(
Group
.
election_params_of_string
raw_election
)
|
_
->
Lwt
.
fail
Not_found
module
WCacheTypes
=
struct
type
key
=
string
type
value
=
(
module
WEB_
ELECTION_DATA
)
type
value
=
(
module
ELECTION_DATA
)
end
module
WCache
=
Ocsigen_cache
.
Make
(
WCacheTypes
)
...
...
@@ -159,16 +144,11 @@ let finalize_election uuid se =
create_file
"metadata.json"
string_of_metadata
[
metadata
]
>>
create_file
"election.json"
(
fun
x
->
x
)
[
raw_election
]
>>
(* construct Web_election instance *)
let
module
X
=
struct
let
metadata
=
metadata
let
dir
=
dir
end
in
let
web_params
=
(
module
X
:
WEB_PARAMS
)
in
let
election
=
web_election_data
(
raw_election
,
web_params
)
in
let
election
=
Group
.
election_params_of_string
raw_election
in
let
module
W
=
Web_election
.
Make
((
val
election
))
(
LwtRandom
)
in
(* set up authentication *)
lwt
()
=
match
W
.
D
.
metadata
.
e_auth_config
with
match
metadata
.
e_auth_config
with
|
None
->
return
()
|
Some
xs
->
let
auth_config
=
...
...
@@ -211,7 +191,7 @@ let finalize_election uuid se =
|
Some
x
->
Ocsipersist
.
add
table
login
x
|
None
->
return_unit
)
se
.
se_voters
>>
dump_passwords
W
.
D
.
dir
table
dump_passwords
(
!
spool_dir
/
uuid_s
)
table
|
_
->
return_unit
)
>>
(* finish *)
Web_persist
.
set_election_state
uuid_s
`Open
>>
...
...
@@ -565,10 +545,11 @@ let () =
(
fun
(
uuid
,
()
)
user
->
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
let
module
W
=
(
val
w
)
in
lwt
site_user
=
Web_auth_state
.
get_site_user
()
in
match
site_user
with
|
Some
u
when
W
.
metadata
.
e_owner
=
Some
u
->
|
Some
u
when
metadata
.
e_owner
=
Some
u
->
let
table
=
"password_"
^
underscorize
uuid_s
in
let
table
=
Ocsipersist
.
open_table
table
in
let
title
=
W
.
election
.
e_params
.
e_name
in
...
...
@@ -580,7 +561,7 @@ let () =
lwt
_
=
Ocsipersist
.
find
table
user
in
lwt
x
=
generate_password
title
url
user
in
Ocsipersist
.
add
table
user
x
>>
dump_passwords
W
.
dir
table
>>
dump_passwords
(
!
spool_dir
/
uuid_s
)
table
>>
T
.
generic_page
~
title
:
"Success"
(
"A new password has been mailed to "
^
user
^
"."
)
()
>>=
Html5
.
send
...
...
@@ -1055,12 +1036,13 @@ let () =
(
fun
(
uuid
,
()
)
()
->
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
lwt
site_user
=
Web_auth_state
.
get_site_user
()
in
let
module
W
=
(
val
w
)
in
match
site_user
with
|
Some
u
when
W
.
metadata
.
e_owner
=
Some
u
->
|
Some
u
when
metadata
.
e_owner
=
Some
u
->
lwt
state
=
Web_persist
.
get_election_state
uuid_s
in
T
.
election_admin
(
module
W
)
state
()
>>=
Html5
.
send
T
.
election_admin
w
metadata
state
()
>>=
Html5
.
send
|
_
->
let
cont
()
=
Redirection
.
send
(
Eliom_service
.
preapply
election_admin
(
uuid
,
()
))
...
...
@@ -1072,10 +1054,11 @@ let () =
let
election_set_state
state
(
uuid
,
()
)
()
=
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
let
module
W
=
(
val
w
)
in
lwt
()
=
match_lwt
Web_auth_state
.
get_site_user
()
with
|
Some
u
when
W
.
metadata
.
e_owner
=
Some
u
->
return
()
|
Some
u
when
metadata
.
e_owner
=
Some
u
->
return
()
|
_
->
forbidden
()
in
lwt
()
=
...
...
@@ -1093,10 +1076,11 @@ let () = Any.register ~service:election_close (election_set_state false)
let
()
=
Any
.
register
~
service
:
election_archive
(
fun
(
uuid
,
()
)
()
->
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
lwt
site_user
=
Web_auth_state
.
get_site_user
()
in
let
module
W
=
(
val
w
)
in
match
site_user
with
|
Some
u
when
W
.
metadata
.
e_owner
=
Some
u
->
|
Some
u
when
metadata
.
e_owner
=
Some
u
->
archive_election
uuid_s
>>
Redirection
.
send
(
Eliom_service
.
preapply
election_admin
(
uuid
,
()
))
|
_
->
forbidden
()
...
...
@@ -1108,11 +1092,12 @@ let () =
(
fun
(
uuid
,
()
)
()
->
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
lwt
site_user
=
Web_auth_state
.
get_site_user
()
in
let
module
W
=
(
val
w
)
in
match
site_user
with
|
Some
u
->
if
W
.
metadata
.
e_owner
=
Some
u
then
(
if
metadata
.
e_owner
=
Some
u
then
(
T
.
update_credential
(
module
W
)
()
>>=
Html5
.
send
)
else
(
forbidden
()
...
...
@@ -1125,15 +1110,15 @@ let () =
(
fun
(
uuid
,
()
)
(
old
,
new_
)
->
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
let
module
W
=
(
val
w
)
in
lwt
site_user
=
Web_auth_state
.
get_site_user
()
in
let
module
W
=
Web_election
.
Make
((
val
w
))
(
LwtRandom
)
in
let
module
B
=
W
.
B
in
let
module
W
=
W
.
D
in
let
module
WE
=
Web_election
.
Make
(
W
)
(
LwtRandom
)
in
match
site_user
with
|
Some
u
->
if
W
.
metadata
.
e_owner
=
Some
u
then
(
if
metadata
.
e_owner
=
Some
u
then
(
try_lwt
B
.
update_cred
~
old
~
new_
>>
WE
.
B
.
update_cred
~
old
~
new_
>>
String
.
send
(
"OK"
,
"text/plain"
)
with
Error
e
->
String
.
send
(
"Error: "
^
explain_error
e
,
"text/plain"
)
...
...
@@ -1211,9 +1196,8 @@ let () =
(
fun
(
uuid
,
()
)
()
->
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
let
module
W
=
Web_election
.
Make
((
val
w
))
(
LwtRandom
)
in
let
module
B
=
W
.
B
in
let
module
W
=
W
.
D
in
let
module
W
=
(
val
w
)
in
let
module
WE
=
Web_election
.
Make
(
W
)
(
LwtRandom
)
in
match_lwt
Eliom_reference
.
get
Web_services
.
ballot
with
|
Some
the_ballot
->
begin
...
...
@@ -1223,7 +1207,7 @@ let () =
let
record
=
u
,
now
()
in
lwt
result
=
try_lwt
lwt
hash
=
B
.
cast
the_ballot
record
in
lwt
hash
=
WE
.
B
.
cast
the_ballot
record
in
return
(
`Valid
hash
)
with
Error
e
->
return
(
`Error
e
)
in
...
...
@@ -1264,14 +1248,15 @@ let () =
(
fun
(
uuid
,
()
)
()
->
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
let
module
W
=
(
val
w
)
in
lwt
()
=
match_lwt
Web_auth_state
.
get_site_user
()
with
|
Some
u
when
W
.
metadata
.
e_owner
=
Some
u
->
return
()
|
Some
u
when
metadata
.
e_owner
=
Some
u
->
return
()
|
_
->
forbidden
()
in
let
voters
=
Lwt_io
.
lines_of_file
(
W
.
dir
/
string_of_election_file
ESVoters
)
(
!
spool_dir
/
uuid_s
/
string_of_election_file
ESVoters
)
in
let
module
S
=
Set
.
Make
(
PString
)
in
lwt
voters
=
Lwt_stream
.
fold
(
fun
v
accu
->
...
...
@@ -1279,7 +1264,7 @@ let () =
S
.
add
login
accu
)
voters
S
.
empty
in
let
records
=
Lwt_io
.
lines_of_file
(
W
.
dir
/
string_of_election_file
ESRecords
)
(
!
spool_dir
/
uuid_s
/
string_of_election_file
ESRecords
)
in
lwt
voters
=
Lwt_stream
.
fold
(
fun
r
accu
->
let
s
=
Pcre
.
exec
~
rex
r
in
...
...
@@ -1299,14 +1284,15 @@ let () =
(
fun
(
uuid
,
()
)
()
->
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
let
module
W
=
(
val
w
)
in
lwt
()
=
match_lwt
Web_auth_state
.
get_site_user
()
with
|
Some
u
when
W
.
metadata
.
e_owner
=
Some
u
->
return_unit
|
Some
u
when
metadata
.
e_owner
=
Some
u
->
return_unit
|
_
->
forbidden
()
in
let
records
=
Lwt_io
.
lines_of_file
(
W
.
dir
/
string_of_election_file
ESRecords
)
(
!
spool_dir
/
uuid_s
/
string_of_election_file
ESRecords
)
in
lwt
records
=
Lwt_stream
.
fold
(
fun
r
accu
->
let
s
=
Pcre
.
exec
~
rex
r
in
...
...
@@ -1358,7 +1344,7 @@ let () =
lwt
w
=
find_election
uuid_s
in
let
module
W
=
(
val
w
)
in
let
module
E
=
Election
.
MakeElection
(
W
.
G
)
(
LwtRandom
)
in
let
pks
=
W
.
dir
/
string_of_election_file
ESKeys
in
let
pks
=
!
spool_dir
/
uuid_s
/
string_of_election_file
ESKeys
in
let
pks
=
Lwt_io
.
lines_of_file
pks
in
lwt
()
=
Lwt_stream
.
njunk
(
trustee_id
-
1
)
pks
in
lwt
pk
=
Lwt_stream
.
peek
pks
in
...
...
@@ -1371,7 +1357,7 @@ let () =
let
pk
=
trustee_public_key_of_string
W
.
G
.
read
pk
in
let
pk
=
pk
.
trustee_public_key
in
let
pd
=
partial_decryption_of_string
W
.
G
.
read
partial_decryption
in
let
et
=
W
.
dir
/
string_of_election_file
ESETally
in
let
et
=
!
spool_dir
/
uuid_s
/
string_of_election_file
ESETally
in
lwt
et
=
Lwt_io
.
chars_of_file
et
|>
Lwt_stream
.
to_string
in
let
et
=
encrypted_tally_of_string
W
.
G
.
read
et
in
if
E
.
check_factor
et
pk
pd
then
(
...
...
@@ -1389,11 +1375,12 @@ let () =
let
handle_election_tally_release
(
uuid
,
()
)
()
=
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
let
module
W
=
(
val
w
)
in
let
module
E
=
Election
.
MakeElection
(
W
.
G
)
(
LwtRandom
)
in
lwt
()
=
match_lwt
Web_auth_state
.
get_site_user
()
with
|
Some
u
when
W
.
metadata
.
e_owner
=
Some
u
->
return
()
|
Some
u
when
metadata
.
e_owner
=
Some
u
->
return
()
|
_
->
forbidden
()
in
lwt
npks
,
ntallied
=
...
...
@@ -1410,7 +1397,7 @@ let handle_election_tally_release (uuid, ()) () =
with
Not_found
->
fail_http
404
in
lwt
et
=
W
.
dir
/
string_of_election_file
ESETally
|>
!
spool_dir
/
uuid_s
/
string_of_election_file
ESETally
|>
Lwt_io
.
chars_of_file
|>
Lwt_stream
.
to_string
>>=
wrap1
(
encrypted_tally_of_string
W
.
G
.
read
)
in
...
...
@@ -1418,7 +1405,7 @@ let handle_election_tally_release (uuid, ()) () =
lwt
()
=
let
open
Lwt_io
in
with_file
~
mode
:
Output
(
W
.
dir
/
string_of_election_file
ESResult
)
~
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
))
in
lwt
()
=
Web_persist
.
set_election_state
uuid_s
(
`Tallied
result
.
result
)
in
...
...
@@ -1435,8 +1422,8 @@ let content_type_of_file = function
|
ESRaw
|
ESKeys
|
ESBallots
|
ESETally
|
ESResult
->
"application/json"
|
ESCreds
|
ESRecords
|
ESVoters
->
"text/plain"
let
handle_pseudo_file
w
f
site_user
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
handle_pseudo_file
uuid_s
w
f
site_user
=
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
let
confidential
=
match
f
with
|
ESRaw
|
ESKeys
|
ESBallots
|
ESETally
|
ESResult
|
ESCreds
->
false
...
...
@@ -1444,13 +1431,14 @@ let handle_pseudo_file w f site_user =
in
lwt
()
=
if
confidential
then
(
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
match
site_user
with
|
Some
u
when
W
.
metadata
.
e_owner
=
Some
u
->
return
()
|
Some
u
when
metadata
.
e_owner
=
Some
u
->
return
()
|
_
->
forbidden
()
)
else
return
()
in
let
content_type
=
content_type_of_file
f
in
File
.
send
~
content_type
(
W
.
dir
/
string_of_election_file
f
)
File
.
send
~
content_type
(
!
spool_dir
/
uuid_s
/
string_of_election_file
f
)
let
()
=
Any
.
register
...
...
@@ -1460,7 +1448,7 @@ let () =
lwt
w
=
find_election
uuid_s
in
lwt
site_user
=
Web_auth_state
.
get_site_user
()
in
let
module
W
=
(
val
w
)
in
handle_pseudo_file
w
f
site_user
)
handle_pseudo_file
uuid_s
w
f
site_user
)
let
()
=
Any
.
register
...
...
@@ -1468,13 +1456,12 @@ let () =
(
fun
(
uuid
,
()
)
()
->
let
uuid_s
=
Uuidm
.
to_string
uuid
in
lwt
w
=
find_election
uuid_s
in
let
module
W
=
Web_election
.
Make
((
val
w
))
(
LwtRandom
)
in
let
module
E
=
W
.
E
in
let
module
B
=
W
.
B
in
let
module
W
=
W
.
D
in
lwt
metadata
=
Web_persist
.
get_election_metadata
uuid_s
in
let
module
W
=
(
val
w
)
in
let
module
WE
=
Web_election
.
Make
(
W
)
(
LwtRandom
)
in
lwt
()
=
match_lwt
Web_auth_state
.
get_site_user
()
with
|
Some
u
when
W
.
metadata
.
e_owner
=
Some
u
->
return
()
|
Some
u
when
metadata
.
e_owner
=
Some
u
->
return
()
|
_
->
forbidden
()
in
lwt
()
=
...
...
@@ -1482,24 +1469,24 @@ let () =
|
`Closed
->
return
()
|
_
->
forbidden
()
in
lwt
nb
,
hash
,
tally
=
B
.
compute_encrypted_tally
()
in
let
pks
=
W
.
dir
/
string_of_election_file
ESKeys
in
lwt
nb
,
hash
,
tally
=
WE
.
B
.
compute_encrypted_tally
()
in
let
pks
=
!
spool_dir
/
uuid_s
/
string_of_election_file
ESKeys
in
let
pks
=
Lwt_io
.
lines_of_file
pks
in
let
npks
=
ref
0
in
lwt
()
=
Lwt_stream
.
junk_while
(
fun
_
->
incr
npks
;
true
)
pks
in
Web_persist
.
set_election_state
uuid_s
(
`EncryptedTally
(
!
npks
,
nb
,
hash
))
>>
(* compute partial decryption and release tally
if the (single) key is known *)
let
skfile
=
W
.
dir
/
"private_key.json"
in
let
skfile
=
!
spool_dir
/
uuid_s
/
"private_key.json"
in
if
!
npks
=
1
&&
Sys
.
file_exists
skfile
then
(
lwt
sk
=
Lwt_io
.
lines_of_file
skfile
|>
Lwt_stream
.
to_list
in
let
sk
=
match
sk
with
|
[
sk
]
->
number_of_string
sk
|
_
->
failwith
"several private keys are available"
in
let
tally
=
encrypted_tally_of_string
W
.
G
.
read
tally
in
lwt
pd
=
E
.
compute_factor
tally
sk
in
let
pd
=
string_of_partial_decryption
W
.
G
.
write
pd
in
let
tally
=
encrypted_tally_of_string
W
E
.
G
.
read
tally
in
lwt
pd
=
WE
.
E
.
compute_factor
tally
sk
in
let
pd
=
string_of_partial_decryption
W
E
.
G
.
write
pd
in
Web_persist
.
set_partial_decryptions
uuid_s
[
1
,
pd
]
>>
handle_election_tally_release
(
uuid
,
()
)
()
)
else
Redirection
.
send
(
preapply
election_admin
(
uuid
,
()
)))
src/web/web_templates.ml
View file @
7a2769b3
...
...
@@ -144,7 +144,7 @@ let base ~title ~login_box ~content ?(footer = div []) ?uuid () =
]))
let
format_election
kind
election
=
let
module
W
=
(
val
election
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
election
:
ELECTION_DATA
)
in
let
e
=
W
.
election
.
e_params
in
let
service
=
match
kind
with
...
...
@@ -843,7 +843,7 @@ let election_setup_trustee token se () =
let
election_setup_import
uuid
se
(
elections
,
tallied
,
archived
)
()
=
let
title
=
"Election "
^
se
.
se_questions
.
t_name
^
" — Import voters from another election"
in
let
format_election
election
=
let
module
W
=
(
val
election
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
election
:
ELECTION_DATA
)
in
let
name
=
W
.
election
.
e_params
.
e_name
in
let
uuid_s
=
Uuidm
.
to_string
W
.
election
.
e_params
.
e_uuid
in
let
form
=
post_form
...
...
@@ -879,7 +879,7 @@ let election_setup_import uuid se (elections, tallied, archived) () =
base
~
title
~
login_box
~
content
()
let
election_login_box
w
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
let
module
A
=
struct
let
get_user
()
=
Web_auth_state
.
get_election_user
W
.
election
.
e_params
.
e_uuid
...
...
@@ -900,13 +900,13 @@ let election_login_box w =
fun
()
->
make_login_box
~
site
:
false
auth
links
let
file
w
x
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
Eliom_service
.
preapply
election_dir
(
W
.
election
.
e_params
.
e_uuid
,
x
)
let
audit_footer
w
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
div
~
a
:
[
a_style
"line-height:1.5em;"
]
[
div
[
div
[
...
...
@@ -936,7 +936,7 @@ let audit_footer w =
]
let
election_home
w
state
()
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
let
params
=
W
.
election
.
e_params
in
let
state_
=
match
state
with
...
...
@@ -1043,8 +1043,8 @@ let election_home w state () =
let
uuid
=
params
.
e_uuid
in
base
~
title
:
params
.
e_name
~
login_box
~
content
~
footer
~
uuid
()
let
election_admin
w
state
()
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
election_admin
w
metadata
state
()
=
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
let
title
=
W
.
election
.
e_params
.
e_name
^
" — Administration"
in
let
uuid_s
=
Uuidm
.
to_string
W
.
election
.
e_params
.
e_uuid
in
let
state_form
checked
=
...
...
@@ -1093,7 +1093,7 @@ let election_admin w state () =
|
[]
->
(
None
,
i
)
::
(
loop
(
i
+
1
)
ts
)
else
[]
in
match
W
.
metadata
.
e_trustees
with
match
metadata
.
e_trustees
with
|
None
->
loop
1
[]
|
Some
ts
->
loop
1
ts
in
...
...
@@ -1172,7 +1172,7 @@ let election_admin w state () =
in
let
uuid
=
W
.
election
.
e_params
.
e_uuid
in
let
update_credential
=
match
W
.
metadata
.
e_cred_authority
with
match
metadata
.
e_cred_authority
with
|
Some
"server"
->
pcdata
""
|
_
->
...
...
@@ -1204,7 +1204,7 @@ let election_admin w state () =
base
~
title
~
login_box
~
content
()
let
update_credential
w
()
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
let
params
=
W
.
election
.
e_params
in
let
form
=
post_form
~
service
:
election_update_credential_post
(
fun
(
old
,
new_
)
->
...
...
@@ -1263,7 +1263,7 @@ let regenpwd uuid () =
base
~
title
~
login_box
~
content
~
uuid
()
let
cast_raw
w
()
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
let
params
=
W
.
election
.
e_params
in
let
form_rawballot
=
post_form
~
service
:
election_cast_post
(
fun
(
name
,
_
)
->
...
...
@@ -1316,7 +1316,7 @@ let cast_raw w () =
base
~
title
:
params
.
e_name
~
login_box
~
content
~
uuid
~
footer
()
let
cast_confirmation
w
hash
()
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
lwt
user
=
Web_auth_state
.
get_election_user
W
.
election
.
e_params
.
e_uuid
in
let
params
=
W
.
election
.
e_params
in
let
name
=
params
.
e_name
in
...
...
@@ -1378,7 +1378,7 @@ let cast_confirmation w hash () =
base
~
title
:
name
~
login_box
~
content
~
uuid
()
let
cast_confirmed
w
~
result
()
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
let
params
=
W
.
election
.
e_params
in
let
name
=
params
.
e_name
in
let
progress
=
div
~
a
:
[
a_style
"text-align:center;margin-bottom:20px;"
]
[
...
...
@@ -1426,7 +1426,7 @@ let cast_confirmed w ~result () =
base
~
title
:
name
~
login_box
~
content
~
uuid
()
let
pretty_ballots
w
hashes
result
()
=
let
module
W
=
(
val
w
:
WEB_
ELECTION_DATA
)
in
let
module
W
=
(
val
w
:
ELECTION_DATA
)
in
let
params
=
W
.
election
.
e_params
in