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:
pena 2022-04-05 23:08:57 +02:00 • committed by Swrup
parent 5f89b5eb61
commit 855564bed6
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))
citations
in
match thread_data with
| None -> Ok id
| Some { subject; lng; lat } ->
let^ () = Db.exec Q.upload_thread_info (id, subject, lat, lng) in
Ok id
let^ () =
match thread_data with
| None -> Ok ()
| Some { subject; lng; lat } ->
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 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"
else if String.length subject > 600 then Error "Invalid subject"
else
let thread_data = { subject; lng; lat } in
let* reply = build_reply ~comment ~image_info ~tag_list user_id in
let op = (thread_data, reply) in
Ok op
let build_image image_input =
let* image = Image.make_image image_input in
Ok image
Ok ({ subject; lng; lat }, reply)
let make_post ~comment ?image_input ~tags ~op_or_reply_data user_id =
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
| None -> Ok (None, None)
| 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))
in
let* post =
@ -391,8 +387,7 @@ let get_post id =
let get_thread_data id =
if thread_exist id then
let^? subject, lat, lng = Db.find_opt Q.get_thread_info id in
let thread_data = { subject; lat; lng } in
Ok thread_data
Ok { subject; lat; lng }
else Error "not an op"
let get_op id =

153
src/discuss.ml
View file

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

493
src/permap.ml
View file

