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

4
src/pp_babillard.ml
View file

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

6
src/register.eml.html
View file

@ -2,13 +2,11 @@ let f request =
<%s! Dream.form_tag ~action:"/register" request %> <%s! Dream.form_tag ~action:"/register" request %>
<div class="mb-3"> <div class="mb-3">
<label for="nick" class="form-label">Nick</label> <label for="nick" class="form-label">Nick</label>
<input name="nick" type="text" class="form-control" id="nick" aria-describedby="nick-help"> <input name="nick" type="text" class="form-control" id="nick">
<div id="nick-help" class="form-text">Choose a nickname</div>
</div> </div>
<div class="mb-3"> <div class="mb-3">
<label for="email" class="form-label">Email address</label> <label for="email" class="form-label">Email address</label>
<input name="email" type="email" class="form-control" id="email" aria-describedby="email-help"> <input name="email" type="email" class="form-control" id="email">
<div id="email-help" class="form-text">We'll never share your email with anyone else.</div>
</div> </div>
<div class="mb-3"> <div class="mb-3">
<label for="password" class="form-label">Password</label> <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 Caqti_request.find Caqti_type.string Caqti_type.string
"SELECT user_id FROM user WHERE nick=?;" "SELECT user_id FROM user WHERE nick=?;"
let get_user_id_from_login = let get_user_id_from_email =
Caqti_request.find Caqti_request.find Caqti_type.string Caqti_type.string
Caqti_type.(tup2 string string) "SELECT user_id FROM user WHERE email=?;"
Caqti_type.string "SELECT user_id FROM user WHERE nick=? OR email=?;"
let get_password = let get_password =
Caqti_request.find Caqti_type.string Caqti_type.string Caqti_request.find Caqti_type.string Caqti_type.string
@ -167,9 +166,16 @@ let get_nick user_id =
let login ~login ~password request = let login ~login ~password request =
if is_banished login then Error "YOU ARE BANISHED" if is_banished login then Error "YOU ARE BANISHED"
else else
match Db.find Q.get_user_id_from_login (login, login) with let* user_id =
| Error _e -> Error "wrong login" match Db.find_opt Q.get_user_id_from_nick login with
| Ok user_id -> | 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 let^ good_password = Db.find Q.get_password user_id in
if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
let _unit_lwt = Dream.invalidate_session request in let _unit_lwt = Dream.invalidate_session request in
@ -187,8 +193,7 @@ let valid_nick nick =
let valid_password password = let valid_password password =
String.length password < 128 && String.length password > 0 String.length password < 128 && String.length password > 0
let valid_email email = let valid_email email = Result.is_ok @@ Emile.of_string email
match Emile.of_string email with Ok _mail -> true | Error _e -> false
let register ~email ~nick ~password = let register ~email ~nick ~password =
let valid = valid_nick nick && valid_email email && valid_password password in 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" Error "label or content is too long"
else else
let* metadata = get_metadata user_id in 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 = let metadata =
if List.length metadata > 0 && List.length metadata > count then List.init n (fun i ->
List.mapi if i = count then (label, content) else metadata.(i) )
(fun i (l, c) -> if i = count then (label, content) else (l, c))
metadata
else metadata @ [ (label, content) ]
in in
let metadata = let metadata =
List.filter (fun (l, c) -> not (l = "" && c = "")) metadata List.filter (fun (l, c) -> not (l = "" && c = "")) metadata
in in
if List.length metadata >= 42 then Error "to many metadata"
else
let s = Marshal.to_string metadata [] in let s = Marshal.to_string metadata [] in
let^ () = Db.exec Q.delete_metadata user_id in let^ () = Db.exec Q.delete_metadata user_id in
let^ () = Db.exec Q.upload_metadata (user_id, s) in let^ () = Db.exec Q.upload_metadata (user_id, s) in