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

refactor some code

Browse source
This commit is contained in:
zapashcanon 2022-04-05 23:08:57 +02:00
parent 0632a713c7
commit 3796a96997
No known key found for this signature in database
GPG key ID: 8981C3C62D1D28F1
7 changed files with 330 additions and 403 deletions
Download patch file Download diff file Expand all files Collapse all files

25
src/babillard.ml
View file

@ -267,11 +267,13 @@ let upload_post ~image post =
(fun cited_id -> Db.exec Q.upload_post_reply (cited_id, id)) (fun cited_id -> Db.exec Q.upload_post_reply (cited_id, id))
citations citations
in in
match thread_data with let^ () =
| None -> Ok id match thread_data with
| Some { subject; lng; lat } -> | None -> Ok ()
let^ () = Db.exec Q.upload_thread_info (id, subject, lat, lng) in | Some { subject; lng; lat } ->
Ok id Db.exec Q.upload_thread_info (id, subject, lat, lng)
in
Ok id
let build_reply ~comment ~image_info ~tag_list ?parent_id user_id = let build_reply ~comment ~image_info ~tag_list ?parent_id user_id =
let comment = Dream.html_escape comment in let comment = Dream.html_escape comment in
@ -323,14 +325,8 @@ let build_op ~comment ~image_info ~tag_list ~categories ~subject ~lat ~lng
if not is_valid_latlng then Error "Invalid coordinate" if not is_valid_latlng then Error "Invalid coordinate"
else if String.length subject > 600 then Error "Invalid subject" else if String.length subject > 600 then Error "Invalid subject"
else else
let thread_data = { subject; lng; lat } in
let* reply = build_reply ~comment ~image_info ~tag_list user_id in let* reply = build_reply ~comment ~image_info ~tag_list user_id in
let op = (thread_data, reply) in Ok ({ subject; lng; lat }, reply)
Ok op
let build_image image_input =
let* image = Image.make_image image_input in
Ok image
let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id = let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id =
let tag_list = String.split_on_char ',' tags in let tag_list = String.split_on_char ',' tags in
@ -338,7 +334,7 @@ let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id =
match image_input with match image_input with
| None -> Ok (None, None) | None -> Ok (None, None)
| Some image_input -> | Some image_input ->
let* image = build_image image_input in let* image = Image.make_image image_input in
Ok (Some image, Some (image.name, image.alt)) Ok (Some image, Some (image.name, image.alt))
in in
let* post = let* post =
@ -391,8 +387,7 @@ let get_post id =
let get_thread_data id = let get_thread_data id =
if thread_exist id then if thread_exist id then
let^? subject, lat, lng = Db.find_opt Q.get_thread_info id in let^? subject, lat, lng = Db.find_opt Q.get_thread_info id in
let thread_data = { subject; lat; lng } in Ok { subject; lat; lng }
Ok thread_data
else Error "not an op" else Error "not an op"
let get_op id = let get_op id =

153
src/discuss.ml
View file