@ -1,12 +1,5 @@
open Template_utils
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
open Utils
open Syntax
let asset_loader _root path _request =
match Content.read ("assets/" ^ path) with
@ -19,36 +12,36 @@ let page name request =
| None -> Dream.empty `Not_Found
| Some page ->
let content = Omd.of_string page |> Omd.to_html in
render_unsafe content request
render content 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 =
match%lwt Dream.form request with
| `Ok [ ("email", email); ("nick", nick); ("password", password) ] -> (
match User.register ~email ~nick ~password with
| Error e -> render_unsafe e request
| Error e -> render e request
| Ok () ->
let res =
Result.fold ~error:Fun.id
~ok:(fun _ -> "User created ! Welcome !")
(User.login ~login:nick ~password request)
in
render_unsafe res request )
render res request )
| `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
let login_get request = render (Login.f request) request
let login_post request =
match%lwt Dream.form request with
| `Ok [ ("login", login); ("password", password) ] -> (
match User.login ~login ~password request with
| Error e -> render_unsafe e request
| Error e -> render e request
| Ok () ->
let url =
match Dream.query request "redirect" with
@ -79,228 +72,200 @@ let admin_get request =
| Ok (posts, reports) ->
Pp_babillard.admin_page_content posts reports request
in
render_unsafe res request
render res request
let admin_post request =
match Dream.session "user_id" request with
| None -> not_logged_in "/admin" request
| Some user_id -> (
if not (User.is_admin user_id) then Dream.respond ~status:`Forbidden ""
else
match%lwt Dream.form request with
| `Ok [ ("action", action); ("post_id", id) ] -> (
let res =
match Babillard.get_post id with
| Error _e as e -> e
| Ok post -> (
let evil_user_id = post.user_id in
match Babillard.moderation_action_from_string action with
| None -> Error "Invalid action"
| Some action -> (
match action with
| Delete -> Babillard.try_delete_post ~user_id:evil_user_id id
| Banish -> User.banish evil_user_id
| Ignore -> Babillard.ignore_report id ) )
in
match res with
| Error e -> render_unsafe e request
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/admin") ]
"" )
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
Utils.logged_in_or_redirect request (fun user_id ->
if not (User.is_admin user_id) then Dream.respond ~status:`Forbidden ""
else
match%lwt Dream.form request with
| `Ok [ ("action", action); ("post_id", id) ] -> (
(* TODO: use let* and Utils.render_result ? *)
let res =
match Babillard.get_post id with
| Error _e as e -> e
| Ok post -> (
let evil_user_id = post.user_id in
match Babillard.moderation_action_from_string action with
| None -> Error "Invalid action"
| Some action -> (
match action with
| Delete -> Babillard.try_delete_post ~user_id:evil_user_id id
| Banish -> User.banish evil_user_id
| Ignore -> Babillard.ignore_report id ) )
in
match res with
| Error e -> render e request
| Ok () ->
(* TODO: ??? *)
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/admin") ]
"" )
| `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 =
let catalog_content =
Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.catalog_content ())
in
render_unsafe (Catalog_page.f catalog_content) request
render (Catalog_page.f catalog_content) request
let delete_get request =
let post_id = Dream.param request "post_id" in
let post_preview =
Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.view_post post_id)
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 post_id = Dream.param request "post_id" in
match Dream.session "user_id" request with
| None -> not_logged_in (Format.sprintf "/delete/%s" post_id) request
| Some user_id -> (
(* match on Dream.form needed for hidden csrf field *)
match%lwt Dream.form request with
| `Ok [] -> (
match Babillard.try_delete_post ~user_id post_id with
| Error e -> render_unsafe e request
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/") ]
"Your post was deleted!" )
| `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
Utils.logged_in_or_redirect request (fun user_id ->
(* match on Dream.form needed for hidden csrf field *)
match%lwt Dream.form request with
| `Ok [] -> (
(* TODO: use let* and Utils.render_result ? *)
let post_id = Dream.param request "post_id" in
match Babillard.try_delete_post ~user_id post_id with
| Error e -> render e request
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/") ]
"Your post was deleted!" )
| `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 report_get request =
let post_id = Dream.param request "post_id" in
let post_preview =
Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.view_post post_id)
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 post_id = Dream.param request "post_id" in
match Dream.session "user_id" request with
| None -> not_logged_in (Format.sprintf "/report/%s" post_id) request
| Some user_id -> (
match%lwt Dream.form request with
| `Ok [ ("reason", reason) ] ->
let res =
match Babillard.report ~user_id ~reason post_id with
| Error e -> e
| Ok () -> "The post was reported!"
in
render_unsafe res 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 )
Utils.logged_in_or_redirect request (fun user_id ->
match%lwt Dream.form request with
| `Ok [ ("reason", reason) ] ->
Utils.render_result request
@@
let post_id = Dream.param request "post_id" in
let* () = Babillard.report ~user_id ~reason post_id in
Ok "The post was reported!"
| `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 =
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 nick = Dream.param request "user" in
match User.get_user_id_from_nick nick with
| Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
| Ok user_id ->
render_unsafe
render
(Result.fold ~ok:Fun.id ~error:Fun.id (User.public_profile user_id))
request
let logout request =
let _ = Dream.invalidate_session request in
let content = "Logged out !" in
render_unsafe content request
render content request
let account_get request =
match Dream.session "user_id" request with
| None -> not_logged_in "/account" request
| Some user_id ->
let res =
match User.get_user user_id with
| Error e -> e
| Ok user -> User_account.f user request
in
render_unsafe res request
Utils.logged_in_or_redirect request (fun user_id ->
Utils.render_result request
@@ let* user = User.get_user user_id in
Ok (User_account.f user request) )
(*TODO ask for password *)
let account_post request =
match Dream.session "user_id" request with
| None -> not_logged_in "/account" request
| Some user_id -> (
match%lwt Dream.form request with
| `Ok [ ("delete", _) ] ->
(*TODO ask for confirmation *)
let res =
Result.fold ~error:Fun.id
~ok:(fun () ->
let _unit_lwt = Dream.invalidate_session request in
"Your account was deleted" )
(User.delete_user user_id)
in
render_unsafe res request
| `Ok [ ("email", email) ] ->
let res =
Result.fold ~error:Fun.id
~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 =
Utils.logged_in_or_redirect request (fun user_id ->
match%lwt Dream.form request with
| `Ok [ ("delete", _) ] ->
Utils.render_result request
@@ (*TODO ask for confirmation *)
let* () = User.delete_user user_id in
let _unit_lwt = Dream.invalidate_session request in
Ok "Your account was deleted"
| `Ok [ ("email", email) ] ->
Utils.render_result request
@@ let* () = User.update_email email user_id in
Ok "Your email was updated!"
| `Ok
[ ("confirm-new-password", confirm_password)
; ("new-password", password)
] ->
Utils.render_result request
@@
if password = confirm_password then
Result.fold ~error:Fun.id
~ok:(fun _ -> "Your password was updated!")
(User.update_password password user_id)
else "Password confimation does not match"
in
render_unsafe res request
| `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* () = User.update_password password user_id in
Ok "Your password was updated!"
else Error "Password confirmation does not match"
| `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 =
match Dream.session "user_id" request with
| None -> not_logged_in "/profile" request
| Some user_id ->
let res =
match User.get_user user_id with
| Error e -> e
| Ok user -> User_profile.f user request
in
render_unsafe res request
Utils.logged_in_or_redirect request (fun user_id ->
Utils.render_result request
@@ let* user = User.get_user user_id in
Ok (User_profile.f user request) )
let profile_post request =
match Dream.session "user_id" request with
| None -> not_logged_in "/profile" request
| Some user_id -> (
match%lwt Dream.form request with
| `Ok [ ("bio", bio) ] -> (
match User.update_bio bio user_id with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
"Your bio was updated!"
| Error e -> render_unsafe e request )
| `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
Utils.logged_in_or_redirect request (fun user_id ->
match%lwt Dream.form request with
| `Ok [ ("bio", bio) ] -> (
match User.update_bio bio user_id with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
"Your bio was updated!"
| Error e -> render e request )
| `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 _ -> 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
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
"Your avatar was updated!"
| Error e -> render_unsafe e request )
| Error e -> render e request )
| `Ok [ ("content", content); ("count", count); ("label", label) ] -> (
match int_of_string_opt count with
| None -> render "Error: invalid count" request
| Some count -> (
match User.update_metadata count label content user_id with
| Ok () ->
Dream.respond ~status:`See_Other
~headers:[ ("Location", "/profile") ]
"Your display nick 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 ) )
| `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
| 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 id = Dream.param request "id" in
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
match image with
| Error e -> render_unsafe e request
| Error e -> render e request
| Ok image_opt -> (
match image_opt with
| 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"
| Some avatar ->
Dream.respond ~headers:[ ("Content-Type", "image") ] avatar )
| Error e -> render_unsafe e request )
| Error e -> render e request )
let markers request =
let markers = Pp_babillard.get_markers () in
match markers with
| Ok 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 =
match Dream.session "user_id" request with
| None -> not_logged_in "/" request
| Some user_id -> (
match%lwt Dream.multipart request with
| `Ok
[ ("alt", [ (_, alt) ])
; ("category", categories)
; ("file", file)
; ("lat-input", [ (_, lat) ])
; ("lng-input", [ (_, lng) ])
; ("subject", [ (_, subject) ])
; ("tags", [ (_, tags) ])
; ("thread-comment", [ (_, comment) ])
]
| `Ok
( ("alt", [ (_, alt) ])
:: ("file", file)
:: ("lat-input", [ (_, lat) ])
:: ("lng-input", [ (_, lng) ])
:: ("subject", [ (_, subject) ])
:: ("tags", [ (_, tags) ])
:: ("thread-comment", [ (_, comment) ])
:: ([] as categories) ) -> (
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
| Some lat, Some lng -> (
let op_or_reply_data = `Op_data (categories, subject, lat, lng) in
let res =
match file with
| [] -> Babillard.make_post ~comment ~tags ~op_or_reply_data user_id
| _ :: _ :: _ -> Error "More than one image"
| [ (image_name, image_content) ] ->
let image_input = (image_name, alt, image_content) in
Babillard.make_post ~comment ~image_input ~tags ~op_or_reply_data
user_id
in
match res with
| Ok thread_id ->
let adress = Format.asprintf "/thread/%s" thread_id in
Dream.respond ~status:`See_Other
~headers:[ ("Location", adress) ]
"Your thread was posted!"
| Error e -> render_unsafe 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 )
Utils.logged_in_or_redirect request (fun user_id ->
match%lwt Dream.multipart request with
| `Ok
[ ("alt", [ (_, alt) ])
; ("category", categories)
; ("file", file)
; ("lat-input", [ (_, lat) ])
; ("lng-input", [ (_, lng) ])
; ("subject", [ (_, subject) ])
; ("tags", [ (_, tags) ])
; ("thread-comment", [ (_, comment) ])
]
| `Ok
( ("alt", [ (_, alt) ])
:: ("file", file)
:: ("lat-input", [ (_, lat) ])
:: ("lng-input", [ (_, lng) ])
:: ("subject", [ (_, subject) ])
:: ("tags", [ (_, tags) ])
:: ("thread-comment", [ (_, comment) ])
:: ([] as categories) ) -> (
let categories = List.map snd categories in
match (Float.of_string_opt lat, Float.of_string_opt lng) with
| None, _ -> render "Invalide coordinate" request
| _, None -> render "Invalide coordinate" request
| Some lat, Some lng -> (
let op_or_reply_data = `Op_data (categories, subject, lat, lng) in
let res =
match file with
| [] -> Babillard.make_post ~comment ~tags ~op_or_reply_data user_id
| _ :: _ :: _ -> Error "More than one image"
| [ (image_name, image_content) ] ->
let image_input = (image_name, alt, image_content) in
Babillard.make_post ~comment ~image_input ~tags ~op_or_reply_data
user_id
in
match res with
| Ok thread_id ->
let adress = Format.asprintf "/thread/%s" thread_id in
Dream.respond ~status:`See_Other
~headers:[ ("Location", adress) ]
"Your thread was posted!"
| 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 thread_feed_get request =
let thread_id = Dream.param request "thread_id" in
if Babillard.thread_exist thread_id then
match Pp_babillard.feed thread_id with
| Error e -> render_unsafe e request
| Error e -> render e request
| Ok feed ->
Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed
else Dream.respond ~status:`Not_Found "Thread not found"
@ -407,43 +370,41 @@ let thread_get request =
| Error e -> e
| Ok thread_view -> Thread_page.f thread_view thread_id request
in
render_unsafe res request
render res request
else Dream.respond ~status:`Not_Found "Thread not found"
(*form to reply to a thread *)
let reply_post request =
let parent_id = Dream.param request "thread_id" in
match Dream.session "user_id" request with
| None -> not_logged_in (Format.sprintf "/thread/%s" parent_id) request
| Some user_id -> (
match%lwt Dream.multipart request with
| `Ok
[ ("alt", [ (_, alt) ])
; ("file", file)
; ("reply-comment", [ (_, comment) ])
; ("tags", [ (_, tags) ])
] -> (
let op_or_reply_data = `Reply_data parent_id in
let res =
match file with
| [] -> Babillard.make_post ~comment ~tags ~op_or_reply_data user_id
| [ (image_name, image_content) ] ->
let image_input = (image_name, alt, image_content) in
Babillard.make_post ~comment ~image_input ~tags ~op_or_reply_data
user_id
| _ :: _ :: _ -> Error "More than one image"
in
match res with
| Ok post_id ->
let adress = Format.sprintf "/thread/%s#%s" parent_id post_id in
Dream.respond ~status:`See_Other
~headers:[ ("Location", adress) ]
"Your reply was posted!"
| Error e -> render_unsafe 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 )
Utils.logged_in_or_redirect request (fun user_id ->
match%lwt Dream.multipart request with
| `Ok
[ ("alt", [ (_, alt) ])
; ("file", file)
; ("reply-comment", [ (_, comment) ])
; ("tags", [ (_, tags) ])
] -> (
let parent_id = Dream.param request "thread_id" in
let op_or_reply_data = `Reply_data parent_id in
let res =
match file with
| [] -> Babillard.make_post ~comment ~tags ~op_or_reply_data user_id
| [ (image_name, image_content) ] ->
let image_input = (image_name, alt, image_content) in
Babillard.make_post ~comment ~image_input ~tags ~op_or_reply_data
user_id
| _ :: _ :: _ -> Error "More than one image"
in
match res with
| Ok post_id ->
let adress = Format.sprintf "/thread/%s#%s" parent_id post_id in
Dream.respond ~status:`See_Other
~headers:[ ("Location", adress) ]
"Your reply was posted!"
| 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 error_template _error _debug_info response =
let status = Dream.status response in
@ -474,7 +435,7 @@ let routes =
; get_ "/delete/:post_id" delete_get
; post "/delete/:post_id" delete_post
; get_ "/discuss" Discuss.render
; get_ "/discuss/:comrade_id" Discuss.render_one
; get_ "/discuss/:comrade_id" Discuss.renderone
; post "/discuss/:comrade_id" Discuss.post
; get_ "/img/:id" (get_post_image ~thumbnail:false)
; 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">
<img class="post-image" src="/img/s/%s" alt="%s" title="%s" data-id="%s" loading="lazy">
</a>
</div>
</div>
|}
id id image_alt image_alt id
| None -> Format.fprintf fmt ""
@ -108,10 +108,11 @@ let pp_post fmt t =
in
let categories = List.sort String.compare categories 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.pp_print_list ~pp_sep:Format.pp_print_space pp_print_category)
(Format.pp_print_list ~pp_sep pp_print_category)
categories
(Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_tag)
(Format.pp_print_list ~pp_sep pp_print_tag)
tags
in
let tags = List.sort String.compare tags in
@ -138,9 +139,9 @@ let pp_post fmt t =
%a
%a
%a
<blockquote class="post-comment">%s</blockquote>
<blockquote class="post-comment">%s</blockquote>
%a
</div>
</div>
|}
id subject link () post_info_view () image_view () comment tags_view ()
@ -295,7 +296,7 @@ let pp_checkboxes fmt () =
category category category category
in
Format.fprintf fmt
{|
{|
<div class="row">
%a
</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