geochan/src/permap.ml

open Utils
open Syntax

let asset_loader _root path _request =
  match Content.read ("assets/" ^ path) with
  | None -> Dream.empty `Not_Found
  | Some asset ->
    Dream.respond ~headers:[ ("Cache-Control", "max-age=151200") ] 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 content request

let about request = page "about" 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 e request
    | Ok () ->
      let res =
        Result.fold ~error:Fun.id
          ~ok:(fun _ -> "User created ! Welcome !")
          (User.login ~login:nick ~password request)
      in
      render res request )
  | form -> Utils.handle_invalid_form form

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 e request
    | Ok () ->
      let url =
        match Dream.query request "redirect" with
        | None -> "/"
        | Some redirect -> Dream.from_percent_encoded redirect
      in
      Dream.respond ~status:`See_Other
        ~headers:[ ("Location", url) ]
        "Logged in: Happy geo-posting!" )
  | form -> Utils.handle_invalid_form form

let admin_get request =
  match Dream.session "user_id" request with
  | None ->
    let redirect_url =
      Format.sprintf "/login?redirect=%s" (Dream.to_percent_encoded "/admin")
    in
    Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] ""
  | Some user_id ->
    if not (User.is_admin user_id) then Dream.respond ~status:`Forbidden ""
    else
      let res =
        match Babillard.get_reports () with
        | Error e -> e
        | Ok (posts, reports) ->
          Pp_babillard.admin_page_content posts reports request
      in
      render res request

let admin_post 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") ]
              "" )
        | form -> Utils.handle_invalid_form form )

let catalog request =
  let catalog_content =
    Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.catalog_content ())
  in
  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 (Delete_page.f post_preview post_id request) request

let delete_post 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!" )
      | form -> Utils.handle_invalid_form form )

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 (Report_page.f post_preview post_id request) request

let report_post 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!"
      | form -> Utils.handle_invalid_form form )

let user 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_id_from_nick nick with
  | Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
  | Ok user_id -> render_result request @@ User.public_profile user_id

let logout request =
  let _ = Dream.invalidate_session request in
  let content = "Logged out !" in
  render content request

let account_get 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 =
  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
          let* () = User.update_password password user_id in
          Ok "Your password was updated!"
        else Error "Password confirmation does not match"
      | form -> Utils.handle_invalid_form form )

let profile_get 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 =
  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 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"
      | `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
      | `Expired _ | `Wrong_content_type -> (
        (* TODO: why is this here ?! *)
        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 )
        | form -> Utils.handle_invalid_form form ) )