@ -1,4 +1,5 @@
open Db open Db
open Syntax
(** Creating the table of all messages. (** Creating the table of all messages.
@ -57,87 +58,62 @@ let find_messages k1 k2 =
Ok comrades Ok comrades
(** display the list of discussions *) (** display the list of discussions *)
let render request = let render =
match Dream.session "user_id" request with let pp_one_discuss fmt (id, nick) =
| None -> Format.fprintf fmt {|<li><a href="/discuss/%s">%s</a></li>|} id nick
let redirect_url = in
Format.sprintf "/login=?redirect=%s" (Dream.to_percent_encoded "/discuss") fun request ->
in Utils.logged_in_or_redirect request (fun user_id ->
Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] "" Utils.render_result request
| Some user_id -> ( @@ let* comrades = find_comrades user_id in
match find_comrades user_id with let* comrades =
| Error e -> Template_utils.render_unsafe e request Syntax.unwrap_list
| Ok comrades -> ( (fun id ->
let comrades = match User.get_nick id with
Syntax.unwrap_list | Error _e as e -> e
(fun id -> | Ok nick -> Ok (id, nick) )
match User.get_nick id with comrades
| Error _e as e -> e in
| Ok nick -> Ok (id, nick) ) Ok
comrades (Format.asprintf "<ul>%a</ul>"
in (Format.pp_print_list
match comrades with ~pp_sep:(fun fmt () -> Format.fprintf fmt "<br />")
| Error e -> Template_utils.render_unsafe e request pp_one_discuss )
| Ok comrades -> comrades ) )
let pp_one_discuss fmt (id, nick) =
Format.fprintf fmt {|<li><a href="/discuss/%s">%s</a></li>|} id nick
in
let output =
Format.asprintf "<ul>%a</ul>"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "<br />")
pp_one_discuss )
comrades
in
Template_utils.render_unsafe output request ) )
let pp_discussion (request, user_id, comrade_id) = let pp_discussion (request, user_id, comrade_id) =
let path = Format.sprintf "/discuss/%s" comrade_id in let path = Format.sprintf "/discuss/%s" comrade_id in
match find_messages user_id comrade_id with Utils.render_result request
| Error e -> Template_utils.render_unsafe e request @@ let* msg = find_messages user_id comrade_id in
| Ok msg -> ( let* user_nick = User.get_nick user_id in
match User.get_nick user_id with let* comrade_nick = User.get_nick comrade_id in
| Error e -> Template_utils.render_unsafe e request let pp_one_msg fmt (from_id, msg) =
| Ok user_nick -> ( Format.fprintf fmt "<li>%s | %s</li>"
match User.get_nick comrade_id with (if from_id = user_id then user_nick else comrade_nick)
| Error e -> Template_utils.render_unsafe e request msg
| Ok comrade_nick -> in
let pp_one_msg fmt (from_id, msg) = let pp_all_msg fmt msg =
Format.fprintf fmt "<li>%s | %s</li>" Format.fprintf fmt "<ul>%a</ul>"
(if from_id = user_id then user_nick else comrade_nick) (Format.pp_print_list
msg ~pp_sep:(fun fmt () -> Format.fprintf fmt "<br />")
in pp_one_msg )
let pp_all_msg fmt msg = msg
Format.fprintf fmt "<ul>%a</ul>" in
(Format.pp_print_list Ok
~pp_sep:(fun fmt () -> Format.fprintf fmt "<br />") (Format.asprintf
pp_one_msg ) {|%a<br />
msg
in
Template_utils.render_unsafe
(Format.asprintf
{|%a<br />
%s %s
<input value="" name="msg" type="text" /> <input value="" name="msg" type="text" />
<button type="submit" class="btn btn-primary">Send</button> <button type="submit" class="btn btn-primary">Send</button>
</form>|} </form>|}
pp_all_msg msg pp_all_msg msg
(Dream.form_tag ~action:path request) ) (Dream.form_tag ~action:path request) )
request ) )
(** display one discussion *) (** display one discussion *)
let render_one request = let renderone request =
let comrade_id = Dream.param request "comrade_id" in Utils.logged_in_or_redirect request (fun user_id ->
let comrade_id = Dream.param request "comrade_id" in
let path = Format.sprintf "/discuss/%s" comrade_id in pp_discussion (request, user_id, comrade_id) )
match Dream.session "user_id" request with
| None ->
let redirect_url =
Format.sprintf "/login=?redirect=%s" (Dream.to_percent_encoded path)
in
Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] ""
| Some user_id -> pp_discussion (request, user_id, comrade_id)
let insert_msg from_id to_id msg = let insert_msg from_id to_id msg =
let open Syntax in let open Syntax in
@ -146,24 +122,15 @@ let insert_msg from_id to_id msg =
(** handle posts *) (** handle posts *)
let post request = let post request =
let comrade_id = Dream.param request "comrade_id" in Utils.logged_in_or_redirect request (fun user_id ->
match%lwt Dream.form request with
let path = Format.sprintf "/discuss/%s" comrade_id in | `Ok [ ("msg", msg) ] -> begin
let comrade_id = Dream.param request "comrade_id" in
match Dream.session "user_id" request with match insert_msg user_id comrade_id msg with
| None -> | Ok () -> pp_discussion (request, user_id, comrade_id)
let redirect_url = | Error e -> Utils.render e request
Format.sprintf "/login=?redirect=%s" (Dream.to_percent_encoded path) end
in | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] "" | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| Some user_id -> ( | `Wrong_session _ | `Wrong_content_type ->
match%lwt Dream.form request with Dream.empty `Bad_Request )
| `Ok [ ("msg", msg) ] -> begin
match insert_msg user_id comrade_id msg with
| Ok () -> pp_discussion (request, user_id, comrade_id)
| Error e -> Template_utils.render_unsafe e request
end
| `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/dune
View file

