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 let asset_loader _root path _request = match Content.read ("assets/" ^ path) with | None -> Dream.empty `Not_Found | Some asset -> Dream.respond asset let page name request = match Content.read (name ^ ".md") with | None -> Dream.empty `Not_Found | Some page -> let content = Omd.of_string page |> Omd.to_html in render_unsafe content request let homepage request = page "index" request let register_get request = render_unsafe (Register.f request) request let register_post request = match%lwt Dream.form request with | `Ok [ ("email", email); ("nick", nick); ("password", password) ] -> render_unsafe (Register.f ~nick ~email ~password request) request | `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _ | `Expired _ | `Wrong_content_type -> assert false let login_get request = render_unsafe (Login.f request) request let login_post request = match%lwt Dream.form request with | `Ok [ ("nick", nick); ("password", password) ] -> render_unsafe (Login.f ~nick ~password request) request | _ -> assert false let user request = render_unsafe ( match User.list () with | Ok s -> s | Error _ -> "" ) 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 let content = "Logged out !" in render_unsafe content request let profile_get request = match Dream.session "nick" request with | None -> render_unsafe "Not logged in" request | Some nick -> let bio = match User.get_bio nick with | Ok bio -> bio | Error e -> e in render_unsafe (User_profile.f nick bio request) request let profile_post request = match Dream.session "nick" request with | None -> render_unsafe "Not logged in" request | Some nick -> ( match%lwt Dream.form request with | `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 _ | `Invalid_token _ | `Wrong_session _ | `Expired _ | `Wrong_content_type -> ( match%lwt Dream.multipart request with | `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 _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _ | `Wrong_content_type -> Dream.empty `Bad_Request ) ) let avatar_image request = let nick = Dream.param "user" request in let avatar = User.get_avatar nick in match avatar with | Ok (Some avatar) -> Dream.respond ~headers:[ ("Content-Type", "image") ] avatar | Ok None | Error _ -> ( match Content.read "/assets/img/default_avatar.png" with | None -> Dream.empty `Not_Found | Some avatar -> Dream.respond ~headers:[ ("Content-Type", "image") ] avatar ) let post_image request = let post_id = Dream.param "post_id" request in let image = Babillard.get_post_image post_id in match image with | Ok image -> Dream.respond ~headers:[ ("Content-Type", "image") ] image | Error _ -> Dream.empty `Not_Found let plants_get request = render_unsafe (Plants_page.f request) request let markers ~board request = let markers = Babillard.get_markers board in match markers with | Ok markers -> Dream.respond ~headers:[ ("Content-Type", "application/json") ] markers | Error e -> render_unsafe e request let babillard_get request = render_unsafe (Babillard_page.f request) request let newthread_get ~board request = render_unsafe (Newthread_page.f ~board request) request let newthread_post ~board request = match Dream.session "nick" request with | None -> render_unsafe "Not logged in" request | Some nick -> ( match%lwt Dream.multipart request with (*TODO jpp du duplicat la *) | `Ok [ ("file", file) ; ("lat_input", [ (_, lat) ]) ; ("lng_input", [ (_, lng) ]) ; ("subject", [ (_, subject) ]) ; ("tags", [ (_, tags) ]) ; ("threadComment", [ (_, comment) ]) ] | `Ok (("file", file) :: ("lat_input", [ (_, lat) ]) :: ("lng_input", [ (_, lng) ]) :: ("subject", [ (_, subject) ]) :: ("tags", [ (_, tags) ]) :: ("threadComment", [ (_, comment) ]) :: _ :: _ ) -> ( 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 -> ( match file with | [] -> render_unsafe "No image" request | _ :: _ :: _ -> render_unsafe "More than one image" request | [ file ] -> ( match Babillard.make_op ~comment ~image:file ~lat ~lng ~subject ~tags ~board nick with | Ok thread_id -> let adress = Format.asprintf "/%a/%s" Babillard.pp_board board thread_id in Dream.respond ~status:`See_Other ~headers:[ ("Location", adress) ] "Your thread was posted!" | Error e -> render_unsafe e request ) ) ) | `Ok _ -> Dream.empty `Bad_Request | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _ | `Wrong_content_type -> Dream.empty `Bad_Request ) let thread_get request = let thread_id = Dream.param "thread_id" request in let thread_view = Babillard.view_thread thread_id in match thread_view with | Error e -> render_unsafe e request | Ok thread_view -> render_unsafe (Thread_page.f thread_view thread_id request) request (* get thread view but not wrapped in template, so we can display it on /babillard*) let thread_view request = let thread_id = Dream.param "thread_id" request in let thread_view = Babillard.view_thread thread_id in match thread_view with | Error e -> render_unsafe e request | Ok thread_view -> Dream.html (Thread_page.f thread_view thread_id request) (*form to reply to a thread *) let reply_post request = match Dream.session "nick" request with | None -> render_unsafe "Not logged in" request | Some nick -> ( match%lwt Dream.multipart request with | `Ok [ ("file", file) ; ("replyComment", [ (_, comment) ]) ; ("tags", [ (_, tags) ]) ] | `Ok (("file", file) :: ("tags", [ (_, tags) ]) :: ("replyComment", [ (_, comment) ]) :: _ :: _ ) -> ( let parent_id = Dream.param "thread_id" request in let res = match file with | [] -> Babillard.make_reply ~comment ~tags ~parent_id nick | [ file ] -> Babillard.make_reply ~comment ~image:file ~tags ~parent_id nick | _ :: _ :: _ -> Error "More than one image" in match res with | Ok post_id -> let adress = Format.sprintf "/babillard/%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.empty `Bad_Request | `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _ | `Wrong_content_type -> Dream.empty `Bad_Request ) let () = Dream.run @@ Dream.logger @@ Dream.memory_sessions @@ Dream.router [ Dream.get "/assets/**" (Dream.static ~loader:asset_loader "") ; Dream.get "/" homepage ; Dream.get "/register" register_get ; Dream.post "/register" register_post ; Dream.get "/login" login_get ; Dream.post "/login" login_post ; Dream.get "/user" user ; Dream.get "/user/:user" user_profile ; Dream.get "/user/:user/avatar" avatar_image ; Dream.get "/logout" logout ; Dream.get "/profile" profile_get ; Dream.post "/profile" profile_post ; Dream.get "/thread_view/:thread_id" thread_view ; Dream.get "/plants/markers" (markers ~board:Plants) ; Dream.get "/babillard/markers" (markers ~board:Babillard) ; Dream.get "/plants" plants_get ; Dream.get "/plants/new_thread" (newthread_get ~board:Plants) ; Dream.post "/plants/new_thread" (newthread_post ~board:Plants) ; Dream.get "/plants/:thread_id" thread_get (*todo, bad names ^^*) ; Dream.post "/plants/:thread_id" reply_post ; Dream.get "/post_pic/:post_id" post_image ; Dream.get "/babillard" babillard_get ; Dream.get "/babillard/new_thread" (newthread_get ~board:Babillard) ; Dream.post "/babillard/new_thread" (newthread_post ~board:Babillard) ; Dream.get "/babillard/:thread_id" thread_get ; Dream.post "/reply/:thread_id" reply_post ; Dream.get "/post_pic/:post_id" post_image ] @@ Dream.not_found