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

use let* in user.ml

Browse source
This commit is contained in:
Swrup 2022-01-14 21:36:25 +01:00
parent 8f6c376f0d
commit 18df99534e
3 changed files with 83 additions and 100 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/babillard.ml
View file

@ -54,7 +54,7 @@ type post =
let ( let** ) o f =
match o with
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Ok None -> Error (Format.sprintf "db error: value not found")
| Ok None -> Error "db error"
| Ok (Some x) -> f x
(* ('a, string) result *)

46
src/permap.ml
View file

@ -62,9 +62,19 @@ let login_post request =
render_unsafe (Login.f ~nick ~password request) request
| _ -> assert false
let user request = render_unsafe (User.list ()) request
let user request =
render_unsafe
( match User.list () with
| Ok s -> s
| Error _ -> "" )
request
let user_profile request = render_unsafe (User.public_profile request) request
let user_profile request =
render_unsafe
( match User.public_profile request with
| Ok s -> s
| Error e -> e )
request
let logout request =
let _ = Dream.invalidate_session request in
@ -87,13 +97,13 @@ let profile_post request =
| None -> render_unsafe "Not logged in" request
| Some nick -> (
match%lwt Dream.form request with
| `Ok [ ("bio", bio) ] ->
let res =
match User.update_bio bio nick with
| Ok () -> "Bio updated!"
| Error e -> e
in
render_unsafe res request
| `Ok [ ("bio", bio) ] -> (
match User.update_bio bio nick with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
"Your bio was updated!"
| Error e -> render_unsafe e request )
| `Ok _
| `Many_tokens _
| `Missing_token _
@ -102,13 +112,13 @@ let profile_post request =
| `Expired _
| `Wrong_content_type -> (
match%lwt Dream.multipart request with
| `Ok [ ("file", file) ] ->
let res =
match User.upload_avatar file nick with
| Ok () -> "Avatar was uploaded!"
| Error e -> e
in
render_unsafe res request
| `Ok [ ("file", file) ] -> (
match User.upload_avatar file nick with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
"Your avatar was updated!"
| Error e -> render_unsafe e request )
| `Ok _ -> Dream.empty `Bad_Request
| `Expired _
| `Many_tokens _
@ -190,7 +200,7 @@ let newthread_post ~board request =
Format.asprintf "/%a/%s" Babillard.pp_board board thread_id
in
Dream.respond ~status:`See_Other ~headers:[ ("Location", adress) ]
"Your thread was posted on the babillard!"
"Your thread was posted!"
| Error e -> render_unsafe e request ) ) )
| `Ok _ -> Dream.empty `Bad_Request
| `Expired _
@ -244,7 +254,7 @@ let reply_post request =
| Ok post_id ->
let adress = Format.sprintf "/babillard/%s#%s" parent_id post_id in
Dream.respond ~status:`See_Other ~headers:[ ("Location", adress) ]
"Your thread was posted on the babillard!"
"Your reply was posted!"
| Error e -> render_unsafe e request )
| `Ok _ -> Dream.empty `Bad_Request
| `Expired _

135
src/user.ml
View file

@ -8,6 +8,19 @@ type t =
; avatar : string
}
(* ('a option, string) result *)
let ( let** ) o f =
match o with
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Ok None -> Error "db error"
| Ok (Some x) -> f x
(* ('a, string) result *)
let ( let* ) o f =
match o with
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Ok x -> f x
module Q = struct
let create_user_table =
Caqti_request.exec Caqti_type.unit
@ -71,21 +84,15 @@ let () =
Dream.warning (fun log -> log "can't create table")
let login ~nick ~password request =
let good_password = Db.find_opt Q.get_password nick in
match good_password with
| Ok foo -> (
match foo with
| Some good_password ->
if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
let _ =
let%lwt () = Dream.invalidate_session request in
Dream.put_session "nick" nick request
in
Ok ()
else
Error "wrong password"
| None -> Error (Format.sprintf "user `%s` doesn't exist" nick) )
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
let** good_password = Db.find_opt Q.get_password nick in
if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
let _ =
let%lwt () = Dream.invalidate_session request in
Dream.put_session "nick" nick request
in
Ok ()
else
Error "wrong password"
let register ~email ~nick ~password =
(* TODO: remove bad characters (e.g. delthas) *)
@ -113,51 +120,32 @@ let register ~email ~nick ~password =
if not valid then
Error "Something is wrong"
else
let unique = Db.find_opt Q.is_already_user (nick, email) in
match unique with
| Ok unique -> (
match unique with
| Some nb -> (
match nb with
| 0 -> (
let res =
Db.exec Q.inser_new_user (nick, password, email, ("", ""))
in
match res with
| Ok res -> Ok res
| Error e ->
Error (Format.sprintf "db error: %s" (Caqti_error.show e)) )
| _ -> Error "nick or email already exists" )
| None -> Error "db error" )
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
let** nb = Db.find_opt Q.is_already_user (nick, email) in
match nb with
| 0 ->
let* () = Db.exec Q.inser_new_user (nick, password, email, ("", "")) in
Ok ()
| _ -> Error "nick or email already exists"
let list () =
let users = Db.fold Q.list_nicks (fun nick acc -> nick :: acc) () [] in
match users with
| Ok users ->
Format.asprintf "<ul>%a</ul>"
(Format.pp_print_list (fun fmt -> function
| s -> Format.fprintf fmt {|<li><a href="/user/%s">%s</a></li>|} s s )
)
users
| Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)
let* users = Db.fold Q.list_nicks (fun nick acc -> nick :: acc) () [] in
Ok
(Format.asprintf "<ul>%a</ul>"
(Format.pp_print_list (fun fmt -> function
| s -> Format.fprintf fmt {|<li><a href="/user/%s">%s</a></li>|} s s )
)
users )
let public_profile request =
let nick = Dream.param "user" request in
let user = Db.find_opt Q.get_user nick in
match user with
| Ok user -> (
match user with
| Some (nick, password, email, (bio, _)) ->
let user_info =
Format.sprintf
{|nick = `%s`; password = `%s`; email = `%s`; bio = '%s';
let** nick, password, email, (bio, _) = Db.find_opt Q.get_user nick in
let user_info =
Format.sprintf
{|nick = `%s`; password = `%s`; email = `%s`; bio = '%s';
<img src="/user/%s/avatar" class="img-thumbnail" alt="Your avatar picture">|}
nick password email (Dream.html_escape bio) nick
in
user_info
| None -> "incoherent db answer" )
| Error e -> Format.sprintf "db error: %s" (Caqti_error.show e)
nick password email (Dream.html_escape bio) nick
in
Ok user_info
let profile request =
match Dream.session "nick" request with
@ -170,42 +158,27 @@ let update_bio bio nick =
if not valid then
Error "Not biologic"
else
let res = Db.exec Q.update_bio (bio, nick) in
match res with
| Ok _ -> Ok ()
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
let* () = Db.exec Q.update_bio (bio, nick) in
Ok ()
let get_bio nick =
let res = Db.find_opt Q.get_bio nick in
match res with
| Ok bio -> (
match bio with
| Some bio -> Ok bio
| None -> Error "incoherent db result" )
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
let** bio = Db.find_opt Q.get_bio nick in
Ok bio
let get_avatar nick =
let res = Db.find_opt Q.get_avatar nick in
match res with
| Ok avatar -> (
match avatar with
| Some avatar ->
if String.length avatar = 0 then
Ok None
else
Ok (Some avatar)
| None -> Error "db error:" )
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
let** avatar = Db.find_opt Q.get_avatar nick in
if String.length avatar = 0 then
Ok None
else
Ok (Some avatar)
let upload_avatar files nick =
match files with
| [] -> Error "No file provided"
| [ (_, content) ] -> (
| [ (_, content) ] ->
if not (is_valid_image content) then
Error "Invalid image"
else
let res = Db.exec Q.upload_avatar (content, nick) in
match res with
| Ok _ -> Ok ()
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) )
let* () = Db.exec Q.upload_avatar (content, nick) in
Ok ()
| _files -> Error "More than one file provided"