@ -17,11 +17,11 @@
report_page report_page
syntax syntax
template template
template_utils
thread_page thread_page
user user
user_account user_account
user_profile) user_profile
utils)
(libraries (libraries
bos bos
caqti caqti

493
src/permap.ml
View file

@ -1,12 +1,5 @@
open Template_utils open Utils
open Syntax
let not_logged_in redirect request =
let content =
Format.sprintf
{|Not logged in, please <a href="/login?redirect=%s">login<a> to access this page|}
(Dream.to_percent_encoded redirect)
in
render_unsafe content request
let asset_loader _root path _request = let asset_loader _root path _request =
match Content.read ("assets/" ^ path) with match Content.read ("assets/" ^ path) with
@ -19,36 +12,36 @@ let page name request =
| None -> Dream.empty `Not_Found | None -> Dream.empty `Not_Found
| Some page -> | Some page ->
let content = Omd.of_string page |> Omd.to_html in let content = Omd.of_string page |> Omd.to_html in
render_unsafe content request render content request
let about request = page "about" request let about request = page "about" request
let register_get request = render_unsafe (Register.f request) request let register_get request = render (Register.f request) request
let register_post request = let register_post request =
match%lwt Dream.form request with match%lwt Dream.form request with
| `Ok [ ("email", email); ("nick", nick); ("password", password) ] -> ( | `Ok [ ("email", email); ("nick", nick); ("password", password) ] -> (
match User.register ~email ~nick ~password with match User.register ~email ~nick ~password with
| Error e -> render_unsafe e request | Error e -> render e request
| Ok () -> | Ok () ->
let res = let res =
Result.fold ~error:Fun.id Result.fold ~error:Fun.id
~ok:(fun _ -> "User created ! Welcome !") ~ok:(fun _ -> "User created ! Welcome !")
(User.login ~login:nick ~password request) (User.login ~login:nick ~password request)
in in
render_unsafe res request ) render res request )
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form" | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
| `Expired _ | `Wrong_content_type -> | `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 (Login.f request) request
let login_post request = let login_post request =
match%lwt Dream.form request with match%lwt Dream.form request with
| `Ok [ ("login", login); ("password", password) ] -> ( | `Ok [ ("login", login); ("password", password) ] -> (
match User.login ~login ~password request with match User.login ~login ~password request with
| Error e -> render_unsafe e request | Error e -> render e request
| Ok () -> | Ok () ->
let url = let url =
match Dream.query request "redirect" with match Dream.query request "redirect" with
@ -79,228 +72,200 @@ let admin_get request =
| Ok (posts, reports) -> | Ok (posts, reports) ->
Pp_babillard.admin_page_content posts reports request Pp_babillard.admin_page_content posts reports request
in in
render_unsafe res request render res request
let admin_post request = let admin_post request =
match Dream.session "user_id" request with Utils.logged_in_or_redirect request (fun user_id ->
| None -> not_logged_in "/admin" request if not (User.is_admin user_id) then Dream.respond ~status:`Forbidden ""
| Some user_id -> ( else
if not (User.is_admin user_id) then Dream.respond ~status:`Forbidden "" match%lwt Dream.form request with
else | `Ok [ ("action", action); ("post_id", id) ] -> (
match%lwt Dream.form request with (* TODO: use let* and Utils.render_result ? *)
| `Ok [ ("action", action); ("post_id", id) ] -> ( let res =
let res = match Babillard.get_post id with
match Babillard.get_post id with | Error _e as e -> e
| Error _e as e -> e | Ok post -> (
| Ok post -> ( let evil_user_id = post.user_id in
let evil_user_id = post.user_id in match Babillard.moderation_action_from_string action with
match Babillard.moderation_action_from_string action with | None -> Error "Invalid action"
| None -> Error "Invalid action" | Some action -> (
| Some action -> ( match action with
match action with | Delete -> Babillard.try_delete_post ~user_id:evil_user_id id
| Delete -> Babillard.try_delete_post ~user_id:evil_user_id id | Banish -> User.banish evil_user_id
| Banish -> User.banish evil_user_id | Ignore -> Babillard.ignore_report id ) )
| Ignore -> Babillard.ignore_report id ) ) in
in match res with
match res with | Error e -> render e request
| Error e -> render_unsafe e request | Ok () ->
| Ok () -> (* TODO: ??? *)
Dream.respond ~status:`See_Other Dream.respond ~status:`See_Other
~headers:[ ("Location", "/admin") ] ~headers:[ ("Location", "/admin") ]
"" ) "" )
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form" | `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 )
let catalog request = let catalog request =
let catalog_content = let catalog_content =
Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.catalog_content ()) Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.catalog_content ())
in in
render_unsafe (Catalog_page.f catalog_content) request render (Catalog_page.f catalog_content) request
let delete_get request = let delete_get request =
let post_id = Dream.param request "post_id" in let post_id = Dream.param request "post_id" in
let post_preview = let post_preview =
Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.view_post post_id) Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.view_post post_id)
in in
render_unsafe (Delete_page.f post_preview post_id request) request render (Delete_page.f post_preview post_id request) request
let delete_post request = let delete_post request =
let post_id = Dream.param request "post_id" in Utils.logged_in_or_redirect request (fun user_id ->
match Dream.session "user_id" request with (* match on Dream.form needed for hidden csrf field *)
| None -> not_logged_in (Format.sprintf "/delete/%s" post_id) request match%lwt Dream.form request with
| Some user_id -> ( | `Ok [] -> (
(* match on Dream.form needed for hidden csrf field *) (* TODO: use let* and Utils.render_result ? *)
match%lwt Dream.form request with let post_id = Dream.param request "post_id" in
| `Ok [] -> ( match Babillard.try_delete_post ~user_id post_id with
match Babillard.try_delete_post ~user_id post_id with | Error e -> render e request
| Error e -> render_unsafe e request | Ok () ->
| Ok () -> Dream.respond ~status:`See_Other
Dream.respond ~status:`See_Other ~headers:[ ("Location", "/") ]
~headers:[ ("Location", "/") ] "Your post was deleted!" )
"Your post was deleted!" ) | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `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 )
let report_get request = let report_get request =
let post_id = Dream.param request "post_id" in let post_id = Dream.param request "post_id" in
let post_preview = let post_preview =
Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.view_post post_id) Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.view_post post_id)
in in
render_unsafe (Report_page.f post_preview post_id request) request render (Report_page.f post_preview post_id request) request
let report_post request = let report_post request =
let post_id = Dream.param request "post_id" in Utils.logged_in_or_redirect request (fun user_id ->
match Dream.session "user_id" request with match%lwt Dream.form request with
| None -> not_logged_in (Format.sprintf "/report/%s" post_id) request | `Ok [ ("reason", reason) ] ->
| Some user_id -> ( Utils.render_result request
match%lwt Dream.form request with @@
| `Ok [ ("reason", reason) ] -> let post_id = Dream.param request "post_id" in
let res = let* () = Babillard.report ~user_id ~reason post_id in
match Babillard.report ~user_id ~reason post_id with Ok "The post was reported!"
| Error e -> e | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| Ok () -> "The post was reported!" | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
in | `Wrong_session _ | `Wrong_content_type ->
render_unsafe res request 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 )
let user request = let user request =
render_unsafe (Result.fold ~ok:Fun.id ~error:Fun.id (User.list ())) request render (Result.fold ~ok:Fun.id ~error:Fun.id (User.list ())) request
let user_profile request = let user_profile request =
let nick = Dream.param request "user" in let nick = Dream.param request "user" in
match User.get_user_id_from_nick nick with match User.get_user_id_from_nick nick with
| Error _e -> Dream.respond ~status:`Not_Found "User does not exists" | Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
| Ok user_id -> | Ok user_id ->
render_unsafe render
(Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile user_id)) (Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile user_id))
request request
let logout request = let logout request =
let _ = Dream.invalidate_session request in let _ = Dream.invalidate_session request in
let content = "Logged out !" in let content = "Logged out !" in
render_unsafe content request render content request
let account_get request = let account_get request =
match Dream.session "user_id" request with Utils.logged_in_or_redirect request (fun user_id ->
| None -> not_logged_in "/account" request Utils.render_result request
| Some user_id -> @@ let* user = User.get_user user_id in
let res = Ok (User_account.f user request) )
match User.get_user user_id with
| Error e -> e
| Ok user -> User_account.f user request
in
render_unsafe res request
(*TODO ask for password *) (*TODO ask for password *)
let account_post request = let account_post request =
match Dream.session "user_id" request with Utils.logged_in_or_redirect request (fun user_id ->
| None -> not_logged_in "/account" request match%lwt Dream.form request with
| Some user_id -> ( | `Ok [ ("delete", _) ] ->
match%lwt Dream.form request with Utils.render_result request
| `Ok [ ("delete", _) ] -> @@ (*TODO ask for confirmation *)
(*TODO ask for confirmation *) let* () = User.delete_user user_id in
let res = let _unit_lwt = Dream.invalidate_session request in
Result.fold ~error:Fun.id Ok "Your account was deleted"
~ok:(fun () -> | `Ok [ ("email", email) ] ->
let _unit_lwt = Dream.invalidate_session request in Utils.render_result request
"Your account was deleted" ) @@ let* () = User.update_email email user_id in
(User.delete_user user_id) Ok "Your email was updated!"
in | `Ok
render_unsafe res request [ ("confirm-new-password", confirm_password)
| `Ok [ ("email", email) ] -> ; ("new-password", password)
let res = ] ->
Result.fold ~error:Fun.id Utils.render_result request
~ok:(fun () -> "Your email was updated!") @@
(User.update_email email user_id)
in
render_unsafe res request
| `Ok
[ ("confirm-new-password", confirm_password)
; ("new-password", password)
] ->
let res =
if password = confirm_password then if password = confirm_password then
Result.fold ~error:Fun.id let* () = User.update_password password user_id in
~ok:(fun _ -> "Your password was updated!") Ok "Your password was updated!"
(User.update_password password user_id) else Error "Password confirmation does not match"
else "Password confimation does not match" | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
in | `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
render_unsafe res request | `Expired _ | `Wrong_content_type ->
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form" Dream.empty `Bad_Request )
| `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
| `Expired _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
let profile_get request = let profile_get request =
match Dream.session "user_id" request with Utils.logged_in_or_redirect request (fun user_id ->
| None -> not_logged_in "/profile" request Utils.render_result request
| Some user_id -> @@ let* user = User.get_user user_id in
let res = Ok (User_profile.f user request) )
match User.get_user user_id with
| Error e -> e
| Ok user -> User_profile.f user request
in
render_unsafe res request
let profile_post request = let profile_post request =
match Dream.session "user_id" request with Utils.logged_in_or_redirect request (fun user_id ->
| None -> not_logged_in "/profile" request match%lwt Dream.form request with
| Some user_id -> ( | `Ok [ ("bio", bio) ] -> (
match%lwt Dream.form request with match User.update_bio bio user_id with
| `Ok [ ("bio", bio) ] -> ( | Ok () ->
match User.update_bio bio user_id with Dream.respond ~status:`See_Other
| Ok () -> ~headers:[ ("Location", "/profile") ]
Dream.respond ~status:`See_Other "Your bio was updated!"
~headers:[ ("Location", "/profile") ] | Error e -> render e request )
"Your bio was updated!" | `Ok [ ("nick", nick) ] -> (
| Error e -> render_unsafe e request ) match User.update_nick nick user_id with
| `Ok [ ("nick", nick) ] -> (
match User.update_nick nick user_id with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
"Your display nick was updated!"
| Error e -> render_unsafe e request )
| `Ok [ ("content", content); ("count", count); ("label", label) ] -> (
match int_of_string_opt count with
| None -> render_unsafe "Error: invalid count" request
| Some count -> (
match User.update_metadata count label content user_id with
| Ok () -> | Ok () ->
Dream.respond ~status:`See_Other Dream.respond ~status:`See_Other
~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 e request )
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form" | `Ok [ ("content", content); ("count", count); ("label", label) ] -> (
| `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _ match int_of_string_opt count with
| `Expired _ | `Wrong_content_type -> ( | None -> render "Error: invalid count" request
match%lwt Dream.multipart request with | Some count -> (
| `Ok [ ("file", file) ] -> ( match User.update_metadata count label content user_id with
match User.upload_avatar file user_id with | Ok () ->
| Ok () -> Dream.respond ~status:`See_Other
Dream.respond ~status:`See_Other ~headers:[ ("Location", "/profile") ]
~headers:[ ("Location", "/profile") ] "Your display nick was updated!"
"Your avatar was updated!" | Error e -> render e request ) )
| Error e -> render_unsafe e request )
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form" | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
| `Wrong_session _ | `Wrong_content_type -> | `Expired _ | `Wrong_content_type -> (
Dream.empty `Bad_Request ) ) match%lwt Dream.multipart request with
| `Ok [ ("file", file) ] -> (
match User.upload_avatar file user_id with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
"Your avatar was updated!"
| Error e -> render e 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 ) )
let get_post_image ~thumbnail request = let get_post_image ~thumbnail request =
let id = Dream.param request "id" in let id = Dream.param request "id" in
let image = let image =
if thumbnail then Image.get_thumbnail id else Image.get_content id (if thumbnail then Image.get_thumbnail else Image.get_content) id
in in
match image with match image with
| Error e -> render_unsafe e request | Error e -> render e request
| Ok image_opt -> ( | Ok image_opt -> (
match image_opt with match image_opt with
| None -> Dream.respond ~status:`Not_Found "Image does not exists" | None -> Dream.respond ~status:`Not_Found "Image does not exists"
@ -327,73 +292,71 @@ let get_avatar_image request =
| None -> failwith "can't find default avatar" | None -> failwith "can't find default avatar"
| Some avatar -> | Some avatar ->
Dream.respond ~headers:[ ("Content-Type", "image") ] avatar ) Dream.respond ~headers:[ ("Content-Type", "image") ] avatar )
| Error e -> render_unsafe e request ) | Error e -> render e request )
let markers request = let markers request =
let markers = Pp_babillard.get_markers () in let markers = Pp_babillard.get_markers () in
match markers with match markers with
| Ok markers -> | Ok markers ->
Dream.respond ~headers:[ ("Content-Type", "application/json") ] markers Dream.respond ~headers:[ ("Content-Type", "application/json") ] markers
| Error e -> render_unsafe e request | Error e -> render e request
let babillard_get request = render_unsafe (Babillard_page.f request) request let babillard_get request = render (Babillard_page.f request) request
let babillard_post request = let babillard_post request =
match Dream.session "user_id" request with Utils.logged_in_or_redirect request (fun user_id ->
| None -> not_logged_in "/" request match%lwt Dream.multipart request with
| Some user_id -> ( | `Ok
match%lwt Dream.multipart request with [ ("alt", [ (_, alt) ])
| `Ok ; ("category", categories)
[ ("alt", [ (_, alt) ]) ; ("file", file)
; ("category", categories) ; ("lat-input", [ (_, lat) ])
; ("file", file) ; ("lng-input", [ (_, lng) ])
; ("lat-input", [ (_, lat) ]) ; ("subject", [ (_, subject) ])
; ("lng-input", [ (_, lng) ]) ; ("tags", [ (_, tags) ])
; ("subject", [ (_, subject) ]) ; ("thread-comment", [ (_, comment) ])
; ("tags", [ (_, tags) ]) ]
; ("thread-comment", [ (_, comment) ]) | `Ok
] ( ("alt", [ (_, alt) ])
| `Ok :: ("file", file)
( ("alt", [ (_, alt) ]) :: ("lat-input", [ (_, lat) ])
:: ("file", file) :: ("lng-input", [ (_, lng) ])
:: ("lat-input", [ (_, lat) ]) :: ("subject", [ (_, subject) ])
:: ("lng-input", [ (_, lng) ]) :: ("tags", [ (_, tags) ])
:: ("subject", [ (_, subject) ]) :: ("thread-comment", [ (_, comment) ])
:: ("tags", [ (_, tags) ]) :: ([] as categories) ) -> (
:: ("thread-comment", [ (_, comment) ]) let categories = List.map snd categories in
:: ([] as categories) ) -> ( match (Float.of_string_opt lat, Float.of_string_opt lng) with
let categories = List.map snd categories in | None, _ -> render "Invalide coordinate" request
match (Float.of_string_opt lat, Float.of_string_opt lng) with | _, None -> render "Invalide coordinate" request
| None, _ -> render_unsafe "Invalide coordinate" request | Some lat, Some lng -> (
| _, None -> render_unsafe "Invalide coordinate" request let op_or_reply_data = `Op_data (categories, subject, lat, lng) in
| Some lat, Some lng -> ( let res =
let op_or_reply_data = `Op_data (categories, subject, lat, lng) in match file with
let res = | [] -> Babillard.make_post ~comment ~tags ~op_or_reply_data user_id
match file with | _ :: _ :: _ -> Error "More than one image"
| [] -> Babillard.make_post ~comment ~tags ~op_or_reply_data user_id | [ (image_name, image_content) ] ->
| _ :: _ :: _ -> Error "More than one image" let image_input = (image_name, alt, image_content) in
| [ (image_name, image_content) ] -> Babillard.make_post ~comment ~image_input ~tags ~op_or_reply_data
let image_input = (image_name, alt, image_content) in user_id
Babillard.make_post ~comment ~image_input ~tags ~op_or_reply_data in
user_id match res with
in | Ok thread_id ->
match res with let adress = Format.asprintf "/thread/%s" thread_id in
| Ok thread_id -> Dream.respond ~status:`See_Other
let adress = Format.asprintf "/thread/%s" thread_id in ~headers:[ ("Location", adress) ]
Dream.respond ~status:`See_Other "Your thread was posted!"
~headers:[ ("Location", adress) ] | Error e -> render e request ) )
"Your thread was posted!" | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| Error e -> render_unsafe e request ) ) | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form" | `Wrong_session _ | `Wrong_content_type ->
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ Dream.empty `Bad_Request )
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
let thread_feed_get request = let thread_feed_get request =
let thread_id = Dream.param request "thread_id" in let thread_id = Dream.param request "thread_id" in
if Babillard.thread_exist thread_id then if Babillard.thread_exist thread_id then
match Pp_babillard.feed thread_id with match Pp_babillard.feed thread_id with
| Error e -> render_unsafe e request | Error e -> render e request
| Ok feed -> | Ok feed ->
Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed
else Dream.respond ~status:`Not_Found "Thread not found" else Dream.respond ~status:`Not_Found "Thread not found"
@ -407,43 +370,41 @@ let thread_get request =
| Error e -> e | Error e -> e
| Ok thread_view -> Thread_page.f thread_view thread_id request | Ok thread_view -> Thread_page.f thread_view thread_id request
in in
render_unsafe res request render res request
else Dream.respond ~status:`Not_Found "Thread not found" else Dream.respond ~status:`Not_Found "Thread not found"
(*form to reply to a thread *) (*form to reply to a thread *)
let reply_post request = let reply_post request =
let parent_id = Dream.param request "thread_id" in Utils.logged_in_or_redirect request (fun user_id ->
match Dream.session "user_id" request with match%lwt Dream.multipart request with
| None -> not_logged_in (Format.sprintf "/thread/%s" parent_id) request | `Ok
| Some user_id -> ( [ ("alt", [ (_, alt) ])
match%lwt Dream.multipart request with ; ("file", file)
| `Ok ; ("reply-comment", [ (_, comment) ])
[ ("alt", [ (_, alt) ]) ; ("tags", [ (_, tags) ])
; ("file", file) ] -> (
; ("reply-comment", [ (_, comment) ]) let parent_id = Dream.param request "thread_id" in
; ("tags", [ (_, tags) ]) let op_or_reply_data = `Reply_data parent_id in
] -> ( let res =
let op_or_reply_data = `Reply_data parent_id in match file with
let res = | [] -> Babillard.make_post ~comment ~tags ~op_or_reply_data user_id
match file with | [ (image_name, image_content) ] ->
| [] -> Babillard.make_post ~comment ~tags ~op_or_reply_data user_id let image_input = (image_name, alt, image_content) in
| [ (image_name, image_content) ] -> Babillard.make_post ~comment ~image_input ~tags ~op_or_reply_data
let image_input = (image_name, alt, image_content) in user_id
Babillard.make_post ~comment ~image_input ~tags ~op_or_reply_data | _ :: _ :: _ -> Error "More than one image"
user_id in
| _ :: _ :: _ -> Error "More than one image" match res with
in | Ok post_id ->
match res with let adress = Format.sprintf "/thread/%s#%s" parent_id post_id in
| Ok post_id -> Dream.respond ~status:`See_Other
let adress = Format.sprintf "/thread/%s#%s" parent_id post_id in ~headers:[ ("Location", adress) ]
Dream.respond ~status:`See_Other "Your reply was posted!"
~headers:[ ("Location", adress) ] | Error e -> render e request )
"Your reply was posted!" | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| Error e -> render_unsafe e request ) | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form" | `Wrong_session _ | `Wrong_content_type ->
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ Dream.empty `Bad_Request )
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
let error_template _error _debug_info response = let error_template _error _debug_info response =
let status = Dream.status response in let status = Dream.status response in
@ -474,7 +435,7 @@ let routes =
; get_ "/delete/:post_id" delete_get ; get_ "/delete/:post_id" delete_get
; post "/delete/:post_id" delete_post ; post "/delete/:post_id" delete_post
; get_ "/discuss" Discuss.render ; get_ "/discuss" Discuss.render
; get_ "/discuss/:comrade_id" Discuss.render_one ; get_ "/discuss/:comrade_id" Discuss.renderone
; post "/discuss/:comrade_id" Discuss.post ; post "/discuss/:comrade_id" Discuss.post
; get_ "/img/:id" (get_post_image ~thumbnail:false) ; get_ "/img/:id" (get_post_image ~thumbnail:false)
; get_ "/img/s/:id" (get_post_image ~thumbnail:true) ; get_ "/img/s/:id" (get_post_image ~thumbnail:true)

13
src/pp_babillard.ml
View file

@ -31,7 +31,7 @@ let pp_post fmt t =
<a href="/img/%s"> <a href="/img/%s">
<img class="post-image" src="/img/s/%s" alt="%s" title="%s" data-id="%s" loading="lazy"> <img class="post-image" src="/img/s/%s" alt="%s" title="%s" data-id="%s" loading="lazy">
</a> </a>
</div> </div>
|} |}
id id image_alt image_alt id id id image_alt image_alt id
| None -> Format.fprintf fmt "" | None -> Format.fprintf fmt ""
@ -108,10 +108,11 @@ let pp_post fmt t =
in in
let categories = List.sort String.compare categories in let categories = List.sort String.compare categories in
let tags = List.sort String.compare tags in let tags = List.sort String.compare tags in
let pp_sep = Format.pp_print_space in
Format.fprintf fmt {|<div class="tags">%a%a</div>|} Format.fprintf fmt {|<div class="tags">%a%a</div>|}
(Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_category) (Format.pp_print_list ~pp_sep pp_print_category)
categories categories
(Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_tag) (Format.pp_print_list ~pp_sep pp_print_tag)
tags tags
in in
let tags = List.sort String.compare tags in let tags = List.sort String.compare tags in
@ -138,9 +139,9 @@ let pp_post fmt t =
%a %a
%a %a
%a %a
<blockquote class="post-comment">%s</blockquote> <blockquote class="post-comment">%s</blockquote>
%a %a
</div> </div>
|} |}
id subject link () post_info_view () image_view () comment tags_view () id subject link () post_info_view () image_view () comment tags_view ()
@ -295,7 +296,7 @@ let pp_checkboxes fmt () =
category category category category category category category category
in in
Format.fprintf fmt Format.fprintf fmt
{| {|
<div class="row"> <div class="row">
%a %a
</div>|} </div>|}