let get_post_image ~thumbnail request =
  let id = Dream.param request "id" in
  let image =
    (if thumbnail then Image.get_thumbnail else Image.get_content) id
  in
  match image with
  | Error e -> render e request
  | Ok image_opt -> (
    match image_opt with
    | None -> Dream.respond ~status:`Not_Found "Image does not exists"
    | Some image ->
      (* posts images do not change so we cache them *)
      Dream.respond
        ~headers:
          [ ("Cache-Control", "max-age=3628800, immutable")
          ; ("Content-Type", "image")
          ]
        image )

let get_avatar_image request =
  let nick = Dream.param request "user" in
  match User.get_id_from_nick nick with
  | Error _e -> Dream.respond ~status:`Not_Found "User does not exists"
  | Ok user_id -> (
    let avatar = Image.get_user_content user_id in
    match avatar with
    | Ok (Some avatar) ->
      Dream.respond ~headers:[ ("Content-Type", "image") ] avatar
    | Ok None -> (
      match Content.read "/assets/img/default_avatar.png" with
      | None -> failwith "can't find default avatar"
      | Some avatar ->
        Dream.respond ~headers:[ ("Content-Type", "image") ] avatar )
    | 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 e request

let babillard_get request = render (Babillard_page.f request) request

let babillard_post request =
  Utils.logged_in_or_redirect request (fun user_id ->
      match%lwt Dream.multipart request with
      | `Ok
          [ ("alt", [ (_, alt) ])
          ; ("category", categories)
          ; ("comment", [ (_, comment) ])
          ; ("file", file)
          ; ("lat-input", [ (_, lat) ])
          ; ("lng-input", [ (_, lng) ])
          ; ("subject", [ (_, subject) ])
          ; ("tags", [ (_, tags) ])
          ]
      | `Ok
          ( ("alt", [ (_, alt) ])
          :: ("comment", [ (_, comment) ])
          :: ("file", file)
          :: ("lat-input", [ (_, lat) ])
          :: ("lng-input", [ (_, lng) ])
          :: ("subject", [ (_, subject) ])
          :: ("tags", [ (_, tags) ])
          :: ([] 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 ) )
      | form -> Utils.handle_invalid_form form )

let thread_feed_get request =
  let thread_id = Dream.param request "thread_id" in
  match Pp_babillard.feed thread_id with
  | Error e -> render e request
  | Ok feed ->
    Dream.respond ~headers:[ ("Content-Type", "application/atom+xml") ] feed

let thread_get request =
  let thread_id = Dream.param request "thread_id" in
  let thread_view = Pp_babillard.view_thread thread_id in
  render
    ( match thread_view with
    | Error e -> e
    | Ok thread_view -> Thread_page.f thread_view thread_id request )
    request

(*form to reply to a thread *)
let reply_post request =
  Utils.logged_in_or_redirect request (fun user_id ->
      match%lwt Dream.multipart request with
      | `Ok
          [ ("alt", [ (_, alt) ])
          ; ("comment", [ (_, comment) ])
          ; ("file", file)
          ; ("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 )
      | form -> Utils.handle_invalid_form form )

let error_template _error _debug_info response =
  let status = Dream.status response in
  let code = Dream.status_to_int status in

  (*TODO improve: can't use template.elm.html because it needs "request" *)
  let%lwt body = Dream.body response in
  let reason =
    if String.equal "" body then Dream.status_to_string status else body
  in
  Dream.set_body response (Format.sprintf "%d: %s" code reason);
  Lwt.return response

let routes =
  (* this is just so that they're visually aligned *)
  let get_ = Dream.get in
  let post = Dream.post in

  [ get_ "/" babillard_get
  ; post "/" babillard_post
  ; get_ "/about" about
  ; get_ "/account" account_get
  ; post "/account" account_post
  ; get_ "/admin" admin_get
  ; post "/admin" admin_post
  ; get_ "/assets/**" (Dream.static ~loader:asset_loader "")
  ; get_ "/catalog" catalog
  ; get_ "/delete/:post_id" delete_get
  ; post "/delete/:post_id" delete_post
  ; get_ "/discuss" Discuss.render
  ; 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)
  ; get_ "/login" login_get
  ; post "/login" login_post
  ; get_ "/logout" logout
  ; get_ "/markers" markers
  ; get_ "/profile" profile_get
  ; post "/profile" profile_post
  ; get_ "/report/:post_id" report_get
  ; post "/report/:post_id" report_post
  ; get_ "/thread/:thread_id" thread_get
  ; post "/thread/:thread_id" reply_post
  ; get_ "/thread/:thread_id/feed" thread_feed_get
  ; get_ "/user" user
  ; get_ "/user/:user" user_profile
  ; get_ "/user/:user/avatar" get_avatar_image
  ]
  @
  if App.open_registration then
    [ get_ "/register" register_get; post "/register" register_post ]
  else []

let () =
  let logger = if App.log then Dream.logger else Fun.id in
  Dream.run ~port:App.port ~error_handler:(Dream.error_template error_template)
  @@ logger @@ Dream.cookie_sessions
  (* this should replace memory/cookie sessions but it doesn't work :-(
     @@ Dream.sql_pool Db.db_uri
     @@ Dream.sql_sessions
  *)
  @@ Dream.router routes