swrup/geochan
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

fix

Browse source
This commit is contained in:
Swrup 2022-03-14 17:20:02 +01:00
parent 674e63aa77
commit 804631cf08
5 changed files with 70 additions and 57 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/babillard_page.eml.html
View file

@ -39,7 +39,7 @@ let f request =
<textarea name="thread-comment" type="text" class="form-control" id="thread-comment" aria-labelledby="thread-comment-label"></textarea>
<br />
<label for="tags" id="tags-label" class="form-label">Tags</label>
<%s! Pp_babillard.pp_checkboxes () %>
<%s! Format.asprintf "%a" Pp_babillard.pp_checkboxes () %>
<input name="tags" type="text" class="form-control" id="tags" aria-labelledby="tags-label"></input>
<br />
<label for="file" id="file-label" class="form-label">Picture:</label>

44
src/permap.ml
View file

@ -58,8 +58,9 @@ let register_post request =
(User.login ~login:nick ~password request)
in
render_unsafe res request )
| `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Expired _ | `Wrong_content_type ->
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
| `Expired _ | `Wrong_content_type ->
Dream.empty `Bad_Request
let login_get request = render_unsafe (Login.f request) request
@ -78,8 +79,9 @@ let login_post request =
Dream.respond ~status:`See_Other
~headers:[ ("Location", url) ]
"Logged in: Happy geo-posting!" )
| `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Expired _ | `Wrong_content_type ->
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
| `Expired _ | `Wrong_content_type ->
Dream.empty `Bad_Request
let admin_get request =
@ -125,8 +127,9 @@ let admin_post request =
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/admin") ]
"" )
| `Ok _ | `Expired _ | `Many_tokens _ | `Missing_token _
| `Invalid_token _ | `Wrong_session _ | `Wrong_content_type ->
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
let catalog request =
@ -156,7 +159,8 @@ let delete_post request =
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/") ]
"Your post was deleted!" )
| `Ok _ | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
@ -180,7 +184,8 @@ let report_post request =
| Ok () -> "The post was reported!"
in
render_unsafe res request
| `Ok _ | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
@ -245,8 +250,9 @@ let account_post request =
else "Password confimation does not match"
in
render_unsafe res request
| `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Expired _ | `Wrong_content_type ->
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
| `Expired _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
let profile_get request =
@ -289,8 +295,9 @@ let profile_post request =
~headers:[ ("Location", "/profile") ]
"Your display nick was updated!"
| Error e -> render_unsafe e request ) )
| `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Expired _ | `Wrong_content_type -> (
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
| `Expired _ | `Wrong_content_type -> (
match%lwt Dream.multipart request with
| `Ok [ ("file", file) ] -> (
match User.upload_avatar file user_id with
@ -299,8 +306,9 @@ let profile_post request =
~headers:[ ("Location", "/profile") ]
"Your avatar was updated!"
| Error e -> render_unsafe e request )
| `Ok _ | `Expired _ | `Many_tokens _ | `Missing_token _
| `Invalid_token _ | `Wrong_session _ | `Wrong_content_type ->
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request ) )
let avatar_image request =
@ -360,9 +368,7 @@ let babillard_post request =
:: ("tags", [ (_, tags) ])
:: ("thread-comment", [ (_, comment) ])
:: ([] as categories) ) -> (
let categories =
List.map (fun (_name, category) -> category) categories
in
let categories = List.map snd categories in
match (Float.of_string_opt lat, Float.of_string_opt lng) with
| None, _ -> render_unsafe "Invalide coordinate" request
| _, None -> render_unsafe "Invalide coordinate" request
@ -385,7 +391,7 @@ let babillard_post request =
~headers:[ ("Location", adress) ]
"Your thread was posted!"
| Error e -> render_unsafe e request ) )
| `Ok _ -> Dream.empty `Bad_Request
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
@ -439,7 +445,7 @@ let reply_post request =
~headers:[ ("Location", adress) ]
"Your reply was posted!"
| Error e -> render_unsafe e request )
| `Ok _ -> Dream.empty `Bad_Request
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )

4
src/pp_babillard.ml
View file

@ -284,7 +284,7 @@ let get_markers () =
in
Ok markers
let pp_checkboxes () =
let pp_checkboxes fmt () =
let pp_checkbox fmt category =
Format.fprintf fmt
{|
@ -295,7 +295,7 @@ let pp_checkboxes () =
|}
category category category category
in
Format.asprintf
Format.fprintf fmt
{|
<div class="row">
%a

6
src/register.eml.html
View file

@ -2,13 +2,11 @@ let f request =
<%s! Dream.form_tag ~action:"/register" request %>
<div class="mb-3">
<label for="nick" class="form-label">Nick</label>
<input name="nick" type="text" class="form-control" id="nick" aria-describedby="nick-help">
<div id="nick-help" class="form-text">Choose a nickname</div>
<input name="nick" type="text" class="form-control" id="nick">
</div>
<div class="mb-3">
<label for="email" class="form-label">Email address</label>
<input name="email" type="email" class="form-control" id="email" aria-describedby="email-help">
<div id="email-help" class="form-text">We'll never share your email with anyone else.</div>
<input name="email" type="email" class="form-control" id="email">
</div>
<div class="mb-3">
<label for="password" class="form-label">Password</label>

37
src/user.ml
View file

@ -43,10 +43,9 @@ module Q = struct
Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT user_id FROM user WHERE nick=?;"
let get_user_id_from_login =
Caqti_request.find
Caqti_type.(tup2 string string)
Caqti_type.string "SELECT user_id FROM user WHERE nick=? OR email=?;"
let get_user_id_from_email =
Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT user_id FROM user WHERE email=?;"
let get_password =
Caqti_request.find Caqti_type.string Caqti_type.string
@ -167,9 +166,16 @@ let get_nick user_id =
let login ~login ~password request =
if is_banished login then Error "YOU ARE BANISHED"
else
match Db.find Q.get_user_id_from_login (login, login) with
| Error _e -> Error "wrong login"
| Ok user_id ->
let* user_id =
match Db.find_opt Q.get_user_id_from_nick login with
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Ok None -> (
match Db.find_opt Q.get_user_id_from_email login with
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Ok None -> Error "wrong login"
| Ok (Some user_id) -> Ok user_id )
| Ok (Some user_id) -> Ok user_id
in
let^ good_password = Db.find Q.get_password user_id in
if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
let _unit_lwt = Dream.invalidate_session request in
@ -187,8 +193,7 @@ let valid_nick nick =
let valid_password password =
String.length password < 128 && String.length password > 0
let valid_email email =
match Emile.of_string email with Ok _mail -> true | Error _e -> false
let valid_email email = Result.is_ok @@ Emile.of_string email
let register ~email ~nick ~password =
let valid = valid_nick nick && valid_email email && valid_password password in
@ -297,16 +302,20 @@ let update_metadata count label content user_id =
Error "label or content is too long"
else
let* metadata = get_metadata user_id in
let length = List.length metadata in
if count < 0 || count > length then Error "invalid count"
else
let n = max (count + 1) @@ length in
let metadata = Array.of_list metadata in
let metadata =
if List.length metadata > 0 && List.length metadata > count then
List.mapi
(fun i (l, c) -> if i = count then (label, content) else (l, c))
metadata
else metadata @ [ (label, content) ]
List.init n (fun i ->
if i = count then (label, content) else metadata.(i) )
in
let metadata =
List.filter (fun (l, c) -> not (l = "" && c = "")) metadata
in
if List.length metadata >= 42 then Error "to many metadata"
else
let s = Marshal.to_string metadata [] in
let^ () = Db.exec Q.delete_metadata user_id in
let^ () = Db.exec Q.upload_metadata (user_id, s) in