21
src/template_utils.ml
View file

@ -1,21 +0,0 @@
let get_title content =
let open Soup in
try
let soup = content |> parse in
soup $ "h1" |> R.leaf_text
with Failure _e -> "Permap"
let render ?title content request =
let title =
match title with None -> get_title content | Some title -> title
in
Dream.html
@@ Template.render_unsafe ~title:(Dream.html_escape title)
~content:(Dream.html_escape content)
request
let render_unsafe ?title content request =
let title =
match title with None -> get_title content | Some title -> title
in
Dream.html @@ Template.render_unsafe ~title ~content request

24
src/utils.ml Normal file
View file

@ -0,0 +1,24 @@
let get_title content =
let open Soup in
try
let soup = content |> parse in
soup $ "h1" |> R.leaf_text
with Failure _e -> "Permap"
let render ?title content request =
let title =
match title with None -> get_title content | Some title -> title
in
Dream.html @@ Template.render_unsafe ~title ~content request
(* TODO: different error code ? *)
let render_result request = function Error cnt | Ok cnt -> render cnt request
(* TODO: maybe we can remove path and find it in request ? *)
let logged_in_or_redirect request logged_in =
match Dream.session "user_id" request with
| None ->
let target = Dream.target request in
let redirect_url = Format.sprintf "/login=?redirect=%s" target in
Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] ""
| Some user_id -> logged_in user_id