big squish

.ocamlformat

@@ -1,4 +1,4 @@
-version=0.24.1
+version=0.27.0
 assignment-operator=end-line
 break-cases=fit
 break-fun-decl=wrap

README.md

@@ -26,3 +26,18 @@ that can resolve to a geographical position.
 [AGPL-or-later]
 
 [AGPL-or-later]: ./LICENSE.md
+
+# TODO
+
+- post nb limit
+
+- make it a web-app instead
+
+- rework style, full screen map
+- dream -> drame
+- good moderation/admin system
+- all of [issues](https://git.zapashcanon.fr/zapashcanon/permap/issues)
+- imagemagick: WARNING: The convert command is deprecated in IMv7
+
+- db error on login fail instead of clean login error msg
+- login fail on login with email?

doc/dune

@@ -1,3 +0,0 @@
-(documentation
- (package permap)
- (mld_files index))

doc/index.mld

@@ -1,19 +0,0 @@
-{0 permap}
-
-{{:https://TODO} permap} is an {{:https://ocaml.org} OCaml} library/executable to TODO.
-
-{1:api API}
-
-
-{!modules:
-Permap
-}
-
-
-{1:private_api Private API}
-
-You shouldn't have to use any of these modules, they're used internally only.
-
-{!modules:
-TODO
-}

dune-project

@@ -1,4 +1,7 @@
-(lang dune 2.8)
+(lang dune 3.0)
+(using menhir 2.1)
+
+(generate_opam_files true)
 
 (implicit_transitive_deps false)
 
@@ -6,9 +9,13 @@
 
 (license AGPL-3.0-or-later)
 
-(authors "swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>")
+(authors
+  "swrup <swrup@protonmail.com>"
+  "Léo Andrès <contact@ndrs.fr>")
 
-(maintainers "Léo Andrès <contact@ndrs.fr>")
+(maintainers
+  "swrup <swrup@protonmail.com>"
+  "Léo Andrès <contact@ndrs.fr>")
 
 (source
  (uri git+https://git.zapashcanon.fr/zapashcanon/permap.git))
@@ -19,43 +26,40 @@
 
 (documentation https://doc.zapashcanon.fr/permap)
 
-(generate_opam_files true)
-
 (package
  (name permap)
  (synopsis "OCaml library/executable to TODO")
  (description "permap is an OCaml library/executable to TODO.")
  (tags
-  (permap forum map local-knownledge ecology permaculture plant))
+  (imageboard forum map leaflet single-page-application functional-reactive-programming))
  (depends
-   dream
-   lwt
-   yojson
-   brr
-   leaflet
-   js_of_ocaml
-   uuidm
-   scfg
-   crunch
-   safepass
-   omd
-   lambdasoup
    bos
+   brr
    caqti
    caqti-driver-sqlite3
    conan
    conan-database
+   crunch
+   data-encoding
+   digestif
    directories
    dream
    dream-pure
    emile
+   fmt
    fpath
-   lambdasoup
-   omd
+   htmlit
+   js_of_ocaml
+   leaflet
+   lwt
+   note
    safepass
    scfg
    uri
    uuidm
-   yojson
+   (alcotest :with-test)
+   (re :with-test)
+  (ocamlformat :with-dev-setup)
+   prelude
   (ocaml
-   (>= 4.08))))
+   (>= 5.1))))

example/dune

@@ -1,3 +0,0 @@
-(executable
- (name main)
- (modules main))

example/main.ml

@@ -1 +0,0 @@
-let () = Format.printf "TODO@."

permap.opam

@@ -2,47 +2,51 @@
 opam-version: "2.0"
 synopsis: "OCaml library/executable to TODO"
 description: "permap is an OCaml library/executable to TODO."
-maintainer: ["Léo Andrès <contact@ndrs.fr>"]
+maintainer: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
 authors: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
 license: "AGPL-3.0-or-later"
 tags: [
-  "permap" "forum" "map" "local-knownledge" "ecology" "permaculture" "plant"
+  "imageboard"
+  "forum"
+  "map"
+  "leaflet"
+  "single-page-application"
+  "functional-reactive-programming"
 ]
 homepage: "https://git.zapashcanon.fr/zapashcanon/permap"
 doc: "https://doc.zapashcanon.fr/permap"
 bug-reports: "https://git.zapashcanon.fr/zapashcanon/permap/issues"
 depends: [
-  "dune" {>= "2.8"}
-  "dream"
-  "lwt"
-  "yojson"
-  "brr"
-  "leaflet"
-  "js_of_ocaml"
-  "uuidm"
-  "scfg"
-  "crunch"
-  "safepass"
-  "omd"
-  "lambdasoup"
+  "dune" {>= "3.0"}
   "bos"
+  "brr"
   "caqti"
   "caqti-driver-sqlite3"
   "conan"
   "conan-database"
+  "crunch"
+  "data-encoding"
+  "digestif"
   "directories"
   "dream"
   "dream-pure"
   "emile"
+  "fmt"
   "fpath"
-  "lambdasoup"
-  "omd"
+  "htmlit"
+  "js_of_ocaml"
+  "leaflet"
+  "lwt"
+  "note"
   "safepass"
   "scfg"
   "uri"
   "uuidm"
-  "yojson"
-  "ocaml" {>= "4.08"}
+  "alcotest" {with-test}
+  "re" {with-test}
+  "ocamlformat" {with-dev-setup}
+  "prelude"
+  "ocaml" {>= "5.1"}
   "odoc" {with-doc}
 ]
 build: [

src/api.ml

@@ -0,0 +1,334 @@
+open Syntax
+open Err
+
+(* TODO server/client shared routes and types *)
+(* used to get url param/session field and convert to int if needed
+   not actually useful *)
+type _ t =
+  | User_id : string t
+  | Thread_id : int t
+  | Post_id : int t
+  | User_image_id : string t
+  | Post_image_id : int t
+
+let str : type a. a t -> string = function
+  | User_id -> "user_id"
+  | Thread_id -> "thread_id"
+  | Post_id -> "post_id"
+  | User_image_id -> "image_id"
+  | Post_image_id -> "image_id"
+
+let url_param : type a. Dream.request -> a t -> a Err.result =
+  let to_int s = int_of_string_opt s |> Option.to_result ~none:Err.Not_found in
+  fun request kind ->
+    let s = Dream.param request (str kind) in
+    match kind with
+    | User_id -> Ok s
+    | User_image_id -> Ok s
+    | Thread_id -> to_int s
+    | Post_id -> to_int s
+    | Post_image_id -> to_int s
+
+let session_user_id : Dream.request -> string option =
+ fun request -> Dream.session_field request (str User_id)
+
+let set_session_user_id : Dream.request -> string -> unit Lwt.t =
+ fun request v -> Dream.set_session_field request (str User_id) v
+
+let handle_invalid_form form =
+  match form with
+  | `Expired _ | `Wrong_session _ -> Error Bad_form
+  | `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
+  | `Wrong_content_type ->
+    (* usually indicate either bugs or attacks *)
+    Error Bad_form_suspicious
+
+let get_logged_user request =
+  match session_user_id request with
+  | None -> Error Unauthorized
+  | Some id -> User.get_user id
+
+(* TODO
+   better system for permissions? *)
+let check_is_admin request =
+  let* user = get_logged_user request in
+  if user.user_is_admin then Ok user else Error Forbidden
+
+let write_session request =
+  let open Types in
+  let+ user_private =
+    match session_user_id request with
+    | None -> Ok None
+    | Some user_id -> Result.map Option.some (User.get_user_private user_id)
+  in
+  let valid_for = float_of_int Config.csrf_lifetime in
+  let session =
+    { user_private
+    ; csrf_token = Dream.csrf_token ~valid_for request
+    ; csrf_time_limit = Unix.time () +. valid_for
+    }
+  in
+  Json_data.Write.session session
+
+let handle_login ~login ~password request =
+  let*! u = User.login ~login ~password in
+  let%lwt () = Dream.invalidate_session request in
+  let%lwt () = set_session_user_id request u.user_id in
+  Lwt.return @@ write_session request
+
+module GET = struct
+  let catalog _request =
+    let+ catalog = Post.get_catalog () in
+    Json_data.Write.catalog catalog
+
+  let thread_w_reply request =
+    let* thread_id = url_param request Thread_id in
+    let+ v = Post.get_thread_w_reply thread_id in
+    Json_data.Write.thread_w_reply v
+
+  let post request =
+    let* post_id = url_param request Post_id in
+    let+ v = Post.get_post post_id in
+    Json_data.Write.post v
+
+  let admin request =
+    let* _user = check_is_admin request in
+    let+ reports = Moderation.get_reports_all () in
+    Json_data.Write.reports reports
+
+  let user_page request =
+    let* user_id = url_param request User_id in
+    let+ user = User.get_user user_id in
+    Json_data.Write.user user
+
+  let session request = write_session request
+end
+
+module POST = struct
+  let new_thread request =
+    let*! user = get_logged_user request in
+    let%lwt form = Dream.multipart request in
+    Lwt.return
+    @@
+    match form with
+    | `Ok
+        [ ("alt", [ (_, alt) ])
+        ; ("comment", [ (_, comment) ])
+        ; ("file", file)
+        ; ("lat-input", [ (_, lat) ])
+        ; ("lng-input", [ (_, lng) ])
+        ; ("subject", [ (_, subject) ])
+        ] -> (
+      match (Float.of_string_opt lat, Float.of_string_opt lng) with
+      | None, _ | _, None -> Error Bad_form
+      | Some lat, Some lng ->
+        let* image_data =
+          match file with
+          | [] -> Ok None
+          | _ :: _ :: _ -> Error Bad_form
+          | [ (image_name, image_content) ] ->
+            let image_data = (image_name, alt, image_content) in
+            Ok (Some image_data)
+        in
+        let+ v =
+          Post.make_thread ~comment ~image_data ~subject ~lat ~lng user
+        in
+        Json_data.Write.thread_w_reply v )
+    | form -> handle_invalid_form form
+
+  let reply request =
+    let*! user = get_logged_user request in
+    let%lwt form = Dream.multipart request in
+    Lwt.return
+    @@
+    match form with
+    | `Ok
+        [ ("alt", [ (_, alt) ]); ("comment", [ (_, comment) ]); ("file", file) ]
+      ->
+      let* parent_thread =
+        let* thread_id = url_param request Thread_id in
+        Post.get_thread thread_id
+      in
+      let* image_data =
+        match file with
+        | [] -> Ok None
+        | _ :: _ :: _ -> Error Bad_form
+        | [ (image_name, image_content) ] ->
+          let image_data = (image_name, alt, image_content) in
+          Ok (Some image_data)
+      in
+      let* post = Post.make_post ~comment ~image_data ~parent_thread user in
+      let+ v = Post.get_thread_w_reply post.Types.parent_t_id in
+      Json_data.Write.thread_w_reply v
+    | form -> handle_invalid_form form
+
+  let login request =
+    let%lwt form = Dream.multipart request in
+    match form with
+    | `Ok [ ("login", [ (_, login) ]); ("password", [ (_, password) ]) ] -> (
+      (* TODO move all check like this to User/Post *)
+      let*! b = Moderation.is_banished login in
+      match b with
+      | true -> Lwt.return (Error (Unprocessable "YOU ARE BANISHED"))
+      | false -> handle_login ~login ~password request )
+    | form -> Lwt.return @@ handle_invalid_form form
+
+  let logout request =
+    let*! _user = get_logged_user request in
+    let%lwt form = Dream.multipart request in
+    match form with
+    | `Ok [] ->
+      let%lwt () = Dream.invalidate_session request in
+      Lwt.return @@ write_session request
+    | form -> Lwt.return @@ handle_invalid_form form
+
+  let delete request =
+    let*! user = get_logged_user request in
+    let%lwt form = Dream.multipart request in
+    Lwt.return
+    @@
+    match form with
+    | `Ok [] ->
+      let* post_id = url_param request Post_id in
+      let* post = Post.get_post post_id in
+      let+ () = Post.delete ~user post_id in
+      Json_data.Write.post post
+    | form -> handle_invalid_form form
+
+  let report request =
+    let*! user = get_logged_user request in
+    let%lwt form = Dream.multipart request in
+    Lwt.return
+    @@
+    match form with
+    | `Ok [ ("reason", [ (_, reason) ]) ] ->
+      let* post_id = url_param request Post_id in
+      let* () =
+        Moderation.make_report ~reporter_user_id:user.user_id ~reason post_id
+      in
+      let+ my_reports =
+        match user.user_is_admin with
+        | false -> Moderation.get_reports_made_by user.user_id
+        | true -> Moderation.get_reports_all ()
+      in
+      Json_data.Write.reports my_reports
+    | form -> handle_invalid_form form
+
+  let admin_ignore request =
+    let*! _user = check_is_admin request in
+    let%lwt form = Dream.multipart request in
+    Lwt.return
+    @@
+    match form with
+    | `Ok [] ->
+      let* post_id = url_param request Post_id in
+      let* () = Moderation.delete_report post_id in
+      let+ v = Moderation.get_reports_all () in
+      Json_data.Write.reports v
+    | form -> handle_invalid_form form
+
+  let admin_delete request =
+    let*! user = check_is_admin request in
+    let%lwt form = Dream.multipart request in
+    Lwt.return
+    @@
+    match form with
+    | `Ok [] ->
+      let* post_id = url_param request Post_id in
+      let* post = Post.get_post post_id in
+      let+ () = Post.delete ~user post_id in
+      Json_data.Write.post post
+    | form -> handle_invalid_form form
+
+  let admin_banish request =
+    let*! _user = check_is_admin request in
+    let%lwt form = Dream.multipart request in
+    Lwt.return
+    @@
+    match form with
+    | `Ok [] ->
+      let* evil_id = url_param request User_id in
+      let* evil = User.get_user evil_id in
+      let+ () = Moderation.banish evil_id in
+      Json_data.Write.user evil
+    | form -> handle_invalid_form form
+
+  let profile request =
+    let*! user = get_logged_user request in
+    let user_id = user.user_id in
+    let%lwt form = Dream.multipart request in
+    Lwt.return
+    @@
+    match form with
+    | `Ok [ ("bio", [ (_, bio) ]) ] ->
+      let* () = User.update_bio user_id bio in
+      write_session request
+    | `Ok [ ("nick", [ (_, nick) ]) ] ->
+      let* () = User.update_nick user_id nick in
+      write_session request
+    | `Ok [ ("delete-avatar", _) ] ->
+      let* () = User.delete_avatar user_id in
+      write_session request
+    | `Ok
+        [ ("alt", [ (None, alt) ]); ("file", [ (image_name, image_content) ]) ]
+      ->
+      let image_data = (image_name, alt, image_content) in
+      let* () = User.upload_avatar user_id image_data in
+      write_session request
+    | form -> handle_invalid_form form
+
+  (*TODO re-ask for password for account settings *)
+  let account request =
+    let*! user = get_logged_user request in
+    let user_id = user.user_id in
+    let%lwt form = Dream.multipart request in
+    match form with
+    | `Ok [ ("delete-account", _) ] -> (
+      (* TODO ask for confirmation *)
+      match User.delete_user user_id with
+      | Error _ as e -> Lwt.return e
+      | Ok () ->
+        let%lwt () = Dream.invalidate_session request in
+        Lwt.return
+        @@
+        (*let msg = "Your account was deleted" in*)
+        write_session request )
+    | `Ok [ ("email", [ (_, email) ]) ] ->
+      Lwt.return
+      @@
+      (*let msg = "Your email was updated!" in*)
+      let* () = User.update_email user_id email in
+      write_session request
+    | `Ok
+        [ ("confirm-new-password", [ (_, confirm_password) ])
+        ; ("new-password", [ (_, password) ])
+        ] ->
+      Lwt.return
+      @@
+      let* () =
+        if String.equal password confirm_password then
+          User.update_password user_id password
+          (*let msg = "Your password was updated!" in*)
+        else Error (Unprocessable "Password confirmation does not match")
+      in
+      write_session request
+    | form -> Lwt.return @@ handle_invalid_form form
+
+  let register request =
+    let*! () =
+      (* TODO move all check like this to User/Post *)
+      if Config.open_registration then Ok ()
+      else Error (Unprocessable "registration is not open")
+    in
+    let%lwt form = Dream.multipart request in
+    match form with
+    | `Ok
+        [ ("email", [ (_, email) ])
+        ; ("nick", [ (_, nick) ])
+        ; ("password", [ (_, password) ])
+        ] -> (
+      match User.register ~email ~nick ~password with
+      | Error _ as e -> Lwt.return e
+      | Ok () -> handle_login ~login:email ~password request )
+    | form -> Lwt.return @@ handle_invalid_form form
+end

src/app.ml

@@ -1,94 +0,0 @@
-module App_id = struct
-  let qualifier = "org"
-
-  let organization = "Permap"
-
-  let application = "permap"
-end
-
-module Project_dirs = Directories.Project_dirs (App_id)
-
-let data_dir =
-  match Project_dirs.data_dir with
-  | None -> failwith "can't compute data directory"
-  | Some data_dir -> data_dir
-
-let config_dir =
-  match Project_dirs.config_dir with
-  | None -> failwith "can't compute configuration directory"
-  | Some config_dir -> config_dir
-
-let config =
-  let filename = Filename.concat config_dir "config.scfg" in
-  if not @@ Sys.file_exists filename then
-    failwith
-    @@ Format.sprintf "configuration file `%s` does not exist, please create it"
-         filename;
-  Dream.log "config file: %s" filename;
-  match Scfg.Parse.from_file filename with
-  | Error e -> failwith e
-  | Ok config -> config
-
-let open_registration =
-  match Scfg.Query.get_dir "open_registration" config with
-  | None -> true
-  | Some open_registration -> (
-    match Scfg.Query.get_param 0 open_registration with
-    | Error e -> failwith e
-    | Ok "true" -> true
-    | Ok "false" -> false
-    | Ok _unknown ->
-      failwith "invalid `open_registration` value in configuration file" )
-
-let () = Dream.log "open_registration: %b" open_registration
-
-let port =
-  match Scfg.Query.get_dir "port" config with
-  | None -> 8080
-  | Some port -> (
-    match Scfg.Query.get_param 0 port with
-    | Error e -> failwith e
-    | Ok n -> (
-      try
-        let n = int_of_string n in
-        if n < 0 then raise (Invalid_argument "negative port number");
-        n
-      with Invalid_argument _msg ->
-        failwith "invalid `port` value in configuration file" ) )
-
-let () = Dream.log "port: %d" port
-
-let hostname =
-  match Scfg.Query.get_dir "hostname" config with
-  | None -> Format.sprintf "localhost:%d" port
-  | Some hostname ->
-    Result.fold ~error:failwith ~ok:Fun.id (Scfg.Query.get_param 0 hostname)
-
-let () = Dream.log "hostname: %s" hostname
-
-let log =
-  match Scfg.Query.get_dir "log" config with
-  | None -> true
-  | Some log -> (
-    match Scfg.Query.get_param 0 log with
-    | Error e -> failwith e
-    | Ok "true" -> true
-    | Ok "false" -> false
-    | Ok _unknown -> failwith "invalid `log` value in configuration file" )
-
-let () = Dream.log "log: %b" log
-
-let get_dirs name =
-  let dirs = Scfg.Query.get_dirs name config in
-  List.map
-    (fun dir ->
-      Result.fold ~error:failwith ~ok:Fun.id (Scfg.Query.get_param 0 dir) )
-    dirs
-
-let admins = get_dirs "admin"
-
-let categories = List.sort_uniq compare (get_dirs "category")
-
-let random_state = Random.State.make_self_init ()
-
-let () = Random.set_state random_state

src/assets/css/style.css

@@ -0,0 +1,411 @@
+/* TODO
+ * - nice color palette
+ * - nice fonts
+ * ... */
+:root {
+  --bg: #e8eaf6;
+  --bg-nav: #feafd6;
+  --bg-nav-hover: color-mix(in srgb, var(--bg-nav), black 15%);
+  --heavy-text: black;
+  --text: #333333;
+  --light-text: #5a5a5a;
+  --quote: #FFB300;
+  --bg-post: #C5E1A5;
+  --border-post: #9dd162;
+  --bg-post-highlight: #9dd162;
+  --border-form: #FFB300;
+  --bg-form: #FCE4EC;
+  --bg-error-popup: red;
+  --border-error-popup: red;
+  --bg-id: DodgerBlue;
+  --bg-id-hover: red;
+  --bg-id-remote: gray;
+  --bg-id-remote-loading: #FCE4EC;
+  --bg-id-remote-not-found: black;
+  --bg-id-remote-ready: blue;
+}
+
+
+/* unset default */
+ul {
+  list-style-type: none;
+  padding: 0;
+  margin-block: 0;
+}
+
+body {
+  margin: 0;
+  color: var(--light-text);
+  background-color: var(--bg);
+  font-size: 18px;
+  display: grid;
+  grid-template-rows: 3fr 97fr;
+  height: 100vh;
+}
+
+body * {
+  max-height: 100%;
+}
+
+nav {
+  background-color: var(--bg-nav);
+  display: flex;
+  justify-content: space-between;
+}
+
+nav div {
+  display: flex;
+  flex-direction: row;
+}
+
+.logout-btn {
+  all: unset;
+  outline: revert;
+}
+
+.logout-btn:hover {
+  cursor: pointer;
+}
+
+nav a, nav button,
+.sub-nav a, .sub-nav button {
+  display: flex;
+  align-items: center;
+  text-decoration: none;
+  color: var(--heavy-text);
+  transition: all 0.3s ease;
+  padding-inline: 2vw;
+}
+
+nav a:hover, nav button:hover,
+.sub-nav a:hover, .sub-nav button:hover {
+  background-color: var(--bg-nav-hover);
+}
+
+/* todo: use sub-grid? */
+.home-page {
+  display: grid;
+  grid-template-columns: 60fr 40fr ;
+  width: 100%;
+  height: 100%;
+}
+
+.home-left, .home-right {
+  position: relative;
+  width: 100%;
+  height: 100%;
+}
+
+#map {
+  position: sticky !important;
+  height: 100vh;
+  width: 100%;
+  top: 0;
+  left: 0;
+}
+
+.home-left-navigation-div {
+  display: flex;
+  margin-bottom: 7vh;
+  justify-content: flex-end;
+  margin-right: 7vw;
+}
+
+.map-btn-div {
+  display: flex;
+  position: absolute;
+  bottom: 0;
+  margin-bottom: 7vh;
+  justify-content: flex-end;
+  right: 0;
+  margin-right: 7vw;
+  z-index: 999;
+}
+
+.new-thread-view {
+  margin-inline: 1vw;
+  margin-block: 3vw;
+}
+
+/* css trick to have a dropdown menu on click */
+.dropdown {
+  position: relative;
+  display: grid;
+  grid-template-rows: 1fr;
+  grid-auto-rows: 0;
+
+  .dropdown-content, .dropdown-content-placeholder {
+    visibility: hidden;
+    display: flex;
+    flex-direction: column;
+  }
+  .dropdown-content {
+    transition: 0.2s ease-out;
+    z-index: 100000;
+    position: absolute;
+    top: 100%;
+    left: 0;
+  }
+  li {
+    background-color: var(--bg);
+  }
+  &:focus-within .dropdown-content {
+    visibility: visible;
+  }
+  .dropdown-arrow {
+    /* need to be block element to apply transform */
+    display: inline-block;
+    transition: 0.2s ease-out;
+  }
+  &:focus-within .dropdown-arrow {
+    transform: rotate(90deg);
+  }
+  .dropdown-open-btn, .dropdown-close-btn {
+    all: unset;
+    cursor: pointer;
+    user-select: none;
+    transition: 0.2s ease-out;
+  }
+  .dropdown-open-btn {
+    /* gap to add space between arrow and label */
+    display: flex;
+    gap: 3ch;
+    align-items: center;
+  }
+  .dropdown-open-btn:hover, .dropdown-open-btn:focus {
+    color: var(--bg-id-hover);
+  }
+  .dropdown-close-btn {
+    display: none;
+    position: absolute;
+    top: 0;
+    left: 0;
+    opacity: 0;
+    z-index: 99;
+  }
+  &:focus-within .dropdown-close-btn:not(:focus) {
+    display: inline-block;
+    min-width: 100%;
+  }
+}
+
+.thread-view {
+  display: flex;
+  flex-direction: column;
+  height: 100%;
+}
+
+.sub-nav {
+  display: flex;
+  flex-direction: row;
+  justify-content: space-between;
+  border-bottom: 1px solid black;
+}
+
+#bottom {
+  margin-top: auto;
+}
+
+.thread {
+  margin-inline: 1vw;
+  margin-block: 3vw;
+}
+
+.thread-subject {
+  color: var(--light-text);
+  font-size: 25px;
+  padding-left: 3vw;
+  padding-bottom: 1vh;
+}
+
+.thread-replies {
+  color: var(--light-text);
+  font-size: 20px;
+  display: flex;
+  flex-direction: column;
+  gap: 0.7vh;
+}
+
+.post {
+  background-color: var(--bg-post);
+  border: 1px solid var(--border-post);
+  border-top: none;
+  border-left: none;
+  padding: 5px;
+  padding-left: 10px;
+  width: fit-content;
+  max-width: 100%;
+}
+
+.post-info {
+  display: flex;
+  flex-direction: row;
+  gap: 0.2em;
+  align-items: center;
+  margin-bottom: 5px;
+}
+
+.post-info * {
+  text-align: center
+}
+
+.post-replies {
+  display: flex;
+  gap: 0.2em;
+}
+
+.post-id, .post-id-quote {
+  all: unset;
+  cursor: revert;
+  /* revert default focus ring */
+  outline: revert;
+  outline-offset: 3px;
+
+  background-color: var(--bg-id);
+  padding: 2px;
+  text-align: center;
+  transition: 0.2s ease-out;
+  display: inline-block;
+  height: calc(1lh - 2px);
+  border-radius: 6px;
+}
+.post-id-quote {
+  border-radius: 12px;
+}
+.post-id:hover, .post-id-quote:hover,
+.post-id:focus, .post-id-quote:focus {
+  background-color: var(--bg-id-hover);
+}
+
+.post-id-quote.remote {
+  background-color: var(--bg-id-remote);
+}
+.post-id-quote.remote.loading {
+  background-color: var(--bg-id-remote-loading);
+}
+.post-id-quote.remote.not-found {
+  background-color: var(--bg-id-remote-not-found);
+}
+.post-id-quote.remote.ready {
+  background-color: var(--bg-id-remote-ready);
+}
+
+.post-author-nick, .post-link-to-self {
+  text-decoration: none;
+  color: unset;
+  font-style: italic;
+  transition: 0.2s ease-out;
+}
+.post-author-nick:hover, .post-link-to-self:hover,
+.post-author-nick:focus, .post-link-to-self:focus {
+  color: var(--bg-id-hover);
+}
+
+.post-content {
+  display: flex;
+  gap: 10px;
+}
+
+/* TODO use image dim? better max-size? */
+.post-image-div {
+}
+
+.post-image {
+  max-width: 90vw;
+  height: auto;
+}
+
+.post-image-small {
+  max-width: 30vw;
+  max-height: 30vh;
+}
+
+.post-comment {
+  color: var(--text);
+  padding-top: 10px;
+  overflow-wrap: break-word;
+}
+.line-quote {
+  color: var(--quote);
+}
+
+.selected, .highlighted {
+  background-color: var(--bg-post-highlight);
+}
+
+.open-reply-popup-btn {
+  /* TODO */
+}
+
+.reply-popup {
+  display: table;
+  position: fixed;
+  right: 1vw;
+  top: 40vh;
+  background-color: var(--bg-form);
+  border: 2px solid var(--border-form);
+  padding: 5px;
+  z-index: 999990;
+}
+.reply-popup-dragzone {
+  display: flex;
+  justify-content: end;
+  cursor: move;
+}
+.close-reply-popup-btn {
+  line-height: 0.5lh;
+}
+.reply-popup-content {
+  display: flex;
+  flex-direction: column;
+  gap: 1em;
+  label {
+    display: block;
+  }
+  textarea {
+    width: 40ch;
+    height: 15ch;
+  }
+  & > div:last-child {
+    display: flex;
+    justify-content: center;
+    margin-top: 1em;
+  }
+}
+
+.error-popup {
+  display: table;
+  position: fixed;
+  right: 1vw;
+  bottom: 1vh;
+  padding: 5px;
+  z-index: 999999;
+  background-color: var(--bg-error-popup);
+  border: 2px solid var(--border-error-popup);
+  border-radius: 12px;
+}
+.error-popup-dragzone {
+  display: flex;
+  justify-content: end;
+  cursor: move;
+}
+.close-error-popup-btn {
+  /* TODO
+   * - always have good contrast
+   * - better style
+   * same for reply-form */
+  line-height: 0.5lh;
+}
+.error-popup-content {
+  padding: 2vw;
+  font-size: 18px;
+  color: white;
+}
+
+.hidden {
+  visibility: hidden;
+}
+
+.off {
+  display: none;
+}

src/assets/js/dune

@@ -0,0 +1,8 @@
+(rule
+ (target client.js)
+ (deps
+  (file ../../client/main.bc.js))
+ (action
+  (with-stdout-to
+   %{target}
+   (cat ../../client/main.bc.js))))

src/babillard.ml

@@ -1,425 +0,0 @@
-open Syntax
-open Caqti_request.Infix
-open Caqti_type
-
-type moderation_action =
-  | Ignore
-  | Delete
-  | Banish
-
-let moderation_action_to_string = function
-  | Ignore -> "ignore"
-  | Delete -> "delete"
-  | Banish -> "banish"
-
-let moderation_action_from_string = function
-  | "ignore" -> Some Ignore
-  | "delete" -> Some Delete
-  | "banish" -> Some Banish
-  | _ -> None
-
-type thread_data =
-  { subject : string
-  ; lng : float
-  ; lat : float
-  }
-
-type post =
-  { id : string
-  ; emojid : string
-  ; parent_id : string
-  ; date : float
-  ; user_id : string
-  ; nick : string
-  ; comment : string
-  ; image_info : (string * string) option
-  ; tags : string list
-  ; replies : string list
-  ; citations : string list
-  }
-
-type t =
-  | Op of thread_data * post
-  | Post of post
-
-let () =
-  let tables =
-    [| (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS post_user (post_id TEXT, user_id TEXT, \
-          PRIMARY KEY(post_id), FOREIGN KEY(user_id) REFERENCES user(user_id) \
-          ON DELETE CASCADE)"
-     ; (* one row for each thread, with thread's data *)
-       (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS thread_info (thread_id TEXT, subject \
-          TEXT, lat FLOAT, lng FLOAT, FOREIGN KEY(thread_id) REFERENCES \
-          post_user(post_id) ON DELETE CASCADE)"
-     ; (* map thread and reply to the thread *)
-       (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS thread_post (thread_id TEXT, post_id \
-          TEXT, FOREIGN KEY(thread_id) REFERENCES post_user(post_id) ON DELETE \
-          CASCADE, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON \
-          DELETE CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS post_replies (post_id TEXT, reply_id \
-          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
-          CASCADE, FOREIGN KEY(reply_id) REFERENCES post_user(post_id) ON \
-          DELETE CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS post_citations (post_id TEXT, cited_id \
-          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
-          CASCADE, FOREIGN KEY(cited_id) REFERENCES post_user(post_id) ON \
-          DELETE CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS post_date (post_id TEXT, date FLOAT, \
-          FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
-          CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS post_comment (post_id TEXT, comment TEXT, \
-          FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
-          CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS post_tags (post_id TEXT, tag TEXT, \
-          FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
-          CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS report (user_id TEXT, reason TEXT, date \
-          FLOAT,post_id TEXT, FOREIGN KEY(post_id) REFERENCES \
-          post_user(post_id) ON DELETE CASCADE, FOREIGN KEY(user_id) \
-          REFERENCES user(user_id) ON DELETE CASCADE)"
-    |]
-  in
-  if
-    Array.exists Result.is_error
-      (Array.map (fun query -> Db.exec query ()) tables)
-  then Dream.error (fun log -> log "can't create babillard's tables")
-
-module Q = struct
-  let upload_report =
-    Db.exec
-    @@ (tup4 string string float string ->. unit)
-         "INSERT INTO report VALUES (?,?,?,?)"
-
-  let get_reports =
-    Db.collect_list
-    @@ (unit ->* tup4 string string float string) "SELECT * FROM report"
-
-  let upload_post_id =
-    Db.exec
-    @@ (tup2 string string ->. unit) "INSERT INTO post_user VALUES (?,?)"
-
-  let upload_thread_info =
-    Db.exec
-    @@ (tup4 string string float float ->. unit)
-         "INSERT INTO thread_info VALUES (?,?,?,?)"
-
-  let upload_thread_post =
-    Db.exec
-    @@ (tup2 string string ->. unit) "INSERT INTO thread_post VALUES (?,?)"
-
-  let upload_post_reply =
-    Db.exec
-    @@ (tup2 string string ->. unit) "INSERT INTO post_replies VALUES (?,?)"
-
-  let upload_post_comment =
-    Db.exec
-    @@ (tup2 string string ->. unit) "INSERT INTO post_comment VALUES (?,?)"
-
-  let upload_post_tag =
-    Db.exec
-    @@ (tup2 string string ->. unit) "INSERT INTO post_tags VALUES (?,?)"
-
-  let upload_post_date =
-    Db.exec @@ (tup2 string float ->. unit) "INSERT INTO post_date VALUES (?,?)"
-
-  let get_post_user_id =
-    Db.find
-    @@ (string ->! string) "SELECT user_id FROM post_user WHERE post_id=?"
-
-  let get_post_comment =
-    Db.find
-    @@ (string ->! string) "SELECT comment FROM post_comment WHERE post_id=?"
-
-  let get_post_tags =
-    Db.collect_list
-    @@ (string ->* string) "SELECT tag FROM post_tags WHERE post_id=?"
-
-  let get_post_date =
-    Db.find @@ (string ->! float) "SELECT date FROM post_date WHERE post_id=?"
-
-  let get_post_citations =
-    Db.collect_list
-    @@ (string ->* string) "SELECT post_id FROM post_citations WHERE post_id=?"
-
-  let get_post_replies =
-    Db.collect_list
-    @@ (string ->* string) "SELECT reply_id FROM post_replies WHERE post_id=?"
-
-  let get_thread_posts =
-    Db.collect_list
-    @@ (string ->* string) "SELECT post_id FROM thread_post WHERE thread_id=?"
-
-  let count_thread_posts =
-    Db.find
-    @@ (string ->! int)
-         "SELECT COUNT(post_id) FROM thread_post WHERE thread_id=?"
-
-  let get_is_post =
-    Db.find
-    @@ (string ->! string)
-         "SELECT post_id FROM post_user WHERE post_id=? LIMIT 1"
-
-  let get_post_thread =
-    Db.find
-    @@ (string ->! string)
-         "SELECT thread_id FROM thread_post WHERE post_id=? LIMIT 1"
-
-  let get_thread_info =
-    Db.find
-    @@ (string ->! tup3 string float float)
-         "SELECT subject,lat,lng FROM thread_info WHERE thread_id=?"
-
-  let get_threads =
-    Db.collect_list @@ (unit ->* string) "SELECT thread_id FROM thread_info"
-
-  let delete_post =
-    Db.exec @@ (string ->. unit) "DELETE FROM post_user WHERE post_id=?"
-end
-
-let ignore_report =
-  Db.exec @@ (string ->. unit) "DELETE FROM report WHERE post_id=?"
-
-(*TODO switch to markdown !*)
-(* insert html into the comment, and keep tracks of citations :
-       -wraps lines starting with ">" with a <span class="quote">
-       -make raw posts uuid into links
-   (*TODO fix bad link if post is in other thread*)
-       -keeps tracks of every post cited in this comment
-      - add <br> at each line *)
-let parse_comment comment =
-  let citations = ref [] in
-
-  let pp_word fmt w =
-    let trim_w = String.trim w in
-    (* '>' is '&gt;' after html_escape *)
-    if String.length trim_w >= 8 then
-      let sub_w = String.sub trim_w 8 (String.length trim_w - 8) in
-      if
-        String.starts_with ~prefix:{|&gt;&gt;|} trim_w
-        && Option.is_some (Uuidm.of_string sub_w)
-      then begin
-        citations := sub_w :: !citations;
-        Format.fprintf fmt {|<a href="#%s">%s</a>|} sub_w w
-      end
-      else Format.pp_print_string fmt w
-    else Format.pp_print_string fmt w
-  in
-  let pp_line fmt l =
-    let trim_w = String.trim l in
-    (*insert quote*)
-    let words = String.split_on_char ' ' l in
-    if
-      String.starts_with ~prefix:{|&gt;|} trim_w
-      && not (String.starts_with ~prefix:{|&gt;&gt;|} trim_w)
-    then
-      Format.fprintf fmt {|<span class="quote">%a</span>|}
-        (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_word)
-        words
-    else Format.pp_print_list ~pp_sep:Format.pp_print_space pp_word fmt words
-  in
-
-  let comment = String.trim comment in
-  let lines = String.split_on_char '\n' comment in
-  (*insert <br>*)
-  let comment =
-    Format.asprintf "%a"
-      (Format.pp_print_list
-         ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n<br>")
-         pp_line )
-      lines
-  in
-  (* remove duplicate cited_id *)
-  let citations = List.sort_uniq String.compare !citations in
-  (comment, citations)
-
-let upload_post ~image post =
-  let thread_data, reply =
-    match post with
-    | Op (thread_data, reply) -> (Some thread_data, reply)
-    | Post reply -> (None, reply)
-  in
-  let { id; parent_id; date; user_id; comment; tags; citations; _ } = reply in
-
-  let* () = Q.upload_post_id (id, user_id) in
-  let* () = Q.upload_post_comment (id, comment) in
-  let* () = Q.upload_post_date (id, date) in
-  let* () = Q.upload_thread_post (parent_id, id) in
-  let* () =
-    match image with None -> Ok () | Some image -> Image.upload image id
-  in
-  match unwrap_list (fun tag -> Q.upload_post_tag (id, tag)) tags with
-  | Error _e as e -> e
-  | Ok _ -> (
-    match
-      unwrap_list (fun cited_id -> Q.upload_post_reply (cited_id, id)) citations
-    with
-    | Error _e as e -> e
-    | Ok _ ->
-      let* () =
-        match thread_data with
-        | None -> Ok ()
-        | Some { subject; lng; lat } ->
-          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
-  let id = Uuidm.to_string (Uuidm.v4_gen App.random_state ()) in
-  (* parent_id is None if this reply is supposed to be a new thread *)
-  let parent_id = Option.value parent_id ~default:id in
-  if Option.is_none (Uuidm.of_string parent_id) then Error "invalid thread id"
-  else if String.length comment > 10000 then Error "invalid comment"
-  else if List.length tag_list > 30 then Error "too much tags"
-  else if List.exists (fun tag -> String.length tag > 100) tag_list then
-    Error "tag too long"
-  else if Option.is_none image_info && String.length (String.trim comment) = 0
-  then Error "Your post must contain an image or a comment"
-  else
-    let tag_list =
-      List.map String.lowercase_ascii
-      @@ List.sort_uniq String.compare
-      @@ List.filter (( <> ) "")
-      @@ List.map String.trim
-      @@ List.map Dream.html_escape tag_list
-    in
-    let date = Unix.time () in
-    let comment, citations = parse_comment comment in
-    let* nick = User.get_nick user_id in
-    let* emojid = Emojid.make id in
-    let reply =
-      { id
-      ; emojid
-      ; parent_id
-      ; date
-      ; user_id
-      ; nick
-      ; comment
-      ; image_info
-      ; tags = tag_list
-      ; replies = []
-      ; citations
-      }
-    in
-    Ok reply
-
-let build_op ~comment ~image_info ~tag_list ~categories ~subject ~lat ~lng
-    user_id =
-  let subject = Dream.html_escape subject in
-  if List.exists (fun s -> not (List.mem s App.categories)) categories then
-    Error "Invalid category"
-  else
-    let tag_list = categories @ tag_list in
-    (* TODO latlng validation? *)
-    let is_valid_latlng = true in
-    if not is_valid_latlng then Error "Invalid coordinate"
-    else if String.length subject > 600 then Error "Invalid subject"
-    else
-      let* reply = build_reply ~comment ~image_info ~tag_list user_id in
-      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
-  let* image, image_info =
-    match image_input with
-    | None -> Ok (None, None)
-    | Some image_input ->
-      let* image = Image.make_image image_input in
-      Ok (Some image, Some (image.name, image.alt))
-  in
-  let* post =
-    match op_or_reply_data with
-    | `Reply_data parent_id ->
-      let* reply =
-        build_reply ~comment ~image_info ~tag_list ~parent_id user_id
-      in
-      Ok (Post reply)
-    | `Op_data (categories, subject, lat, lng) ->
-      let* thread_data, reply =
-        build_op ~comment ~image_info ~tag_list ~categories ~subject ~lat ~lng
-          user_id
-      in
-      Ok (Op (thread_data, reply))
-  in
-  upload_post ~image post
-
-(* true if post is an op too *)
-let post_exist id = Result.is_ok (Q.get_is_post id)
-
-let get_post id =
-  let* emojid = Emojid.get id in
-  let* parent_id = Q.get_post_thread id in
-  let* user_id = Q.get_post_user_id id in
-  let* nick = User.get_nick user_id in
-  let* comment = Q.get_post_comment id in
-  let* date = Q.get_post_date id in
-  let* image_info = Image.get_info id in
-
-  let* tags = Q.get_post_tags id in
-  let* replies = Q.get_post_replies id in
-  let* citations = Q.get_post_citations id in
-  let reply =
-    { id
-    ; emojid
-    ; parent_id
-    ; date
-    ; user_id
-    ; nick
-    ; comment
-    ; image_info
-    ; tags
-    ; replies
-    ; citations
-    }
-  in
-  Ok reply
-
-let get_thread_data id =
-  let* subject, lat, lng = Q.get_thread_info id in
-  Ok { subject; lat; lng }
-
-let get_op id =
-  let* thread_data = get_thread_data id in
-  let* post = get_post id in
-  Ok (thread_data, post)
-
-let get_posts ids = unwrap_list get_post ids
-
-let get_ops ids = unwrap_list get_op ids
-
-let try_delete_post ~user_id id =
-  let* post = get_post id in
-  if post.user_id = user_id || User.is_admin user_id then Q.delete_post id
-  else Error "You can only delete your posts"
-
-let report ~user_id ~reason id =
-  if not (post_exist id) then Error "This post exists not"
-  else if String.length reason > 2000 then Error "Your reason is too long.."
-  else
-    let reason = Dream.html_escape reason in
-    let date = Unix.time () in
-    Q.upload_report (user_id, reason, date, id)
-
-let get_reports () =
-  let* reports = Q.get_reports () in
-  let* posts =
-    unwrap_list (fun (_reporter_id, _reason, _date, id) -> get_post id) reports
-  in
-  (* add reporter_nick to reports so we can display it *)
-  let* reports =
-    unwrap_list
-      (fun (reporter_id, reason, date, id) ->
-        let* reporter_nick = User.get_nick reporter_id in
-        Ok (reporter_id, reporter_nick, reason, date, id) )
-      reports
-  in
-  Ok (posts, reports)

src/babillard_page.eml.html

@@ -1,31 +0,0 @@
-let f request =
-
-% let new_thread_button =
-%   if Option.is_none @@ Dream.session "nick" request then
-%     Format.sprintf
-%   {|<a class="btn btn-primary" id="new-thread-button-redirect" href="/login?redirect=%s">New Thread</a>|} (Dream.to_percent_encoded "/")
-%   else {|<button class="btn btn-primary on" id="new-thread-button">New Thread</button>|}
-% in
-  <script type="text/javascript" src="/assets/js/babillard.js" defer="defer"></script>
-  <h1>Babillard is love ❤️</h1>
-  <br />
-  <div class="row mb-3">
-    <div class="col-lg-6 col-md-12">
-      <div id="map"></div>
-      <br />
-      <button class="btn btn-primary" id="geolocalize">Geolocalize me</button>
-      <button class="btn btn-primary off" id="return-button">Return</button>
-      <%s! new_thread_button %>
-    </div>
-    <div class="col-lg-6 col-md-12">
-      <div class="thread-preview on" id="thread-preview"></div>
-      <div class="new-thread off" id="new-thread">
-        <h2>New thread</h2>
-        <span id="new-thread-info">
-          Click the map and make a new thread:
-        </span>
-        <br />
-        <%s! Post_form.f None request %>
-      </div>
-    </div>
-  </div>

src/caqti_db.ml

@@ -0,0 +1,48 @@
+open Caqti_request.Infix
+
+let map_err = function
+  | Error e -> Error (Err.Internal (Db (Caqti_error.show e)))
+  | Ok _ as ok -> ok
+
+module Db = struct
+  module Db =
+    (val Caqti_blocking.connect Config_serv.db_uri |> Caqti_blocking.or_fail)
+
+  let exec q v = Db.exec q v |> map_err
+
+  let find q v = Db.find q v |> map_err
+
+  let find_opt q v = Db.find_opt q v |> map_err
+
+  let collect_list q v = Db.collect_list q v |> map_err
+
+  let exec_unsafe q v =
+    match Db.exec q v with
+    | Error e ->
+      Dream.error (fun log -> log "%s" (Caqti_error.show e));
+      exit 1
+    | Ok () -> ()
+
+  let do_transaction f =
+    let open Syntax in
+    let* () = Db.start () |> map_err in
+    match f () with
+    | Error _ as error ->
+      let* () = Db.rollback () |> map_err in
+      error
+    | Ok v ->
+      let* () = Db.commit () |> map_err in
+      Ok v
+end
+
+let set_foreign_keys_on = Caqti_type.(unit ->. unit) "PRAGMA foreign_keys = ON"
+
+let create_dream_session =
+  Caqti_type.(unit ->. unit)
+    "CREATE TABLE IF NOT EXISTS dream_session (id TEXT PRIMARY KEY, label TEXT \
+     NOT NULL, expires_at REAL NOT NULL, payload TEXT NOT NULL)"
+
+let () =
+  Db.exec_unsafe set_foreign_keys_on ();
+  Db.exec_unsafe create_dream_session ();
+  ()

src/caqti_db.mli

@@ -0,0 +1,17 @@
+open Err
+
+module Db : sig
+  val exec : ('a, unit, [< `Zero ]) Caqti_request.t -> 'a -> unit result
+
+  val find : ('a, 'b, [< `One ]) Caqti_request.t -> 'a -> 'b result
+
+  val find_opt :
+    ('a, 'b, [< `One | `Zero ]) Caqti_request.t -> 'a -> 'b option result
+
+  val collect_list :
+    ('a, 'b, [ `Many | `One | `Zero ]) Caqti_request.t -> 'a -> 'b list result
+
+  val exec_unsafe : ('a, unit, [< `Zero ]) Caqti_request.t -> 'a -> unit
+
+  val do_transaction : (unit -> 'a result) -> 'a result
+end

src/catalog_page.eml.html

@@ -1,8 +0,0 @@
-let f content =
-
-<script type="text/javascript" src="/assets/js/catalog.js" defer="defer"></script>
-  <h1>Catalog:</h1>
-  <br />
-  <div class="row mb-3">
-      <%s! content %>
-  </div>

src/client/client_types.ml

@@ -0,0 +1,207 @@
+open Types
+
+type ('a, 'b) wrap = ('a, 'b) Page.wrap
+
+module Fragment = struct
+  type t =
+    | Empty
+    | Top
+    | Bottom
+    | Id of (int, int) wrap
+
+  let unwrap_id = function Page.Loading v | Not_found v -> v | Ready v -> v
+
+  let to_string = function
+    | Empty -> ""
+    | Top -> "top"
+    | Bottom -> "bottom"
+    | Id v ->
+      let id = unwrap_id v in
+      string_of_int id
+
+  let of_string s =
+    match s with
+    | "" -> Ok Empty
+    | "top" -> Ok Top
+    | "bottom" -> Ok Bottom
+    | s -> (
+      match int_of_string_opt s with
+      | None -> Fmt.error "invalid fragment format `%s`" s
+      | Some id -> Ok (Id (Loading id)) )
+
+  let get_ready_value v =
+    match v with
+    | Empty | Top | Bottom -> Some (to_string v)
+    | Id (Loading _) | Id (Not_found _) -> None
+    | Id (Ready _) -> Some (to_string v)
+end
+
+module Post_form_data = struct
+  (* TODO (?) have a more genral thing for every form *)
+  (* store input data of reply and new thread form
+     both form share the same data:
+       text in comment on reply form will show up on new thread form too
+     wraped in module because record field conflict *)
+  type t =
+    { subject : string
+    ; comment : string
+    ; file : string option
+    ; alt : string option
+    ; is_open : bool
+    ; latlng : (float * float) option
+    }
+
+  let empty =
+    { subject = ""
+    ; comment = ""
+    ; file = None
+    ; alt = None
+    ; is_open = false
+    ; latlng = None
+    }
+end
+
+type meth =
+  | GET
+  | POST
+
+type response =
+  { meth : meth
+  ; url : string
+  ; status : int
+  ; status_text : string
+  ; body : string
+  }
+
+(* https://developer.mozilla.org/en-US/docs/Web/API/Window/fetch#exceptions *)
+(* https://developer.mozilla.org/en-US/docs/Web/API/Response/text#exceptions *)
+type network_error =
+  | Fetch_err of string
+  | Body_err of string
+  | Read_err of string * response
+
+(* error type for interactions with server *)
+type error =
+  | Network_err of network_error
+  | Err_response of Err.t
+
+type map_action =
+  | Move_end of (float * float * int)
+  | Zoom_end of (float * float * int)
+  | Click_latlng of (float * float)
+  | Click_marker of Types.post_id
+  | Geoloc_start
+  | Geoloc_pos of Brr_io.Geolocation.Pos.t
+  | Geoloc_err of Brr_io.Geolocation.Error.t
+
+type form_action =
+  | Form_open
+  | Form_close
+  | Form_insert_quote of post_id
+  | Form_comment of string
+  | Form_file of string option
+  | Form_alt of string option
+  | Form_subject of string
+  | Form_latlng of (float * float) option
+  | Form_reset
+
+(* post-quote's (x,y,w,h)
+   needed to compute quickview position *)
+type rect = float * float * float * float
+
+type action =
+  | Navigation_event of (Page.t option * Fragment.t)
+  | Post_form_change of form_action
+  | Map_input of map_action
+  | Submit_event of (Form_kind.wrapped * Brr.El.t)
+  | Quickview_change of (rect * post_id) option
+  | Image_click of post_id
+  | Clear_error
+
+type data_update =
+  | Post_update of post
+  | Thread_update of Thread_w_reply.t
+  | Catalog_update of thread list
+  | User_update of user
+  | Reports_update of report list
+  | Session_update of session
+
+(* printer/util *)
+
+let pp_meth fmt = function GET -> Fmt.pf fmt "GET" | POST -> Fmt.pf fmt "POST"
+
+let pp_response fmt r =
+  Fmt.pf fmt
+    {|{ meth: `%a`; url: `%s`; status code: `%d`; status text: `%s`; body:`%s`}@.|}
+    pp_meth r.meth r.url r.status r.status_text r.body
+
+let pp_network_error fmt err =
+  match err with
+  | Fetch_err s -> Fmt.pf fmt "network fetch error `%s`" s
+  | Body_err s -> Fmt.pf fmt "network read body error `%s`" s
+  | Read_err (s, r) ->
+    Fmt.pf fmt "network read error `%s` on response `%a`" s pp_response r
+
+let pp_error fmt err =
+  match err with
+  | Network_err e -> pp_network_error fmt e
+  | Err_response e -> Err.pp fmt e
+
+let pp_map_action fmt a =
+  Fmt.pf fmt "map ";
+  match a with
+  | Move_end (lat, lng, zoom) ->
+    Fmt.pf fmt "move end `(%f, %f, %d)`" lat lng zoom
+  | Zoom_end (lat, lng, zoom) ->
+    Fmt.pf fmt "zoom end `(%f, %f, %d)`" lat lng zoom
+  | Click_latlng (lat, lng) -> Fmt.pf fmt "click latlng `(%f, %f)`" lat lng
+  | Click_marker post_id -> Fmt.pf fmt "click marker `%d`" post_id
+  | Geoloc_start -> Fmt.pf fmt "geoloc start"
+  | Geoloc_pos pos ->
+    let open Brr_io.Geolocation.Pos in
+    Fmt.pf fmt "geoloc pos `(%f, %f)`" (latitude pos) (longitude pos)
+  | Geoloc_err err ->
+    let open Brr_io.Geolocation.Error in
+    Fmt.pf fmt "geoloc error, code `%d` message `%s`" (code err)
+      (message err |> Jstr.to_string)
+
+let pp_form_action fmt a =
+  Fmt.pf fmt "form ";
+  match a with
+  | Form_open -> Fmt.pf fmt "open"
+  | Form_close -> Fmt.pf fmt "close"
+  | Form_insert_quote post_id -> Fmt.pf fmt "insert quote `%d`" post_id
+  | Form_comment s -> Fmt.pf fmt "comment `%s`" s
+  | Form_file o -> Fmt.pf fmt "file `%s`" (Option.value ~default:"none" o)
+  | Form_alt o -> Fmt.pf fmt "alt `%s`" (Option.value ~default:"none" o)
+  | Form_subject s -> Fmt.pf fmt "subject `%s`" s
+  | Form_latlng o -> (
+    match o with
+    | None -> Fmt.pf fmt "latlng `none`"
+    | Some (lat, lng) -> Fmt.pf fmt "latlng `(%f, %f)`" lat lng )
+  | Form_reset -> Fmt.pf fmt "reset"
+
+let pp_action fmt = function
+  | Navigation_event (opt, frag) ->
+    let s =
+      match opt with
+      | None -> "none"
+      | Some p -> p |> Page.to_uri |> Brr.Uri.to_jstr |> Jstr.to_string
+    in
+    Fmt.pf fmt "navigation event `(%s, %s)`" s (Fragment.to_string frag)
+  | Post_form_change a -> Fmt.pf fmt "post form change `%a`" pp_form_action a
+  | Map_input a -> Fmt.pf fmt "map input `%a`" pp_map_action a
+  | Submit_event (W kind, _el) ->
+    Fmt.pf fmt "submit event `%s`" (Form_kind.name kind)
+  | Quickview_change _opt -> Fmt.pf fmt "quickview change"
+  | Image_click post_id -> Fmt.pf fmt "image click `%d`" post_id
+  | Clear_error -> Fmt.pf fmt "clear error"
+
+let pp_data_update fmt a =
+  match a with
+  | Post_update v -> Fmt.pf fmt "post update `%d`" v.id
+  | Thread_update v -> Fmt.pf fmt "thread update `%d`" v.op.id
+  | Catalog_update _l -> Fmt.pf fmt "catalog update"
+  | User_update u -> Fmt.pf fmt "user update `%s`" u.user_id
+  | Reports_update _l -> Fmt.pf fmt "report update"
+  | Session_update _session -> Fmt.pf fmt "session update"

src/client/db.ml

@@ -0,0 +1,129 @@
+open Types
+
+let session : session option ref = ref None
+
+let update_session (v : session) =
+  session := Some v;
+  ()
+
+let get_session () =
+  match !session with
+  | None -> Fmt.failwith "called get_session with uninitialized session"
+  | Some v -> v
+
+let post_db : (post_id, post) Hashtbl.t = Hashtbl.create 0x1000
+
+let add_post (v : post) =
+  Hashtbl.replace post_db v.id v;
+  ()
+
+let find_post id =
+  match Hashtbl.find_opt post_db id with None -> None | Some v -> Some v
+
+let post_db_404 : (post_id, unit) Hashtbl.t = Hashtbl.create 0x100
+
+let post_is_404 id = Hashtbl.mem post_db_404 id
+
+let thread_is_404 id = Hashtbl.mem post_db_404 id
+
+let user_db_404 : (user_id, unit) Hashtbl.t = Hashtbl.create 0x100
+
+let user_is_404 id = Hashtbl.mem user_db_404 id
+
+let catalog : thread list ref = ref []
+
+let update_catalog (v : thread list) =
+  catalog := v;
+  ()
+
+let get_catalog () = !catalog
+
+let thread_w_reply : Thread_w_reply.t option ref = ref None
+
+let update_thread_w_reply (o : Thread_w_reply.t option) =
+  Hashtbl.clear post_db;
+  thread_w_reply := o;
+  Option.iter (fun v -> List.iter add_post v.Thread_w_reply.reply_l) o;
+  ()
+
+let find_thread_w_reply id =
+  match !thread_w_reply with
+  | None -> None
+  | Some v -> ( match v.op.id = id with false -> None | true -> Some v )
+
+let reports : report list ref = ref []
+
+let update_reports (v : report list) =
+  reports := v;
+  ()
+
+let get_reports () = !reports
+
+let user : user option ref = ref None
+
+let update_user (v : user option) =
+  user := v;
+  ()
+
+let find_user id =
+  match !user with
+  | None -> None
+  | Some v -> (
+    match String.equal v.user_id id with false -> None | true -> Some v )
+
+let clear () =
+  session := None;
+  update_catalog [];
+  update_thread_w_reply None;
+  update_reports [];
+  Hashtbl.clear post_db;
+  Hashtbl.clear post_db_404;
+  update_user None;
+  ()
+
+let add_post_404 id =
+  (* in case post is a thread we have to remove id + potential reply_l *)
+  let to_delete_l =
+    match find_thread_w_reply id with
+    | Some v -> List.map (fun p -> p.id) v.reply_l
+    | None -> [ id ]
+  in
+  let filter get_id l =
+    (* O(n^2) ~~ *)
+    List.filter (fun v -> not @@ List.mem (get_id v) to_delete_l) l
+  in
+
+  update_catalog (get_catalog () |> filter (fun v -> v.op.id));
+
+  update_thread_w_reply
+    ( match find_thread_w_reply id with
+    | Some _ -> None
+    | None -> (
+      match !thread_w_reply with
+      | None -> None
+      | Some v ->
+        let v = { v with reply_l = filter (fun v -> v.id) v.reply_l } in
+        Some v ) );
+
+  update_reports (!reports |> filter (fun r -> r.reported_post.id));
+
+  Hashtbl.remove post_db id;
+  Hashtbl.add post_db_404 id ();
+  ()
+
+let add_thread_404 = add_post_404
+
+let add_user_404 id =
+  let session = get_session () in
+  let session =
+    match session.user_private with
+    | Some u when String.equal u.user_id id ->
+      (* dead session here *)
+      { session with user_private = None }
+    | _ -> session
+  in
+  update_session session;
+  begin
+    match find_user id with Some _ -> update_user None | None -> ()
+  end;
+  ()

src/client/dune

@@ -0,0 +1,17 @@
+(executable
+ (name main)
+ (modules :standard)
+ (libraries
+  config_impl ; virtual
+  shared
+  comment
+  leaflet
+  note
+  note.brr
+  brr
+  fmt
+  unix
+  prelude)
+ (modes js)
+ (flags
+  (:standard -open Prelude)))

src/client/events.ml

@@ -0,0 +1,8 @@
+open Note
+open Client_types
+
+let (actions : action event), send_action = E.create ()
+
+let (data_updates : data_update event), send_data_update = E.create ()
+
+let (errors : error event), send_error = E.create ()

src/client/form_kind.ml

@@ -0,0 +1,50 @@
+(* TODO server/client shared routes and types *)
+open Types
+
+type _ t =
+  | Home : Thread_w_reply.t t
+  | Register : session t
+  | Login : session t
+  | Logout : session t
+  | Profile : session t
+  | Account : session t
+  | Thread : post_id -> Thread_w_reply.t t
+  | Delete : post_id -> post t
+  | Report :
+      post_id
+      -> report list t (* only reports made by user, or all if user is admin *)
+  | Admin_ignore : post_id -> report list t
+  | Admin_delete : post_id -> post t
+  | Admin_banish : user_id -> user t
+
+type wrapped = W : 'a t -> wrapped [@@unboxed]
+
+let name : type a. a t -> string = function
+  | Home -> "new-thread"
+  | Register -> "register"
+  | Login -> "login"
+  | Logout -> "logout"
+  | Profile -> "profile"
+  | Account -> "account"
+  | Thread _ -> "post"
+  | Delete _ -> "delete-post"
+  | Report _ -> "report-post"
+  | Admin_ignore _ -> "admin-ignore"
+  | Admin_delete _ -> "admin-delete"
+  | Admin_banish _ -> "admin-banish"
+
+let action : type a. a t -> string = function
+  | Home -> "/"
+  | Register -> "/register"
+  | Login -> "/login"
+  | Logout -> "/logout"
+  | Profile -> "/profile"
+  | Account -> "/account"
+  | Thread id -> Fmt.str "/thread/%d" id
+  | Delete id -> Fmt.str "/delete/%d" id
+  | Report id -> Fmt.str "/report/%d" id
+  | Admin_ignore id -> Fmt.str "/admin/ignore/%d" id
+  | Admin_delete id -> Fmt.str "/admin/delete/%d" id
+  | Admin_banish id -> Fmt.str "/admin/banish/%s" id
+
+let action k = Fmt.str "/api%s" (action k)

src/client/html.ml

@@ -0,0 +1,366 @@
+open Brr
+open Note
+open Note_brr
+open Types
+open Client_types
+open Page
+open Model
+open Util
+open Html_util
+
+module Header = struct
+  let mk t_s =
+    let left = El.div ~at:[ class' "nav-left" ] [ mk_page_link Home ] in
+    let right session =
+      let dropmenu user =
+        let class_prefix = "settings" in
+        let label = user.user_nick in
+        let at_title = "Settings" in
+        let mk_content () =
+          [ mk_page_link Profile
+          ; mk_page_link Account
+          ; Html_form.mk_logout ()
+          ; mk_page_link About
+          ]
+        in
+        mk_dropdown_menu ~class_prefix ~label ~at_title ~placeholder:true
+          mk_content
+      in
+      let l =
+        match Option.map user_private_to_public session.user_private with
+        | None -> List.map mk_page_link [ About; Register; Login ]
+        | Some u when u.user_is_admin ->
+          [ mk_page_link (Admin (Loading ())); dropmenu u ]
+        | Some u -> [ dropmenu u ]
+      in
+      El.div ~at:[ class' "nav-right" ] l
+    in
+    let children = S.map (fun t -> [ left; right t.session ]) t_s in
+    let el = El.nav ~at:[ id "top" ] [] in
+    Elr.def_children el children;
+    el
+
+  let f t_s =
+    let header = El.header [ mk t_s ] in
+    header
+end
+
+module Home = struct
+  let left t_s =
+    let new_thread_view =
+      (* TODO try to find better class names *)
+      let new_thread_form_div =
+        El.div
+          ~at:[ class' "new-thread-form-div" ]
+          [ Html_form.new_thread_el t_s ]
+      in
+      El.div
+        ~at:[ class' "new-thread-view" ]
+        [ h2 "New thread"
+        ; El.span
+            ~at:[ class' "new-thread-info" ]
+            [ el_txt "Click the map and make a new thread:" ]
+        ; new_thread_form_div
+        ]
+    in
+    let thread_view = Html_thread.f t_s in
+    let new_thread_link = Html_thread.new_thread_link_el t_s in
+    let return_link = El.a ~at:[ href (to_path Home) ] [ el_txt "Return" ] in
+    let navigation_div =
+      El.div
+        ~at:[ class' "home-left-navigation-div" ]
+        [ new_thread_link; return_link ]
+    in
+    let mode k = S.map (is_page_kind k) t_s in
+    def_on (mode New_thread) new_thread_view;
+    def_off (mode Thread) navigation_div;
+    def_on (mode Thread) thread_view;
+    def_off (mode New_thread) new_thread_link;
+    def_on (mode New_thread) return_link;
+    let el =
+      El.div
+        ~at:[ class' "home-left" ]
+        [ navigation_div; new_thread_view; thread_view ]
+    in
+    el
+
+  let f t_s =
+    let left_el = left t_s in
+    let right_el = Leaflet_map.f t_s in
+    let el = El.div ~at:[ class' "home-page" ] [ left_el; right_el ] in
+    def_on
+      (S.map
+         (fun t ->
+           is_page_kind Home t || is_page_kind New_thread t
+           || is_page_kind Thread t )
+         t_s )
+      el;
+    el
+end
+
+module About = struct
+  let f t_s =
+    let l = [ h1 "TODO about page" ] in
+    let el = mk_page About t_s l in
+    el
+end
+
+module Register = struct
+  let f t_s =
+    let l = [ h1 "Register"; Html_form.mk_register () ] in
+    let el = mk_page Register t_s l in
+    el
+end
+
+module Login = struct
+  let f t_s =
+    let l = [ h1 "Login"; Html_form.mk_login () ] in
+    let el = mk_page Login t_s l in
+    el
+end
+
+module Admin = struct
+  let mk t_s t =
+    match get_user_admin t with
+    | None -> []
+    | Some _user -> (
+      match t.page with
+      | Home | New_thread | Thread _ | About | Register | Login | Profile
+      | Account | Delete _ | Report _ | User _ ->
+        []
+      | Admin (Loading ()) -> loading_el
+      | Admin (Not_found ()) -> not_found_el
+      | Admin (Ready reports) ->
+        let forms =
+          match reports with
+          | [] ->
+            [ el_txt "Report list is empty!~"
+            ; El.br ()
+            ; el_txt "good job! ( ๑>ᴗ<๑ )"
+            ]
+          | reports ->
+            (* TODO add reported_post_parent_t_id to report type? *)
+            List.map
+              (fun report ->
+                let post = report.reported_post in
+                let post_view = Html_post.post_view t_s post in
+                let span_info_on_report =
+                  let s =
+                    Fmt.str "From: %s, Reason: %s" report.reporter_nick
+                      report.reason
+                  in
+                  El.span [ el_txt s ]
+                in
+                let forms =
+                  El.div
+                    Html_form.
+                      [ admin_ignore post.id
+                      ; admin_delete post.id
+                      ; admin_banish post.poster_id
+                      ]
+                in
+                El.div
+                  ~at:[ class' "report" ]
+                  [ post_view; span_info_on_report; forms ] )
+              reports
+        in
+        let reports_div = El.div ~at:[ class' "reports-div" ] forms in
+        [ h1 "Administration board"; reports_div ] )
+
+  let f t_s =
+    let el = mk_page Admin t_s [] in
+    Elr.def_children el (S.map (mk t_s) t_s);
+    el
+end
+
+module Profile = struct
+  let mk t =
+    match get_user t with
+    | None -> []
+    | Some user ->
+      let public_profile_link =
+        El.p
+          [ el_txt "Check your "
+          ; mk_page_link ~label:"public profile" (User (Loading user.user_id))
+          ]
+      in
+      let forms = Html_form.profile user in
+      [ h1 "Profile settings"; public_profile_link ] @ forms
+
+  let f t_s =
+    let el = mk_page Profile t_s [] in
+    Elr.def_children el (S.map mk t_s);
+    el
+end
+
+module Account = struct
+  let mk t =
+    match get_user_private t with
+    | None -> []
+    | Some user_private ->
+      let forms = Html_form.account user_private in
+      h1 "Account settings" :: forms
+
+  let f t_s =
+    let el = mk_page Account t_s [] in
+    Elr.def_children el (S.map mk t_s);
+    el
+end
+
+module User = struct
+  let mk t =
+    match t.page with
+    | Home | New_thread | Thread _ | About | Register | Login | Admin _
+    | Profile | Account | Delete _ | Report _ ->
+      []
+    | User (Loading _user_id) -> loading_el
+    | User (Not_found _user_id) -> not_found_el
+    | User (Ready user) ->
+      let bio = El.div [ El.blockquote (Html_util.insert_br user.bio) ] in
+      let img =
+        match user.avatar_info with
+        | None -> []
+        | Some info ->
+          let alt_at =
+            if String.equal "" info.alt then []
+            else [ alt info.alt; name info.name; title info.alt ]
+          in
+          let at =
+            [ Fmt.kstr src "/user/%s/avatar" user.user_id
+            ; class' "img-thumbnail"
+            ]
+            @ alt_at
+          in
+          [ El.img ~at () ]
+      in
+      h1 user.user_nick :: bio :: img
+
+  let f t_s =
+    let el = mk_page User t_s [] in
+    Elr.def_children el (S.map mk t_s);
+    el
+end
+
+module Delete = struct
+  let mk t_s t =
+    match get_user t with
+    | None -> []
+    | Some user -> (
+      match t.page with
+      | Home | New_thread | Thread _ | About | Register | Login | Admin _
+      | Profile | Account | Report _ | User _ ->
+        []
+      | Delete (Loading _id) -> loading_el
+      | Delete (Not_found _id) -> not_found_el
+      | Delete (Ready post) -> (
+        match String.equal post.poster_id user.user_id with
+        | false -> (* TODO error can not delete other's posts *) []
+        | true ->
+          let post_view = Html_post.post_view t_s post in
+          let form = Html_form.delete post in
+          [ post_view; form ] ) )
+
+  let f t_s =
+    let el = mk_page Delete t_s [] in
+    Elr.def_children el (S.map (mk t_s) t_s);
+    el
+end
+
+module Report = struct
+  let mk t_s t =
+    match get_user t with
+    | None -> []
+    | Some _user -> (
+      match t.page with
+      | Home | New_thread | Thread _ | About | Register | Login | Admin _
+      | Profile | Account | Delete _ | User _ ->
+        []
+      | Report (Loading _id) -> loading_el
+      | Report (Not_found _id) -> not_found_el
+      | Report (Ready post) ->
+        let post_view = Html_post.post_view t_s post in
+        let form = Html_form.report post in
+        [ post_view; form ] )
+
+  let f t_s =
+    let el = mk_page Report t_s [] in
+    Elr.def_children el (S.map (mk t_s) t_s);
+    el
+end
+
+module Error_popup = struct
+  let mk container_el opt =
+    match opt with
+    | None -> []
+    | Some error ->
+      let dragzone =
+        let close_btn =
+          El.button ~at:[ class' "close-error-popup-btn" ] [ el_txt "X" ]
+        in
+        hold_on close_btn Ev.click (fun _ev -> Events.send_action Clear_error);
+        El.div ~at:[ class' "error-popup-dragzone" ] [ close_btn ]
+      in
+      Html_form.Dragzone.f ~dragzone container_el;
+      let content =
+        El.div
+          ~at:[ class' "error-popup-content" ]
+          [ El.span [ el_txt (Fmt.str "%a" Client_types.pp_error error) ] ]
+      in
+      [ dragzone; content ]
+
+  let f t_s =
+    let el = El.div ~at:[ class' "error-popup" ] [] in
+    Elr.def_children el (S.map (fun t -> mk el t.error) t_s);
+    def_off (S.map (fun t -> Option.is_none t.error) t_s) el;
+    el
+end
+
+module Main = struct
+  let f t_s =
+    let l =
+      List.map
+        (fun f -> f t_s)
+        [ Home.f
+        ; About.f
+        ; Register.f
+        ; Login.f
+        ; Admin.f
+        ; Profile.f
+        ; Account.f
+        ; User.f
+        ; Delete.f
+        ; Report.f
+        ; Error_popup.f
+        ]
+    in
+    let main = El.v (str "main") l in
+    main
+end
+
+let def_page_title t_s =
+  let set_title page =
+    let s =
+      match page with
+      | Thread (Loading _) | User (Loading _) -> "loading"
+      | Thread (Not_found _) | User (Not_found _) -> "not found"
+      | Thread (Ready v) -> v.subject
+      | User (Ready u) -> u.user_nick
+      | page -> (
+        match to_kind page with
+        | New_thread -> "new thread"
+        | kind -> Kind.to_string kind )
+    in
+    Fmt.str "%s | Permap" s |> String.capitalize_ascii |> Jstr.v
+    |> Document.set_title G.document
+  in
+  S.map (fun t -> t.page) t_s |> S.changes |> hold_endless set_title;
+  (* init *)
+  let k = (S.value t_s).page in
+  set_title k;
+  ()
+
+let f t_s =
+  let header_el = Header.f t_s in
+  let main_el = Main.f t_s in
+  def_page_title t_s;
+  [ header_el; main_el ]

src/client/html_form.ml

@@ -0,0 +1,391 @@
+open Brr
+open Note
+open Note_brr
+open Types
+open Client_types
+open Util
+
+let handle_submit kind form ev =
+  Fmt.pr "catched form submit event@.";
+  Ev.prevent_default ev;
+  Events.send_action (Submit_event (W kind, form));
+  ()
+
+let mk kind ~btn l =
+  let class_prefix = Form_kind.name kind in
+  let action = Form_kind.action kind in
+  let at =
+    [ Fmt.kstr class' "%s-form " class_prefix
+    ; At.action (str action)
+    ; At.method' (str "POST")
+    ; mk_at "enctype" "multipart/form-data"
+    ]
+  in
+  let content = l @ [ El.div [ btn ] ] in
+  let form = El.form ~at content in
+  hold_on form Brr_io.Form.Ev.submit (fun ev -> handle_submit kind form ev);
+  form
+
+(* -- TODO clean up this mess -- *)
+
+let mk_field_unwraped kind ~name ~label ~at =
+  let type' =
+    type'
+    @@
+    match kind with
+    | `Text | `Textarea _ -> "text"
+    | `Password -> "password"
+    | `File -> "file"
+  in
+  let label =
+    El.label
+      ~at:
+        [ At.for' (str name); Fmt.kstr id "%s-label" name; class' "form-label" ]
+      [ el_txt label ]
+  in
+  let at =
+    [ type'
+    ; id name
+    ; At.name (str name)
+    ; class' "form-label"
+    ; Fmt.kstr (mk_at "aria-labelledby") "%s-label" name
+    ]
+    @ at
+  in
+  let item =
+    match kind with
+    | `Text | `File | `Password -> El.input ~at ()
+    | `Textarea content -> El.textarea ~at [ el_txt content ]
+  in
+  (label, item)
+
+let mk_field kind ~name ~label ~at =
+  let label, item = mk_field_unwraped kind ~name ~label ~at in
+  El.div [ label; item ]
+
+let mk_btn ?(at = []) s =
+  let at = [ type' "submit"; class' "submit-btn" ] @ at in
+  El.button ~at [ el_txt s ]
+
+let mk_btn_save () = mk_btn "Save"
+
+let mk_btn_submit () = mk_btn "Submit"
+
+let mk_logout () =
+  let btn =
+    let label = "❌ Logout" in
+    let btn_class = "logount-btn" in
+    El.button ~at:[ class' btn_class ] [ el_txt label ]
+  in
+  mk Logout ~btn []
+
+let mk_register () =
+  let nick = mk_field `Text ~name:"nick" ~label:"Nickname" ~at:[] in
+  let email = mk_field `Text ~name:"email" ~label:"Email" ~at:[] in
+  let password = mk_field `Password ~name:"password" ~label:"Password" ~at:[] in
+  let btn = mk_btn_submit () in
+  mk Register ~btn [ nick; email; password ]
+
+let mk_login () =
+  let nick = mk_field `Text ~name:"login" ~label:"Nickname or email" ~at:[] in
+  let password = mk_field `Password ~name:"password" ~label:"Password" ~at:[] in
+  let btn = mk_btn_submit () in
+  mk Login ~btn [ nick; password ]
+
+let mk_subject_field_unwraped () =
+  mk_field_unwraped `Text ~name:"subject" ~label:"Subject" ~at:[]
+
+let mk_comment_field_unwraped s =
+  mk_field_unwraped (`Textarea s) ~name:"comment" ~label:"Comment" ~at:[]
+
+let mk_image_field_unwraped () =
+  let file_label, file =
+    mk_field_unwraped `File ~name:"file" ~label:"Add picture"
+      ~at:
+        [ mk_at "accept"
+            (String.concat "," (Array.to_list Config.supported_mime_type))
+        ]
+  in
+  let alt =
+    El.div
+      ~at:[ class' "alt-image-input-div" ]
+      [ mk_field (`Textarea "") ~name:"alt" ~label:"Image desciption" ~at:[] ]
+  in
+  ((file_label, file), alt)
+
+let mk_image_field () =
+  let (file_label, file), alt = mk_image_field_unwraped () in
+  let file_div = El.div [ file_label; file ] in
+  El.div ~at:[ class' "image-input-div" ] [ file_div; alt ]
+
+(* -------- *)
+
+let sync_field input ~on form_action =
+  hold_on input Ev.input (fun _ev ->
+      let s = El.prop El.Prop.value input |> Jstr.to_string in
+      Events.send_action (Post_form_change (form_action s)) );
+  Elr.set_prop El.Prop.value ~on input;
+  ()
+
+let mk_comment_div t_s =
+  let open Model in
+  let label, textarea = mk_comment_field_unwraped "" in
+  let () =
+    let on = S.map (fun t -> t.post_form.comment |> Jstr.v) t_s |> S.changes in
+    let send s = Client_types.Form_comment s in
+    sync_field textarea ~on send
+  in
+  let focus_e =
+    S.map
+      (fun t ->
+        (* take reply_form here and not reply_form.is_open
+             so focus turn on when textarea content changes (quote insertion) *)
+        t.post_form )
+      t_s
+    |> S.changes
+    |> E.filter_map (fun rf ->
+           match rf.Post_form_data.is_open with
+           | false -> None
+           | true -> Some true )
+  in
+  Elr.set_has_focus ~on:focus_e textarea;
+  El.div ~at:[ class' "comment-input-div" ] [ label; textarea ]
+
+let mk_image_div t_s =
+  let open Model in
+  let (file_label, file), alt = mk_image_field_unwraped () in
+  let () =
+    let has_file = S.map (fun t -> Option.is_some t.post_form.file) t_s in
+    Util.def_on has_file alt;
+    let on =
+      S.map (fun t -> t.post_form.alt) t_s
+      |> S.changes |> E.filter_map Fun.id |> E.map Jstr.v
+    in
+    let send s =
+      let opt = if String.equal s "" then None else Some s in
+      Client_types.Form_alt opt
+    in
+    sync_field alt ~on send
+  in
+  hold_on file Ev.change (fun _ev ->
+      let opt =
+        match El.Input.files file with
+        | [] -> None
+        | file :: _l ->
+          let s = File.name file |> Jstr.to_string in
+          Some s
+      in
+      Events.send_action (Post_form_change (Form_file opt)) );
+  (* clear image file name if needed *)
+  let on =
+    S.map
+      (fun t ->
+        match t.post_form.file with
+        | None -> Some (Jv.to_jstr Jv.null)
+        | Some _s -> None )
+      t_s
+    |> S.changes |> E.filter_map Fun.id
+  in
+  Elr.set_prop El.Prop.value ~on file;
+  let file_div = El.div [ file_label; file ] in
+  El.div ~at:[ class' "image-input-div" ] [ file_div; alt ]
+
+let new_thread_el t_s =
+  let open Model in
+  let subject =
+    let label, input = mk_subject_field_unwraped () in
+    let () =
+      let on =
+        S.map (fun t -> t.post_form.subject |> Jstr.v) t_s |> S.changes
+      in
+      let send s = Client_types.Form_subject s in
+      sync_field input ~on send
+    in
+    El.div ~at:[ class' "subject-input-div" ] [ label; input ]
+  in
+  let comment = mk_comment_div t_s in
+  let image = mk_image_div t_s in
+  let lat =
+    El.input ~at:[ type' "hidden"; id "lat-input"; name "lat-input" ] ()
+  in
+  let lng =
+    El.input ~at:[ type' "hidden"; id "lng-input"; name "lng-input" ] ()
+  in
+  let latlng_s = S.map (fun t -> t.post_form.latlng) t_s in
+  Elr.def_at At.Name.value
+    (latlng_s |> S.map (Option.map fst) |> S.map (Option.map Jstr.of_float))
+    lat;
+  Elr.def_at At.Name.value
+    (latlng_s |> S.map (Option.map snd) |> S.map (Option.map Jstr.of_float))
+    lng;
+  let btn =
+    let at = [ class' "submit-post-btn" ] in
+    mk_btn ~at "Post"
+  in
+  Util.def_disabled (S.map Option.is_none latlng_s) btn;
+  mk Home ~btn [ subject; comment; image; lat; lng ]
+
+let profile user =
+  let mk = mk Profile in
+  let nickname =
+    let nick =
+      mk_field `Text ~name:"nick" ~label:"Change nickname"
+        ~at:[ value user.user_nick ]
+    in
+    let btn = mk_btn_save () in
+    let form = mk ~btn [ nick ] in
+    [ h2 "Nickname"; form ]
+  in
+  let bio =
+    let bio =
+      mk_field (`Textarea user.bio) ~name:"bio" ~label:"Change your biography"
+        ~at:[]
+    in
+    let btn = mk_btn_save () in
+    let form = mk ~btn [ bio ] in
+    [ h2 "Biography"; form ]
+  in
+  let avatar =
+    (* TODO
+       - small preview off current avatar on the left of delete avatar button
+       - preview of image to be uploaded
+       - add image preview in new-thread/reply form too*)
+    let delete =
+      user.avatar_info
+      |> Option.map (fun _ ->
+             let input_el =
+               El.input
+                 ~at:[ type' "hidden"; name "delete-avatar"; value "" ]
+                 ()
+             in
+             let btn = mk_btn "delete current avatar" in
+             mk ~btn [ input_el ] )
+      |> Option.to_list
+    in
+    let upload =
+      let file_el =
+        mk_field `File ~name:"file" ~label:"Change your avatar"
+          ~at:
+            [ mk_at "accept"
+                (String.concat "," (Array.to_list Config.supported_mime_type))
+            ]
+      in
+      (* TODO disable alt field if no image; do the same for post form *)
+      let alt_el =
+        let content =
+          Option.fold ~none:"" ~some:(fun img -> img.alt) user.avatar_info
+        in
+        mk_field (`Textarea content) ~name:"alt" ~label:"Image desciption"
+          ~at:[]
+      in
+      let btn = mk_btn_save () in
+      [ mk ~btn [ file_el; alt_el ] ]
+    in
+    (h2 "Avatar" :: delete) @ upload
+  in
+  nickname @ bio @ avatar
+
+let account user_private =
+  let mk = mk Account in
+  let email =
+    let email =
+      mk_field `Text ~name:"email" ~label:"Email"
+        ~at:[ value user_private.User_private.email ]
+    in
+    let btn = mk_btn_save () in
+    let form = mk ~btn [ email ] in
+    [ h2 "Change email"; form ]
+  in
+  let password =
+    let pw1 =
+      mk_field `Password ~name:"new-password" ~label:"New password" ~at:[]
+    in
+    let pw2 =
+      mk_field `Password ~name:"confirm-new-password"
+        ~label:"Confirm new password" ~at:[]
+    in
+    let btn = mk_btn_save () in
+    let form = mk ~btn [ pw1; pw2 ] in
+    [ h2 "Change password"; form ]
+  in
+  let big_delete =
+    let btn = mk_btn ~at:[ class' "delete-account-btn" ] "DELETE ACCOUNT" in
+    let form =
+      mk ~btn
+        [ El.input ~at:[ type' "hidden"; name "delete-account"; value "" ] () ]
+    in
+    [ h2 "Delete account"; form ]
+  in
+  email @ password @ big_delete
+
+let delete post =
+  let btn = mk_btn "DELETE" in
+  mk (Delete post.id) ~btn []
+
+let report post =
+  let btn = mk_btn "Report" in
+  let reason = mk_field `Text ~name:"reason" ~label:"Reason" ~at:[] in
+  mk (Report post.id) ~btn [ reason ]
+
+let admin_ignore post_id =
+  let btn = mk_btn "ignore" in
+  mk (Admin_ignore post_id) ~btn []
+
+let admin_delete post_id =
+  let btn = mk_btn "DELETE" in
+  mk (Admin_delete post_id) ~btn []
+
+let admin_banish user_id =
+  let btn = mk_btn "BANISH" in
+  mk (Admin_banish user_id) ~btn []
+
+module Dragzone = struct
+  (* TODO
+     - send drag_state to model on dragend (mouseup)
+       need to differentiate which popup we are dragging for this *)
+  let drag_state = ref None
+
+  let on_mousedown dragzone container ev =
+    match !drag_state with
+    | Some _ -> Fmt.failwith "Dragzone state error: double mousedown?"
+    | None ->
+      let evt = Ev.as_type ev in
+      let offset_x = El.bound_x container -. Ev.Mouse.client_x evt in
+      let offset_y = El.bound_y container -. Ev.Mouse.client_y evt in
+      drag_state := Some (dragzone, container, offset_x, offset_y);
+      (* css so nothing get highlighted *)
+      El.set_inline_style (Jstr.v "user-select") (Jstr.v "none") body;
+      El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "none") body;
+      El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "auto") dragzone
+
+  let on_mousemove ev =
+    match !drag_state with
+    | None -> ()
+    | Some (_dragzone, container, offset_x, offset_y) ->
+      let evt = Ev.as_type ev in
+      let x = Ev.Mouse.client_x evt +. offset_x in
+      let y = Ev.Mouse.client_y evt +. offset_y in
+      let x = clamp ~min:0. ~max:(window_width () -. El.bound_w container) x in
+      let y = clamp ~min:0. ~max:(window_height () -. El.bound_h container) y in
+      El.set_inline_style El.Style.position (Jstr.v "fixed") container;
+      El.set_inline_style El.Style.left (Fmt.kstr Jstr.v "%fpx" x) container;
+      El.set_inline_style El.Style.top (Fmt.kstr Jstr.v "%fpx" y) container
+
+  let on_mouseup _ev =
+    match !drag_state with
+    | None -> ()
+    | Some (dragzone, _container, _, _) ->
+      El.set_inline_style (Jstr.v "user-select") (Jstr.v "") body;
+      El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "") body;
+      El.set_inline_style (Jstr.v "pointer-events") (Jstr.v "") dragzone;
+      drag_state := None
+
+  let () =
+    hold_endless_on_window Ev.mousemove on_mousemove;
+    hold_endless_on_window Ev.mouseup on_mouseup;
+    ()
+
+  let f ~dragzone container =
+    hold_on dragzone Ev.mousedown (fun ev -> on_mousedown dragzone container ev);
+    ()
+end

src/client/html_post.ml

@@ -0,0 +1,335 @@
+open Brr
+open Note
+open Note_brr
+open Types
+open Client_types
+open Util
+
+let nick post =
+  El.a
+    ~at:
+      [ class' "user-link"
+      ; class' "post-author-nick"
+      ; mk_at "data-user-id" post.poster_id
+      ; Fmt.kstr href "/user/%s" post.poster_id
+      ]
+    [ el_txt post.poster_nick ]
+
+let date post =
+  let print_date t =
+    let t = Unix.localtime t in
+    Fmt.str "%02d-%02d-%02d %02d:%02d" (1900 + t.tm_year) (1 + t.tm_mon)
+      t.tm_mday t.tm_hour t.tm_min
+  in
+  El.span
+    ~at:[ class' "post-date"; mk_at "data-time" (string_of_float post.date) ]
+    [ el_txt (print_date post.date) ]
+
+(* TODO rm this since we can click the post_id? *)
+let link_to_post ?(is_vignette = false) post =
+  let url =
+    if is_vignette then Fmt.str "/thread/%d#%d" post.parent_t_id post.id
+    else Fmt.str "#%d" post.id
+  in
+  El.a
+    ~at:[ href url; title "Link to this post"; class' "post-link-to-self" ]
+    [ el_txt "#" ]
+
+let post_id post =
+  let el =
+    let at =
+      [ class' "post-id"
+      ; title "Reply to this post"
+      ; mk_at "data-id" (string_of_int post.id)
+      ; Fmt.kstr href "#%d" post.id
+      ]
+    in
+    El.a ~at [ el_txt (Fmt.str ">>%d" post.id) ]
+  in
+  hold_on el Ev.click (fun _ev ->
+      Events.send_action (Post_form_change Form_open);
+      Events.send_action (Post_form_change (Form_insert_quote post.id)) );
+  el
+
+let post_id_quote =
+  let is_local_link t_s id =
+    (* list of post currently on the page
+       (consider thread page case only) *)
+    let post_l =
+      match (S.value t_s).Model.page with
+      | Thread (Ready v) -> v.reply_l
+      | _ -> []
+    in
+    List.find_opt (fun p -> p.id = id) post_l |> Option.is_some
+  in
+  let hold_highlight_event el id =
+    let mouseenter = Evr.on_el Ev.mouseenter Evr.unit el in
+    let mouseleave = Evr.on_el Ev.mouseleave Evr.unit el in
+    let focus = Evr.on_el Ev.focus Evr.unit el in
+    let blur = Evr.on_el Ev.blur Evr.unit el in
+    let off = E.select [ mouseleave; blur ] |> E.map (fun () -> None) in
+    let on =
+      E.select [ mouseenter; focus ]
+      |> E.map (fun () -> Some (get_bounds el, id))
+    in
+    let event = E.select [ off; on ] in
+    hold_event_on el event (fun opt ->
+        Events.send_action (Quickview_change opt) );
+    ()
+  in
+  fun t_s id ->
+    let at = [ class' "post-id-quote"; mk_at "data-id" (string_of_int id) ] in
+    let txt = el_txt (Fmt.str ">>%d" id) in
+    match is_local_link t_s id with
+    | true ->
+      (* simple #%d link *)
+      let at = [ Fmt.kstr href "#%d" id ] @ at in
+      let el = El.a ~at [ txt ] in
+      hold_highlight_event el id;
+      el
+    | false ->
+      (* remote link *)
+      let at = [ class' "remote" ] @ at in
+      let container = El.span [] in
+      hold_highlight_event container id;
+      let children =
+        let open Page in
+        S.map (fun t -> t.Model.quickview) t_s
+        |> S.changes |> E.filter_map Fun.id
+        |> E.map (fun (rect, v) ->
+               let quickview_id = unwrap_post_id v in
+               fun last_value ->
+                 match quickview_id = id with
+                 | true -> Some (rect, v)
+                 | false -> last_value )
+        |> S.accum None
+        |> S.map (function
+             | None -> [ El.button ~at [ txt ] ]
+             | Some (_rect, v) -> (
+               match v with
+               | Loading _ ->
+                 let at = [ class' "loading" ] @ at in
+                 [ El.button ~at [ txt ] ]
+               | Not_found _ ->
+                 let at = [ class' "not-found" ] @ at in
+                 [ El.button ~at [ txt ] ]
+               | Ready p ->
+                 let at =
+                   [ class' "ready"
+                   ; Fmt.kstr href "/thread/%d#%d" p.parent_t_id p.id
+                   ]
+                   @ at
+                 in
+                 [ El.a ~at [ txt ] ] ) )
+      in
+      Elr.def_children container children;
+      container
+
+let post_menu t_s post =
+  let mk s =
+    El.a
+      ~at:
+        [ Fmt.kstr href "/%s/%d" s post.id
+        ; Fmt.kstr class' "%s-link" s
+        ; mk_at "data-post-id" (string_of_int post.id)
+        ]
+      [ el_txt (String.capitalize_ascii s) ]
+  in
+  let mk_content () =
+    let delete = mk "delete" in
+    let report = mk "report" in
+    let own_post =
+      S.map Model.get_user t_s
+      |> S.map (function
+           | None -> false
+           | Some u -> String.equal u.user_id post.poster_id )
+    in
+    def_on own_post delete;
+    [ delete; report ]
+  in
+  Html_util.mk_dropdown_menu ~class_prefix:"post-info" ~label:""
+    ~at_title:"Post menu" ~placeholder:false mk_content
+
+let backlinks t_s post =
+  let l = List.map (post_id_quote t_s) post.backlinks in
+  El.div ~at:[ class' "post-replies" ] l
+
+let image t_s ?(is_vignette = false) post =
+  match post.image_info with
+  | None -> None
+  | Some image -> (
+    (* TODO show image dimension/name *)
+    let mk is_small =
+      let class_small =
+        if is_small then [ class' "post-image-small" ] else []
+      in
+      let sizes =
+        [ mk_at "width"
+            (string_of_int (if is_small then image.thumb_w else image.w))
+        ; mk_at "height"
+            (string_of_int (if is_small then image.thumb_h else image.h))
+        ]
+      in
+      let url =
+        src
+        @@
+        if is_small then Fmt.str "/img/s/%d" post.id
+        else Fmt.str "/img/%d" post.id
+      in
+      let at =
+        class_small @ sizes
+        @ url
+          :: [ class' "post-image"
+             ; alt image.alt
+             ; title image.alt
+             ; mk_at "data-id" (string_of_int post.id)
+             ; mk_at "loading" "lazy"
+             ]
+      in
+      El.img ~at ()
+    in
+    let img_small, img_big = (mk true, mk false) in
+    let el = El.div ~at:[ class' "post-image-div" ] [ img_small ] in
+    match is_vignette with
+    | true -> Some el
+    | false ->
+      (* swap img_(small/big) on click *)
+      hold_on el Ev.click (fun _ev -> Events.send_action (Image_click post.id));
+      let img_s =
+        S.map (fun t -> t.Model.opened_image) t_s
+        |> S.map (function
+             | Some id when Int.equal id post.id -> [ img_big ]
+             | Some _ | None -> [ img_small ] )
+      in
+      Elr.def_children el img_s;
+      Some el )
+
+let comment =
+  let open Comment in
+  let insert_br_between_lines l =
+    match l with
+    | [] -> []
+    | hd :: tl ->
+      List.rev
+      @@ List.fold_left (fun acc x -> x :: [ El.br () ] :: acc) [ hd ] tl
+  in
+  let item t_s = function Txt s -> el_txt s | Id i -> post_id_quote t_s i in
+  let items t_s l = List.map (item t_s) l in
+  let line t_s = function
+    | Line l -> items t_s l
+    | Line_quote l ->
+      [ El.span ~at:[ class' "line-quote" ] (el_txt ">" :: items t_s l) ]
+  in
+  fun t_s comment ->
+    let content =
+      List.map (line t_s) comment |> insert_br_between_lines |> List.flatten
+    in
+    El.div ~at:[ class' "post-comment" ] content
+
+let info t_s post =
+  El.div
+    ~at:[ class' "post-info" ]
+    [ nick post
+    ; date post
+    ; post_id post
+    ; link_to_post post
+    ; post_menu t_s post
+    ; backlinks t_s post
+    ]
+
+let post_view t_s post =
+  let info = info t_s post in
+  let content =
+    let comment = comment t_s post.comment in
+    let l =
+      match image t_s post with
+      | None -> [ comment ]
+      | Some image -> [ image; comment ]
+    in
+    El.div ~at:[ class' "post-content" ] l
+  in
+  let at = [ class' "post"; id (string_of_int post.id) ] in
+  let el = El.div ~at [ info; content ] in
+  let is_selected =
+    S.map
+      (fun t ->
+        match t.Model.fragment with
+        | Id v ->
+          let id = Fragment.unwrap_id v in
+          post.id = id
+        | Empty | Top | Bottom -> false )
+      t_s
+  in
+  Elr.def_class (Jstr.v "selected") is_selected el;
+  let is_highlighted =
+    S.map (fun t -> t.Model.quickview) t_s
+    |> S.map (function
+         | None -> false
+         | Some (_rect, v) -> Int.equal post.id (Page.unwrap_post_id v) )
+  in
+  Elr.def_class (Jstr.v "highlighted") is_highlighted el;
+  el
+
+module Quickview = struct
+  open Model
+
+  let quickview_class = "quickview-div"
+
+  let to_px_jstr x = x |> int_of_float |> Fmt.str "%dpx" |> Jstr.of_string
+
+  let is_in_viewport post =
+    (* find highlighted post DOM element *)
+    let id = string_of_int post.id in
+    match find_html_el_by_id id with
+    | None -> false
+    | Some el ->
+      (* check bounds *)
+      let x, y, w, h = get_bounds el in
+      let ( <= ) x y = Float.compare x y <= 0 in
+      0. <= x && 0. <= y
+      && x +. w <= window_width ()
+      && y +. h <= window_height ()
+
+  let f t_s =
+    let container = El.div ~at:[ class' quickview_class ] [] in
+    let mk (id_x, id_y, id_w, id_h) post =
+      if is_in_viewport post then []
+      else
+        let quickview = post_view t_s post in
+        (* ensure we don't have duplicate html id attribute *)
+        El.set_at At.Name.id (Some (Jstr.v "quickview")) quickview;
+        (* hack: insert hidden quickview into DOM so we can compute it's bounds
+           we don't use the viewed post's already in DOM element for this
+             - it might actually not be in DOM
+             - it might have it's image opened and size changed *)
+        El.set_inline_style El.Style.visibility (Jstr.v "hidden") quickview;
+        El.set_children container [ quickview ];
+        (* compute quickview position *)
+        let quickview_x = id_x +. id_w in
+        let quickview_h = El.bound_h quickview in
+        let quickview_y = id_y +. (0.5 *. id_h) -. (0.5 *. quickview_h) in
+        let quickview_y =
+          clamp ~min:0. ~max:(window_height () -. quickview_h) quickview_y
+        in
+        (* undo quickview DOM insertion *)
+        El.set_inline_style El.Style.visibility (Jstr.v "visible") quickview;
+        El.remove quickview;
+        (* set quickview style *)
+        El.set_inline_style El.Style.position (Jstr.v "fixed") quickview;
+        El.set_inline_style El.Style.z_index (Jstr.v "99999") quickview;
+        El.set_inline_style El.Style.left (to_px_jstr quickview_x) quickview;
+        El.set_inline_style El.Style.top (to_px_jstr quickview_y) quickview;
+        [ quickview ]
+    in
+    let children =
+      S.map (fun t -> t.quickview) t_s
+      |> S.map (function
+           | None -> []
+           | Some (rect, v) -> (
+             match v with
+             | Page.Loading _ | Not_found _ -> []
+             | Ready post -> mk rect post ) )
+    in
+    Elr.def_children container children;
+    container
+end

src/client/html_thread.ml

@@ -0,0 +1,156 @@
+open Brr
+open Note
+open Note_brr
+open Types
+open Page
+open Model
+open Util
+open Html_util
+
+let thread_el_aux t_s w =
+  match w with
+  | Loading _id -> loading_el
+  | Not_found _id -> not_found_el
+  | Ready (v : Thread_w_reply.t) ->
+    let subject =
+      El.div ~at:[ class' "thread-subject" ] [ El.strong [ el_txt v.subject ] ]
+    in
+    let reply_l =
+      let l =
+        List.sort (fun a b -> Float.compare a.date b.date) v.reply_l
+        |> List.map (fun p -> Html_post.post_view t_s p)
+      in
+      El.div ~at:[ class' "thread-replies" ] l
+    in
+    [ subject; reply_l ]
+
+let thread_el t_s w =
+  let id = Jstr.of_int (unwrap_thread_id w) in
+  let el =
+    El.div
+      ~at:[ class' "thread"; At.v (str "data-id") id ]
+      (thread_el_aux t_s w)
+  in
+  el
+
+let reply_popup_el t_s w =
+  let dragzone =
+    let close_btn =
+      El.button ~at:[ class' "close-reply-popup-btn" ] [ el_txt "X" ]
+    in
+    hold_on close_btn Ev.click (fun _ev ->
+        Events.send_action (Post_form_change Form_close) );
+    El.div ~at:[ class' "reply-popup-dragzone" ] [ close_btn ]
+  in
+  let content =
+    let open Html_form in
+    let comment = mk_comment_div t_s in
+    let image = mk_image_div t_s in
+    let btn = mk_btn "Post" in
+    let form = mk (Thread (unwrap_thread_id w)) ~btn [ comment; image ] in
+    let el = El.div ~at:[ class' "reply-popup-content" ] [ form ] in
+    el
+  in
+  let el = El.div ~at:[ class' "reply-popup" ] [ dragzone; content ] in
+  Html_form.Dragzone.f ~dragzone el;
+  let is_visible_s = S.map (fun t -> t.post_form.is_open) t_s in
+  def_on is_visible_s el;
+  el
+
+let new_thread_link_el t_s =
+  let mk user =
+    match user with
+    | None ->
+      (* TODO redirect *)
+      mk_page_link ~label:"Login to post a thread!" Login
+    | Some _user ->
+      El.a ~at:[ href (Page.to_path New_thread) ] [ el_txt "New thread" ]
+  in
+  let el = El.div ~at:[ class' "new-thread-link-div" ] [] in
+  let children = S.map get_user t_s |> S.map (fun u -> [ mk u ]) in
+  Elr.def_children el children;
+  el
+
+let bump_status_el v =
+  el_txt
+  @@
+  match v with
+  | Types.Dead -> "Dead thread"
+  | Locked c ->
+    Fmt.str "bump order: [%d/%d]\nLocked thread, You cannot reply anymore." c
+      Config.thread_alive_max_count
+  | Alive c -> Fmt.str "bump order: [%d/%d]" c Config.thread_alive_max_count
+
+let reply_btn_el t_s w =
+  let mk user =
+    match w with
+    | Loading _ | Not_found _ -> []
+    | Ready (v : Thread_w_reply.t) ->
+      let el =
+        match user with
+        | None ->
+          (* TODO redirect *)
+          mk_page_link ~label:"Login to reply!" Login
+        | Some _user -> (
+          match v.bump_status with
+          | Dead | Locked _ -> bump_status_el v.bump_status
+          | Alive _bump_order ->
+            let btn =
+              let at = [ class' "open-reply-popup-btn" ] in
+              El.button ~at [ el_txt "Post a reply" ]
+            in
+            let is_hidden = S.map (fun t -> t.post_form.is_open) t_s in
+            Elr.def_class (Jstr.v "hidden") is_hidden btn;
+            hold_on btn Ev.click (fun _ev ->
+                Events.send_action (Post_form_change Form_open) );
+            btn )
+      in
+      [ el ]
+  in
+  let el = El.div ~at:[ class' "reply-popup-btn-div" ] [] in
+  let children = S.map get_user t_s |> S.map mk in
+  Elr.def_children el children;
+  el
+
+(* need t_s for user + reply form open/close state *)
+let nav_el kind t_s w =
+  let str = match kind with `Top -> "top" | `Bottom -> "bottom" in
+  let str_inv = match kind with `Top -> "bottom" | `Bottom -> "top" in
+  let update_el =
+    El.a ~at:[ href (Page.to_path (Thread w)) ] [ el_txt "Update" ]
+  in
+  let at =
+    match kind with
+    | `Top ->
+      (* id="top" is set on nav bar instead *)
+      [ class' "sub-nav" ]
+    | `Bottom -> [ class' "sub-nav"; id str ]
+  in
+  let el =
+    El.div ~at
+      [ new_thread_link_el t_s
+      ; reply_btn_el t_s w
+      ; update_el
+      ; El.a
+          ~at:[ Fmt.kstr href "#%s" str_inv ]
+          [ Fmt.kstr el_txt "Go to %s" str_inv ]
+      ]
+  in
+  el
+
+let mk t_s w =
+  [ nav_el `Top t_s w
+  ; thread_el t_s w
+  ; reply_popup_el t_s w
+  ; Html_post.Quickview.f t_s
+  ; nav_el `Bottom t_s w
+  ]
+
+let f t_s =
+  let el = El.div ~at:[ class' "thread-view" ] [] in
+  let children_s =
+    S.map get_thread_w_reply t_s
+    |> S.map (function None -> [] | Some w -> mk t_s w)
+  in
+  Elr.def_children el children_s;
+  el

src/client/html_util.ml

@@ -0,0 +1,80 @@
+open Brr
+open Note
+open Model
+open Util
+
+let loading_el = [ el_txt "ฅ^•ﻌ•^ฅ loading" ]
+
+let not_found_el = [ el_txt "ฅ^•ﻌ•^ฅ not found" ]
+
+let mk_page_link ?label p =
+  let open Page in
+  let href = href (to_path p) in
+  let k = to_kind p in
+  let s = Kind.to_string k in
+  let label =
+    match label with
+    | Some label -> label
+    | None -> (
+      match Kind.to_emoji k with
+      | None -> s
+      | Some emoji -> Fmt.str "%s %s" emoji s )
+  in
+  El.a ~at:[ Fmt.kstr class' "%s-link" s; href ] [ el_txt label ]
+
+let is_page_kind k t = Page.(Kind.equal k (to_kind t.page))
+
+let mk_page kind t_s l =
+  let el =
+    let at = [ Fmt.kstr class' "%s-page" (Page.Kind.to_string kind) ] in
+    El.div ~at l
+  in
+  let is_on = S.map (is_page_kind kind) t_s in
+  def_on is_on el;
+  el
+
+let insert_br s =
+  match String.split_on_char '\n' s with
+  | [] -> []
+  | hd :: tl ->
+    List.rev
+    @@ List.fold_left
+         (fun acc x -> el_txt x :: El.br () :: acc)
+         [ el_txt hd ]
+         tl
+
+(* glorious CSS dropdown menu
+   - need to take mk_content and not just content because El.t are only added one time in DOM
+     -> or clone content
+   - need placeholder for correct style *)
+let mk_dropdown_menu ~class_prefix ~label ~at_title ~placeholder mk_content =
+  let mk_btn suffix =
+    let at =
+      [ Fmt.kstr class' "%s-dropdown%s" class_prefix suffix
+      ; Fmt.kstr class' "dropdown%s" suffix
+      ]
+    in
+    let arrow = El.span ~at:[ class' "dropdown-arrow" ] [ el_txt "▶" ] in
+    El.button ~at [ arrow; el_txt label ]
+  in
+  let mk_dropdown_content suffix =
+    let at =
+      [ Fmt.kstr class' "%s-dropdown-content%s" class_prefix suffix
+      ; Fmt.kstr class' "dropdown-content%s" suffix
+      ]
+    in
+    let l = mk_content () |> List.map (fun o -> El.li [ o ]) in
+    El.ul ~at l
+  in
+  let at =
+    [ Fmt.kstr class' "%s-dropdown" class_prefix
+    ; class' "dropdown"
+    ; At.title (str at_title)
+    ]
+  in
+  let l =
+    mk_btn "-open-btn"
+    :: (if placeholder then [ mk_dropdown_content "-placeholder" ] else [])
+    @ [ mk_dropdown_content ""; mk_btn "-close-btn" ]
+  in
+  El.div ~at l

src/client/leaflet_map.ml

@@ -0,0 +1,199 @@
+open Brr
+open Note
+open Leaflet
+open Util
+
+let geoloc_btn =
+  let s = "geolocalize-btn" in
+  El.button ~at:[ class' s; id s ] [ el_txt "Geolocalize me" ]
+
+let buttons =
+  let new_thread_link =
+    El.a ~at:[ href (Page.to_path New_thread) ] [ el_txt "New thread" ]
+  in
+  El.div ~at:[ class' "map-btn-div" ] [ new_thread_link; geoloc_btn ]
+
+let map_el = El.div ~at:[ id "map" ] []
+
+let map = Map.create_from_div map_el
+
+let set_view (lat, lng, zoom) =
+  let latlng = Latlng.create ~lat ~lng in
+  let zoom = Some zoom in
+  Map.set_view latlng ~zoom map;
+  ()
+
+let get_view () =
+  let latlng = Map.get_center map in
+  let lat = Latlng.lat latlng in
+  let lng = Latlng.lng latlng in
+  let zoom = Map.get_zoom map in
+  let wrapped_latlng = Map.wrap_latlng latlng map in
+  let is_wrapped = not @@ Latlng.equals latlng wrapped_latlng in
+  if is_wrapped then (
+    (* wrap coordinates so we don't drift into a parralel universe
+     and lose track of markers *)
+    let w_lat = Latlng.lat wrapped_latlng in
+    let w_lng = Latlng.lng wrapped_latlng in
+    set_view (w_lat, w_lng, zoom);
+    (w_lat, w_lng, zoom) )
+  else (lat, lng, zoom)
+
+(* todo better leaflet interface for open/close_popup? *)
+let open_popup content latlng =
+  let popup = Popup.create ~content:(Some content) ~latlng:(Some latlng) [||] in
+  Map.open_popup popup map
+
+let close_popup () = Map.close_popup None map
+
+let on_move_end f = Map.on Event.Move_end f map
+
+let on_zoom_end f = Map.on Event.Zoom_end f map
+
+let on_click f = Map.on Event.Click f map
+
+(* init map, setup events *)
+let () =
+  Note_brr.Elr.on_add
+    (fun () ->
+      Fmt.pr "leaflet map init@.";
+      let osm_layer = Layer.create_tile_osm [||] in
+      Layer.add_to map osm_layer;
+      set_view (Storage.init_map_view ()) )
+    map_el;
+  on_move_end (fun _ev ->
+      let o = get_view () in
+      Events.send_action (Map_input (Move_end o)) );
+  on_zoom_end (fun _ev ->
+      let o = get_view () in
+      Events.send_action (Map_input (Zoom_end o)) );
+  on_click (fun ev ->
+      let latlng =
+        (* TODO wrap/check it server side too *)
+        (* wrap it to avoid creating thread on wrong earth *)
+        let latlng = Event.latlng ev in
+        Map.wrap_latlng latlng map
+      in
+      let lat = Latlng.lat latlng in
+      let lng = Latlng.lng latlng in
+      Events.send_action (Map_input (Click_latlng (lat, lng))) );
+  (* TODO:
+     - show a loading animation until we get the geolocation
+     - show something in case of error
+     - add special marker on map *)
+  let geolocalize _ev =
+    let open Brr_io.Geolocation in
+    let l = of_navigator G.navigator in
+    let opts = opts ~high_accuracy:true () in
+    Events.send_action (Map_input Geoloc_start);
+    (* only get first Geoloc_pos for now
+       let _ : watch_id =
+         watch l ~opts (fun pos_res ->
+    *)
+    let _fut : unit Fut.t =
+      get l ~opts
+      |> Fut.map (fun pos_res ->
+             match pos_res with
+             | Error err -> Events.send_action (Map_input (Geoloc_err err))
+             | Ok pos ->
+               Events.send_action (Map_input (Geoloc_pos pos));
+               let lat = Pos.latitude pos in
+               let lng = Pos.longitude pos in
+               let zoom = 17 in
+               set_view (lat, lng, zoom);
+               Storage.set_map_view (lat, lng, zoom);
+               () )
+    in
+    ()
+  in
+  hold_on geoloc_btn Ev.click geolocalize;
+  ()
+
+let toggle_latlng_popup latlng_opt =
+  match latlng_opt with
+  | None -> close_popup ()
+  | Some (lat, lng) ->
+    (* TODO add a marker with special icon here *)
+    open_popup "create thread here" (Latlng.create ~lat ~lng)
+
+module Markers = struct
+  let icon mode =
+    (* TODO define in App *)
+    let default_url = "/assets/img/marker-icon.png" in
+    let default_icon = Icon.create default_url [||] in
+    let selected_icon = Icon.create default_url [||] in
+    match mode with `Selected -> selected_icon | `Normal -> default_icon
+
+  let selected_id = ref None
+
+  let select id_opt = selected_id := id_opt
+
+  let is_selected id =
+    match !selected_id with
+    | None -> false
+    | Some selected_id -> Int.equal selected_id id
+
+  let refresh =
+    let set_layer =
+      (* replace previous geojson layer: avoid stacking layers and handle thread deletion *)
+      let layer_ref = ref None in
+      fun layer ->
+        Option.iter (Layer.remove_from map) !layer_ref;
+        layer_ref := Some layer;
+        Layer.add_to map layer
+    in
+    let on_marker_click id =
+      Events.send_action (Map_input (Click_marker id));
+      Navigation.load (Thread (Loading id))
+    in
+    let spawn_marker geojsonpoint_feature latlng =
+      let id =
+        let feature_properties = Jv.get geojsonpoint_feature "properties" in
+        Jv.get feature_properties "id" |> Jv.to_int
+      in
+      let icon =
+        match is_selected id with
+        | false -> icon `Normal
+        | true -> icon `Selected
+      in
+      let marker = Marker.create latlng [| Icon icon |] in
+      Layer.on Event.Click (fun _ev -> on_marker_click id) marker;
+      marker
+    in
+    fun catalog ->
+      let geojson_res =
+        let open Types in
+        catalog
+        |> List.map (fun v -> (v.lat, v.lng, v.op.id))
+        |> Json_data.Write.geojson_markers |> Jstr.of_string |> Brr.Json.decode
+      in
+      match geojson_res with
+      | Error e ->
+        Fmt.failwith "Markers.refresh failure: geojson serialization error `%s`"
+          (Util.str_of_error e)
+      | Ok geojson ->
+        let layer =
+          Layer.create_geojson geojson [| Point_to_layer spawn_marker |]
+        in
+        set_layer layer
+end
+
+let f t_s =
+  let open Model in
+  S.map (fun t -> t.post_form.latlng) t_s
+  |> S.changes
+  |> hold_endless toggle_latlng_popup;
+  S.map (fun t -> t.page) t_s
+  |> S.changes
+  |> E.map (fun _ -> None)
+  |> hold_endless toggle_latlng_popup;
+  (* todo: refresh on selection change may be too much because we clear and re-add all markers *)
+  S.map (fun t -> t.catalog) t_s |> S.changes |> hold_endless Markers.refresh;
+  S.map get_thread_w_reply t_s
+  |> S.map (Option.map Page.unwrap_thread_id)
+  |> S.changes
+  |> hold_endless (fun id_opt ->
+         Markers.select id_opt;
+         Markers.refresh (S.value t_s).catalog );
+  let el = El.div ~at:[ class' "home-right" ] [ map_el; buttons ] in
+  el

src/client/main.ml

@@ -0,0 +1,24 @@
+open Brr
+open Note
+open Model
+
+let ui : t -> t signal * El.t list =
+ fun t ->
+  let def t_s =
+    let els = Html.f t_s in
+    let do_stuff =
+      let do_actions = E.map do_action Events.actions in
+      let do_data_updates = E.map do_data_update Events.data_updates in
+      let do_error_popup_updates = E.map do_error Events.errors in
+      E.select [ do_actions; do_data_updates; do_error_popup_updates ]
+    in
+    let t_s' = S.accum (S.value t_s) do_stuff in
+    (t_s', (t_s', els))
+  in
+  S.fix t def
+
+let () =
+  let t_s, els = ui (init ()) in
+  (* don't forget to hold model signal! *)
+  Logr.(hold @@ S.log t_s (fun (_ : Model.t) -> ()));
+  El.set_children Util.body els

src/client/model.ml

@@ -0,0 +1,303 @@
+open Types
+open Client_types
+open Page
+
+type t =
+  { (* navigation state *)
+    session : session
+  ; fragment : Fragment.t
+  ; (* ui state *)
+    catalog : thread list
+  ; page : Page.t
+  ; post_form : Post_form_data.t
+  ; map_view : float * float * int
+  ; (* todo: just remove rect from here *)
+    quickview : (rect * (post_id, post) wrap) option
+  ; opened_image : post_id option
+  ; error : Client_types.error option
+  }
+
+(* TODO better session initialization/no dummy *)
+(* initialize session with dummy data and launch a GET.session request
+   catalog will be fetched on home and thread page navigation *)
+let init () =
+  Fmt.pr "model init@.";
+  let dummy_session =
+    { user_private = None; csrf_token = "dummy"; csrf_time_limit = 0.0 }
+  in
+  Network.GET.session ();
+  { session = dummy_session
+  ; fragment = Empty
+  ; catalog = Db.get_catalog ()
+  ; page = Home
+  ; post_form = Post_form_data.empty
+  ; map_view = Storage.init_map_view ()
+  ; quickview = None
+  ; opened_image = None
+  ; error = None
+  }
+
+(* TODO mv to ../util.ml *)
+let user_private_to_public u =
+  let User_private.
+        { user_id; user_nick; user_is_admin; bio; avatar_info; email = _ } =
+    u
+  in
+  { user_id; user_nick; user_is_admin; bio; avatar_info }
+
+let get_user t = Option.map user_private_to_public t.session.user_private
+
+let get_user_private t = t.session.user_private
+
+let get_user_admin t =
+  match get_user t with
+  | None -> None
+  | Some u -> ( match u.user_is_admin with false -> None | true -> Some u )
+
+let get_thread_w_reply t = match t.page with Thread t -> Some t | _ -> None
+
+(* TODO
+   - use CSS `scroll-margin-top` property *)
+(* History.push_state does not fire hashchange + scroll, so we have to do it
+   manually this relies on html `id` attribute:
+   - id attribute must exists and be unique
+     be careful to have posts only once in the html
+   - if html is invalid and multiple element have the same id.
+       it scroll to the first, which can be in a hidden page
+   This must be called after a fragment change when page is ready.
+   The DOM need to be re-rendered before we scroll_into_view.
+   So the scoll is delayed to the next JavaScript event loop cycle
+   with [Futr.to_event] *)
+let schedule_scroll_into_view =
+  let f opt =
+    match opt with
+    | None -> ()
+    | Some "" -> ()
+    | Some id -> (
+      match Util.find_html_el_by_id id with
+      | None ->
+        Fmt.failwith "scroll_into_view: html element with id `%s` not found@."
+          id
+      | Some el ->
+        Fmt.pr "scroll_into_view `%s`@." id;
+        Brr.El.scroll_into_view el )
+  in
+  fun s ->
+    let open Note in
+    (* TODO hold; need a hold_once? *)
+    let _ : Logr.t =
+      Fut.return s |> Note_brr.Futr.to_event |> E.obs
+      |> Logr.(app (const f))
+      |> Logr.create ~now:false
+    in
+    ()
+
+let load_aux find is_404 id =
+  match find id with
+  | Some v -> Ready v
+  | None -> (
+    match is_404 id with true -> Not_found id | false -> Loading id )
+
+let load_thread v =
+  let id = unwrap_thread_id v in
+  load_aux Db.find_thread_w_reply Db.thread_is_404 id
+
+let load_post v =
+  let id = unwrap_post_id v in
+  load_aux Db.find_post Db.post_is_404 id
+
+let load_user v =
+  let id = unwrap_user_id v in
+  load_aux Db.find_user Db.user_is_404 id
+
+let load_fragment page fragment =
+  let open Fragment in
+  match fragment with
+  | Empty | Top | Bottom -> fragment
+  | Id v ->
+    let id = unwrap_id v in
+    (* only consider fragment on thread pages *)
+    let v =
+      match page with
+      | Thread v -> (
+        match v with
+        | Loading _ -> Loading id
+        | Not_found _ -> Not_found id
+        | Ready v -> (
+          match List.exists (fun p -> p.id = id) v.reply_l with
+          | false -> Not_found id
+          | true -> Ready id ) )
+      | _ -> Not_found id
+    in
+    Id v
+
+let load_page = function
+  | Home -> Home
+  | New_thread -> New_thread
+  | About -> About
+  | Register -> Register
+  | Login -> Login
+  | Profile -> Profile
+  | Account -> Account
+  | Admin _ -> Admin (Ready (Db.get_reports ()))
+  | Thread id -> Thread (load_thread id)
+  | User id -> User (load_user id)
+  | Delete id -> Delete (load_post id)
+  | Report id -> Report (load_post id)
+
+let load_quickview opt =
+  opt
+  |> Option.map (fun (rect, v) ->
+         ( rect
+         , match v with Ready _ | Not_found _ -> v | Loading _ -> load_post v ) )
+
+let load_model t =
+  let session = Db.get_session () in
+  let catalog = Db.get_catalog () in
+  let page = load_page t.page in
+  let fragment = load_fragment page t.fragment in
+  let () =
+    match
+      (Fragment.get_ready_value t.fragment, Fragment.get_ready_value fragment)
+    with
+    | _, None | Some _, Some _ -> ()
+    | None, Some s -> schedule_scroll_into_view s
+  in
+  let quickview = load_quickview t.quickview in
+  { t with session; catalog; page; fragment; quickview }
+
+let do_post_form_action form_action post_form =
+  let open Post_form_data in
+  match form_action with
+  | Form_open -> { post_form with is_open = true }
+  | Form_close -> { post_form with is_open = false }
+  | Form_insert_quote id ->
+    let comment =
+      let s = post_form.comment in
+      (* insert quote on newline *)
+      match String.ends_with ~suffix:"\n" s || String.length s = 0 with
+      | true -> Fmt.str "%s>>%d " s id
+      | false -> Fmt.str "%s@\n>>%d " s id
+    in
+    { post_form with comment }
+  | Form_comment comment -> { post_form with comment }
+  | Form_file file -> { post_form with file }
+  | Form_alt alt -> { post_form with alt }
+  | Form_subject subject -> { post_form with subject }
+  | Form_latlng latlng -> { post_form with latlng }
+  | Form_reset -> Post_form_data.empty
+
+let do_map_action a t =
+  let set_latlng t opt =
+    let post_form = do_post_form_action (Form_latlng opt) t.post_form in
+    { t with post_form }
+  in
+  match a with
+  | Move_end map_view | Zoom_end map_view ->
+    Storage.set_map_view map_view;
+    { t with map_view }
+  | Geoloc_start -> t
+  | Geoloc_pos (_pos : Brr_io.Geolocation.Pos.t) -> t
+  | Geoloc_err (_err : Brr_io.Geolocation.Error.t) -> t
+  | Click_latlng latlng -> (
+    match t.page with New_thread -> set_latlng t (Some latlng) | _ -> t )
+  | Click_marker _thread_id -> set_latlng t None
+
+let do_action : Client_types.action -> t -> t =
+ fun action t ->
+  Fmt.pr {|do action: "%a"@.|} pp_action action;
+  match action with
+  | Navigation_event (page_opt, frag) ->
+    let page =
+      match page_opt with
+      | None -> t.page
+      | Some loading_page ->
+        Network.GET.f loading_page;
+        load_page loading_page
+    in
+    let fragment = load_fragment page frag in
+    let () =
+      match Fragment.get_ready_value fragment with
+      | None -> ()
+      | Some s -> schedule_scroll_into_view s
+    in
+    (* when we click the id to go to post blur event is not triggered,
+       so we clear quick view on hashchange too *)
+    let quickview = None in
+    let post_form =
+      match page_opt with
+      | None -> t.post_form
+      | Some _ -> { t.post_form with is_open = false; latlng = None }
+    in
+    { t with page; fragment; quickview; post_form }
+  | Post_form_change form_action -> (
+    (* TODO error message/feedback; use Validate_str *)
+    (* ignore reply form action if not logged in *)
+    match get_user t with
+    | None -> t
+    | Some _ ->
+      let post_form = do_post_form_action form_action t.post_form in
+      { t with post_form } )
+  | Map_input map_action -> do_map_action map_action t
+  | Submit_event (Form_kind.W kind, form) ->
+    let session = Db.get_session () in
+    Network.POST.f kind form session.csrf_token;
+    let t =
+      match kind with
+      | Logout ->
+        (* todo reload window? Brr.Window.reload Brr.G.window; *)
+        (* clear all state on logout
+           we do it here so we can logout even if offline *)
+        Db.clear ();
+        Storage.clear ();
+        init ()
+      | _ -> t
+    in
+    t
+  | Quickview_change opt ->
+    let quickview =
+      opt |> Option.map (fun (rect, v) -> (rect, Loading v)) |> load_quickview
+    in
+    begin
+      match quickview with
+      | Some (_, Loading post_id) -> Network.GET.post post_id
+      | _ -> ()
+    end;
+    { t with quickview }
+  | Image_click id -> (
+    match t.opened_image with
+    | Some current_image_id when Int.equal current_image_id id ->
+      { t with opened_image = None }
+    | Some _ | None -> { t with opened_image = Some id } )
+  | Clear_error -> { t with error = None }
+
+let do_data_update : Client_types.data_update -> t -> t =
+ fun action t ->
+  Fmt.pr {|do data update: "%a"@.|} pp_data_update action;
+  begin
+    match action with
+    | Post_update v -> Db.add_post v
+    | Thread_update thread_w_reply ->
+      Db.update_thread_w_reply (Some thread_w_reply)
+    | Catalog_update l -> Db.update_catalog l
+    | User_update u -> Db.update_user (Some u)
+    | Reports_update reports -> Db.update_reports reports
+    | Session_update session -> Db.update_session session
+  end;
+  load_model t
+
+let do_error : Client_types.error -> t -> t =
+ fun e t ->
+  Fmt.pr {|do error: "%a"@.|} pp_error e;
+  let t = { t with error = Some e } in
+  let () =
+    match e with
+    | Network_err _ -> ()
+    | Err_response e -> (
+      match e with
+      | Not_found_post id -> Db.add_post_404 id
+      | Not_found_thread id -> Db.add_thread_404 id
+      | Not_found_user user_id -> Db.add_user_404 user_id
+      | _ -> () )
+  in
+  load_model t

src/client/navigation.ml

@@ -0,0 +1,98 @@
+(* TODO
+     - use navigation API when ready(?)
+       https://developer.mozilla.org/en-US/docs/Web/API/Navigation_API *)
+open Brr
+open Util
+
+let of_uri uri =
+  let page, frag = Page.of_uri uri in
+  let frag =
+    let open Client_types.Fragment in
+    match of_string frag with
+    | Error e ->
+      Fmt.epr "%s@." e;
+      Empty
+    | Ok v -> v
+  in
+  (page, frag)
+
+let go_to ~just_change_hash uri =
+  let open Window in
+  let history = history window in
+  History.push_state ~uri history;
+  let page, frag = of_uri uri in
+  let opt = match just_change_hash with true -> None | false -> Some page in
+  Events.send_action (Navigation_event (opt, frag));
+  ()
+
+let load p =
+  let uri = Page.to_uri p in
+  go_to ~just_change_hash:false uri;
+  ()
+
+let update_to_current_location () =
+  let uri = Window.location window in
+  let page, frag = of_uri uri in
+  Events.send_action (Navigation_event (Some page, frag));
+  ()
+
+let on_load () =
+  (* todo hold
+     only observe once; destroy logger after first event *)
+  hold_endless_on_window Ev.load (fun _ev -> update_to_current_location ());
+  ()
+
+let on_link_click () =
+  let handle_link href =
+    let open Window in
+    let is_local = String.starts_with ~prefix:"/" href in
+    let is_hash = String.starts_with ~prefix:"#" href in
+    if is_local || is_hash then
+      (* how to build uri correctly from just href..? *)
+      let href_jstr = Jstr.v href in
+      let uri =
+        let with_uri =
+          match is_local with
+          | true ->
+            let e = Jstr.v "" in
+            fun uri -> Uri.with_uri ~path:e ~query:e ~fragment:e uri
+          | false -> fun uri -> Uri.with_uri ~fragment:href_jstr uri
+        in
+        let base =
+          match with_uri (location window) with
+          | Error e ->
+            Fmt.failwith "on_link_click: with_uri error `%s`"
+              (Util.str_of_error e)
+          | Ok v -> Uri.to_jstr v
+        in
+        Uri.v ~base href_jstr
+      in
+      go_to ~just_change_hash:is_hash uri
+  in
+  let navigation_handler ev =
+    (* TODO rm magick if possible *)
+    let el : El.t = Obj.magic (Ev.target ev) in
+    begin
+      if Jstr.equal (El.tag_name el) (Jstr.v "a") then
+        match El.at (Jstr.v "href") el with
+        | None -> Fmt.failwith "<a> element with no href"
+        | Some href -> begin
+          Ev.prevent_default ev;
+          handle_link (Jstr.to_string href)
+        end
+    end
+  in
+  hold_on body Ev.click navigation_handler
+
+let on_pop_state () =
+  let open Window in
+  hold_endless_on_window History.Ev.popstate (fun _ev ->
+      update_to_current_location () );
+  ()
+
+(* setup navigation listeners *)
+let () =
+  on_load ();
+  on_link_click ();
+  on_pop_state ();
+  ()

src/client/network.ml

@@ -0,0 +1,214 @@
+open Types
+open Client_types
+open Util
+
+(* TODO handle no network connection/unreachable server *)
+let handle_response meth fetch read_ok on_ok =
+  let open Brr_io.Fetch in
+  let read_body response res =
+    match res with
+    | Error e -> Error (Body_err (str_of_error e))
+    | Ok jstr -> (
+      let url = Jstr.to_string (Response.url response) in
+      let status = Response.status response in
+      let status_text = Jstr.to_string (Response.status_text response) in
+      let body = Jstr.to_string jstr in
+      let r = { meth; url; status; status_text; body } in
+      match Response.ok response with
+      | true -> (
+        match read_ok r.body with
+        | Error e -> Error (Read_err (e, r))
+        | Ok v -> Ok (Either.Left v) )
+      | false -> (
+        match Json_data.Read.err r.body with
+        | Error e -> Error (Read_err (e, r))
+        | Ok v -> Ok (Either.Right v) ) )
+  in
+  let read_response res =
+    match res with
+    | Error e -> Fut.return @@ Error (Fetch_err (str_of_error e))
+    | Ok response ->
+      let body = Response.as_body response in
+      Body.text body |> Fut.map (read_body response)
+  in
+  let f res =
+    read_response res
+    |> Fut.map (function
+         | Error e ->
+           Events.send_error (Network_err e);
+           ()
+         | Ok (Either.Left v) ->
+           on_ok v;
+           ()
+         | Ok (Either.Right err) ->
+           Events.send_error (Err_response err);
+           () )
+  in
+  Fut.bind (fetch ()) f
+
+module GET = struct
+  type _ t =
+    | Catalog : thread list t
+    | Thread : int -> Thread_w_reply.t t
+    | Post : int -> post t
+    | Admin : report list t
+    | User : string -> user t
+    | Session : session t
+
+  let reader : type a. a t -> string -> (a, string) result =
+   fun t ->
+    let open Json_data.Read in
+    match t with
+    | Catalog -> catalog
+    | Thread _id -> thread_w_reply
+    | Post _id -> post
+    | Admin -> reports
+    | User _id -> user
+    | Session -> session
+
+  let url : type a. a t -> string =
+   fun t ->
+    Fmt.str "/api%s"
+      ( match t with
+      | Catalog -> "/catalog"
+      | Thread id -> Fmt.str "/thread/%d" id
+      | Post id -> Fmt.str "/post/%d" id
+      | Admin -> "/admin"
+      | User id -> Fmt.str "/user/%s" id
+      | Session -> "/session" )
+
+  let on_ok : type a. a t -> a -> unit =
+   fun req v ->
+    let open Client_types in
+    let open Events in
+    begin
+      match req with
+      | Catalog -> send_data_update (Catalog_update v)
+      | Thread _id -> send_data_update (Thread_update v)
+      | Post _id -> send_data_update (Post_update v)
+      | Admin -> send_data_update (Reports_update v)
+      | User _id -> send_data_update (User_update v)
+      | Session -> send_data_update (Session_update v)
+    end;
+    ()
+
+  let fetch t =
+    let s = url t in
+    Fmt.pr "fetch `%s`@." s;
+    let fetch () = Brr_io.Fetch.url (Jstr.v s) in
+    let _fut = handle_response GET fetch (reader t) (on_ok t) in
+    ()
+
+  let catalog () = fetch Catalog
+
+  let thread id = fetch (Thread id)
+
+  let post id = fetch (Post id)
+
+  let admin () = fetch Admin
+
+  let user id = fetch (User id)
+
+  let session () = fetch Session
+
+  let f page =
+    let open Page in
+    match page with
+    | About | Register | Login -> ()
+    | Account | Profile -> session ()
+    | Home | New_thread -> catalog ()
+    | Admin _ -> admin ()
+    | Thread v ->
+      let id = unwrap_thread_id v in
+      thread id;
+      catalog ()
+    | Delete v | Report v ->
+      let id = unwrap_post_id v in
+      post id
+    | User v ->
+      let id = unwrap_user_id v in
+      user id
+end
+
+module POST = struct
+  open Form_kind
+
+  let reader : type a. a t -> string -> (a, string) result =
+   fun t ->
+    let open Json_data.Read in
+    match t with
+    | Home -> thread_w_reply
+    | Register -> session
+    | Login -> session
+    | Logout -> session
+    | Profile -> session
+    | Account -> session
+    | Thread _ -> thread_w_reply
+    | Delete _ -> post
+    | Report _ -> reports
+    | Admin_ignore _ -> reports
+    | Admin_delete _ -> post
+    | Admin_banish _ -> user
+
+  (* TODO implement redirection mechanism *)
+  let on_ok : type a. a t -> a -> unit =
+   fun o v ->
+    let open Client_types in
+    let open Events in
+    begin
+      match o with
+      | Home ->
+        send_data_update (Thread_update v);
+        send_action (Post_form_change Form_reset);
+        let id = v.op.id in
+        Navigation.load (Thread (Loading id))
+      | Thread _ ->
+        (* server respond to successful POST with full thread *)
+        send_data_update (Thread_update v);
+        send_action (Post_form_change Form_reset);
+        let id = v.op.id in
+        Navigation.load (Thread (Loading id))
+      | Register ->
+        send_data_update (Session_update v);
+        Navigation.load Profile
+      | Login ->
+        send_data_update (Session_update v);
+        Navigation.load Home
+      | Logout -> send_data_update (Session_update v)
+      | Delete _ -> (
+        let is_op = Int.equal v.id v.parent_t_id in
+        match is_op with
+        | true -> Navigation.load Home
+        | false -> Navigation.load (Thread (Loading v.parent_t_id)) )
+      | Report _ ->
+        send_data_update (Reports_update v);
+        (* TODO need redirection to page before report here *)
+        Navigation.load Home
+      | Admin_ignore _ -> send_data_update (Reports_update v)
+      | Admin_delete _ -> ()
+      | Admin_banish _ -> ()
+      | Profile -> send_data_update (Session_update v)
+      | Account -> send_data_update (Session_update v)
+    end;
+    ()
+
+  let fetch t request =
+    let fetch () = Brr_io.Fetch.request request in
+    handle_response POST fetch (reader t) (on_ok t)
+
+  let f kind form_el csrf_token =
+    let open Brr_io in
+    let method' = Jstr.v "POST" in
+    let form = Form.of_el form_el in
+    let action = Form_kind.action kind |> Jstr.v in
+    let form_data = Form.Data.of_form form in
+    Form.Data.set form_data (Jstr.v "dream.csrf") (Jstr.v csrf_token);
+    let body = Fetch.Body.of_form_data form_data in
+    let init = Fetch.Request.init ~method' ~body () in
+    let request = Fetch.Request.v ~init action in
+    let fut = fetch kind request in
+    let _fut : unit Fut.t =
+      Fut.map (fun () -> Fmt.pr "`%s` xhr done@." (Form_kind.name kind)) fut
+    in
+    ()
+end

src/client/page.ml

@@ -0,0 +1,193 @@
+open Types
+
+module Kind = struct
+  type t =
+    | Home
+    | New_thread
+    | Thread
+    | About
+    | Register
+    | Login
+    | Admin
+    | Profile
+    | Account
+    | User
+    | Delete
+    | Report
+
+  let equal : t -> t -> bool = fun a b -> Obj.magic a = Obj.magic b
+
+  let to_string = function
+    | Home -> "home"
+    | New_thread -> "new-thread"
+    | Thread -> "thread"
+    | About -> "about"
+    | Register -> "register"
+    | Login -> "login"
+    | Admin -> "administration"
+    | Profile -> "profile"
+    | Account -> "account"
+    | User -> "user"
+    | Delete -> "delete"
+    | Report -> "report"
+
+  let of_string s =
+    match s with
+    | "" | "home" -> Some Home
+    | "new-thread" -> Some New_thread
+    | "thread" -> Some Thread
+    | "about" -> Some About
+    | "register" -> Some Register
+    | "login" -> Some Login
+    | "administration" -> Some Admin
+    | "profile" -> Some Profile
+    | "account" -> Some Account
+    | "user" -> Some User
+    | "delete" -> Some Delete
+    | "report" -> Some Report
+    | _ -> None
+
+  let to_emoji = function
+    | Home -> Some "🗺️"
+    | About -> Some "🛸"
+    | Register -> Some "🍎"
+    | Login -> Some "🚪"
+    | Admin -> Some "🪄"
+    | Profile -> Some "🦩"
+    | Account -> Some "⚙"
+    | New_thread | Thread | User | Delete | Report -> None
+end
+
+type ('a, 'b) wrap =
+  | Loading of 'a
+  | Not_found of 'a
+  | Ready of 'b
+
+type t =
+  | Home
+  | New_thread
+  | Thread of (int, Thread_w_reply.t) wrap
+  | About
+  | Register
+  | Login
+  | Admin of (unit, report list) wrap
+  | Profile
+  | Account
+  | User of (user_id, user) wrap
+  | Delete of (post_id, post) wrap
+  | Report of (post_id, post) wrap
+
+let is_ready = function
+  | Home | New_thread | About | Register | Login | Profile | Account -> true
+  | Thread (Ready _)
+  | Admin (Ready _)
+  | User (Ready _)
+  | Delete (Ready _)
+  | Report (Ready _) ->
+    true
+  | _ -> false
+
+let unwrap_thread_id = function
+  | Loading v | Not_found v -> v
+  | Ready v -> v.Thread_w_reply.op.id
+
+let unwrap_post_id = function Loading v | Not_found v -> v | Ready v -> v.id
+
+let unwrap_user_id = function
+  | Loading v | Not_found v -> v
+  | Ready v -> v.user_id
+
+let to_kind = function
+  | Home -> Kind.Home
+  | New_thread -> New_thread
+  | Thread _ -> Thread
+  | About -> About
+  | Register -> Register
+  | Login -> Login
+  | Admin _ -> Admin
+  | Profile -> Profile
+  | Account -> Account
+  | User _ -> User
+  | Delete _ -> Delete
+  | Report _ -> Report
+
+(* TODO handle failure *)
+let of_uri =
+  let admin () = Admin (Loading ()) in
+  let user id = User (Loading id) in
+  let thread id = Thread (Loading id) in
+  let delete id = Delete (Loading id) in
+  let report id = Report (Loading id) in
+  let bind_int opt f = Option.bind opt int_of_string_opt |> Option.map f in
+  let of_kind ~item_id k =
+    match k with
+    | Kind.Home -> Some Home
+    | New_thread -> Some New_thread
+    | About -> Some About
+    | Register -> Some Register
+    | Login -> Some Login
+    | Profile -> Some Profile
+    | Account -> Some Account
+    | Admin -> Some (admin ())
+    | User -> item_id |> Option.map user
+    | Thread -> bind_int item_id thread
+    | Delete -> bind_int item_id delete
+    | Report -> bind_int item_id report
+  in
+  fun uri ->
+    let open Brr in
+    let segment_1, segment_2 =
+      let segments =
+        match Uri.path_segments uri with
+        | Error e ->
+          Fmt.failwith "Page.of_uri failure: path_segments error `%s`"
+            (Util.str_of_error e)
+        | Ok l -> List.map Jstr.to_string l
+      in
+      match segments with
+      | [] -> ("home", None)
+      | x :: [] -> (x, None)
+      | [ x; y ] -> (x, Some y)
+      | _ -> Fmt.failwith "Page.of_uri failure: invalid path segments"
+    in
+    match
+      Option.bind (Kind.of_string segment_1) (of_kind ~item_id:segment_2)
+    with
+    | None -> Fmt.failwith "Page.of_uri failure: invalid path format"
+    | Some page ->
+      let fragment_opt = uri |> Uri.fragment |> Jstr.to_string in
+      (page, fragment_opt)
+
+let to_path o =
+  let page_name = to_kind o |> Kind.to_string in
+  let param =
+    match o with
+    | Home | New_thread | About | Register | Login | Profile | Account -> None
+    | Admin _ -> None
+    | User v ->
+      let id = unwrap_user_id v in
+      Some id
+    | Thread v ->
+      let id = unwrap_thread_id v in
+      Some (string_of_int id)
+    | Delete v | Report v ->
+      let id = unwrap_post_id v in
+      Some (string_of_int id)
+  in
+  match param with
+  | None -> Fmt.str "/%s" page_name
+  | Some s -> Fmt.str "/%s/%s" page_name s
+
+let to_uri o =
+  let open Brr in
+  let uri =
+    (* clear query and fragment of the current uri *)
+    let empty_params = Uri.Params.of_jstr (Jstr.v "") in
+    let uri = Window.location G.window in
+    let uri = Uri.with_query_params uri empty_params in
+    Uri.with_fragment_params uri empty_params
+  in
+  let path = Jstr.v (to_path o) in
+  match Uri.with_uri ~path uri with
+  | Error e -> Fmt.failwith "%s" (Jv.of_error e |> Jv.to_string)
+  | Ok uri -> uri

src/client/storage.ml

@@ -0,0 +1,43 @@
+module Local = struct
+  open Brr
+  open Brr_io
+
+  let local = Storage.local G.window
+
+  let set k v =
+    match Storage.set_item local (Jstr.v k) (Jstr.v v) with
+    | (exception Jv.Error e) | Error e ->
+      Fmt.failwith "local storage failure `%s`" (Util.str_of_error e)
+    | Ok () -> ()
+
+  let get k = Storage.get_item local (Jstr.v k) |> Option.map Jstr.to_string
+
+  let clear () = Storage.clear local
+end
+
+let init_map_view () =
+  let default_map_view = (51.505, -0.09, 13) in
+  let lat = Local.get "lat" in
+  let lng = Local.get "lng" in
+  let zoom = Local.get "zoom" in
+  match (lat, lng, zoom) with
+  | Some lat, Some lng, Some zoom ->
+    let lat = lat |> Jstr.v |> Jstr.to_float in
+    let lng = lng |> Jstr.v |> Jstr.to_float in
+    let zoom =
+      match int_of_string_opt zoom with
+      | None -> Fmt.failwith "init_map_view: int_of_string failure on zoom"
+      | Some zoom -> zoom
+    in
+    (lat, lng, zoom)
+  | _ -> default_map_view
+
+let set_map_view (lat, lng, zoom) =
+  Local.set "lat" (string_of_float lat);
+  Local.set "lng" (string_of_float lng);
+  Local.set "zoom" (string_of_int zoom);
+  ()
+
+let clear () =
+  Local.clear ();
+  ()

src/client/util.ml

@@ -0,0 +1,89 @@
+open Brr
+
+let str = Jstr.v
+
+let str_of_error e = Jv.of_error e |> Jv.to_string
+
+(* redefine At module? *)
+let class' j = At.class' (str j)
+
+let id j = At.id (str j)
+
+let href j = At.href (str j)
+
+let src j = At.src (str j)
+
+let alt j = At.v (str "alt") (str j)
+
+let title j = At.title (str j)
+
+let type' j = At.type' (str j)
+
+let name j = At.name (str j)
+
+let value j = At.value (str j)
+
+let mk_at k v = At.v (str k) (str v)
+
+let el_txt s = El.txt (str s)
+
+let h1 s = El.h1 [ el_txt s ]
+
+let h2 s = El.h2 [ el_txt s ]
+
+let window = G.window
+
+let window_as_target = Window.as_target window
+
+let window_jv = Jv.get Jv.global "window"
+
+let window_width () = Jv.get window_jv "innerWidth" |> Jv.to_float
+
+let window_height () = Jv.get window_jv "innerHeight" |> Jv.to_float
+
+let document = G.document
+
+let document_as_target = Document.as_target document
+
+let body = Document.body document
+
+let find_html_el_by_id id =
+  Document.find_el_by_id G.document (Jstr.of_string id)
+
+let get_bounds el =
+  let x = El.bound_x el in
+  let y = El.bound_y el in
+  let w = El.bound_w el in
+  let h = El.bound_h el in
+  (x, y, w, h)
+
+let clamp ~min ~max x = Float.max (Float.min max x) min
+
+(* -- Note util -- *)
+open Note
+open Note_brr
+
+let def_off b_s el = Elr.def_class (str "off") b_s el
+
+let def_on b_s el = Elr.def_class (str "off") (S.map not b_s) el
+
+let def_disabled b_s el =
+  Elr.def_at At.Name.disabled
+    (S.map (function true -> Some (Jstr.v "") | false -> None) b_s)
+    el
+
+let hold_on el ev_type f =
+  let event = Evr.on_el ev_type Fun.id el in
+  Elr.may_hold_logr el (E.log event f);
+  ()
+
+let hold_event_on el event f =
+  Elr.may_hold_logr el (E.log event f);
+  ()
+
+let hold_endless f e = Logr.may_hold (E.log e f)
+
+let hold_endless_on_window ev_type f =
+  let event = Evr.on_target ev_type Fun.id window_as_target in
+  hold_endless f event;
+  ()

src/comment/ast.ml

@@ -0,0 +1,9 @@
+type item =
+  | Id of int
+  | Txt of string
+
+type line =
+  | Line of item list
+  | Line_quote of item list
+
+type t = line list

src/comment/comment.ml

@@ -0,0 +1,85 @@
+include Ast
+
+let backlinks comment =
+  comment
+  |> List.map (function Line l -> l | Line_quote l -> l)
+  |> List.flatten
+  |> List.filter_map (function Id id -> Some id | Txt _s -> None)
+  |> List.sort_uniq Int.compare
+
+let of_string =
+  (* merge adjacent Txt together *)
+  let merge_txt_aux item_l =
+    let rec loop l acc txt_acc =
+      match l with
+      | [] -> (
+        match txt_acc with
+        | [] -> List.rev acc
+        | _ ->
+          let txt = Txt (String.concat "" (List.rev txt_acc)) in
+          List.rev (txt :: acc) )
+      | Txt s :: tl -> loop tl acc (s :: txt_acc)
+      | hd :: tl -> (
+        match txt_acc with
+        | [] -> loop tl (hd :: acc) []
+        | _ ->
+          let txt = Txt (String.concat "" (List.rev txt_acc)) in
+          loop tl (hd :: txt :: acc) [] )
+    in
+    let l = loop item_l [] [] in
+    l
+  in
+  let merge_txt =
+   fun line_l ->
+    List.map
+      (function
+        | Line l -> Line (merge_txt_aux l)
+        | Line_quote l -> Line_quote (merge_txt_aux l) )
+      line_l
+  in
+  (* for debug and error msg *)
+  let token_to_string = function
+    | Parser.EOF -> "eof"
+    | NEWLINE -> "newline"
+    | GT -> ">"
+    | ID i -> Fmt.str "id: `%d`" i
+    | TXT s -> Fmt.str "text: `%s`" s
+  in
+  (* parser *)
+  let from_lexbuf =
+    let parser =
+      MenhirLib.Convert.Simplified.traditional2revised Parser.comment
+    in
+    fun buf ->
+      let provider () =
+        let tok = Lexer.token buf in
+        let start, stop = Sedlexing.lexing_positions buf in
+        (tok, start, stop)
+      in
+      try Ok (parser provider) with
+      | Lexer.Lexing_error e -> Error e
+      | Sedlexing.MalFormed -> Error (Fmt.str "malformed utf8 encoding")
+      | Parser.Error ->
+        let tok = Lexer.token buf |> token_to_string in
+        Error (Fmt.str "unexpected token `%s`" tok)
+  in
+  fun s -> from_lexbuf (Sedlexing.Utf8.from_string s) |> Result.map merge_txt
+
+let to_string =
+  let pp_item fmt = function
+    | Txt s -> Fmt.pf fmt "%s" s
+    | Id i -> Fmt.pf fmt ">>%d" i
+  in
+  let pp_line =
+    let sep = Fmt.any "" in
+    fun fmt line ->
+      match line with
+      | Line items -> Fmt.pf fmt "%a" (Fmt.list ~sep pp_item) items
+      | Line_quote items -> Fmt.pf fmt ">%a" (Fmt.list ~sep pp_item) items
+  in
+  let pp fmt line_l =
+    Fmt.pf fmt "%a" (Fmt.list ~sep:(Fmt.any "@\n") pp_line) line_l
+  in
+  fun comment ->
+    let s = Fmt.str "%a" pp comment in
+    s

src/comment/dune

@@ -0,0 +1,9 @@
+(menhir
+ (modules parser))
+
+(library
+ (name comment)
+ (modules comment lexer parser ast)
+ (libraries menhirLib sedlex fmt)
+ (preprocess
+  (pps sedlex.ppx)))

src/comment/lexer.ml

@@ -0,0 +1,30 @@
+open Sedlexing
+open Parser
+
+exception Lexing_error of string
+
+let newline = [%sedlex.regexp? '\n' | "\r\n"]
+
+let gt = [%sedlex.regexp? '>']
+
+let id = [%sedlex.regexp? ">>", Plus '0' .. '9']
+
+let txt = [%sedlex.regexp? Plus (Compl ('>' | '\n'))]
+
+let token lexbuf =
+  match%sedlex lexbuf with
+  | eof -> EOF
+  | newline -> NEWLINE
+  | id ->
+    let lexeme = Utf8.lexeme lexbuf in
+    let id =
+      ID (int_of_string (String.sub lexeme 2 (String.length lexeme - 2)))
+    in
+    id
+  | gt -> GT
+  | txt ->
+    let lexeme = Utf8.lexeme lexbuf in
+    TXT lexeme
+  | _ -> raise (Lexing_error ("Unexpected character: " ^ Utf8.lexeme lexbuf))
+
+let lexer lexbuf = Sedlexing.with_tokenizer token lexbuf

src/comment/parser.mly

@@ -0,0 +1,30 @@
+%{
+  open Ast
+%}
+%token EOF
+%token NEWLINE
+%token <int> ID
+%token <string> TXT
+%token GT
+
+%start comment
+%type <t> comment
+
+%%
+
+comment:
+  | separated_nonempty_list(NEWLINE, line) EOF { $1 }
+
+line:
+  | {Line ([]) }
+  | ID items {Line ( (Id $1) :: $2) }
+  | TXT items {Line ( (Txt $1) :: $2) }
+  | GT items {Line_quote $2 }
+
+items:
+  | list(item) { $1 }
+
+item:
+  | ID { Id $1 }
+  | TXT { Txt $1 }
+  | GT { Txt ">" }

src/content/about.md

@@ -1,23 +0,0 @@
-# What is Permap
-
-Permap is an open source geo-message-board software written in OCaml.
-
-Permap was initially made to be a gardening/permaculture forum.
-Permap's aim is to help people find friends with similar interests around them
-and build local communities.
-
-You can make threads with geographical coordinate, 
-this way you can find people near you doing interesting stuffs, 
-socialize with them and share local knowledge. 
-
-## Permap's future
-
-- Make permap federate
-
-- More than coordinates
-
-Make threads on anything with a geographical position.
-Instead of making threads with a simple (latitude * longitude) data,
-we want to be able to make threads on any OpenStreetMap's item/ActivityPub object 
-that can resolve to a geographical position.
-

src/content/assets/css/style.css

@@ -1,169 +0,0 @@
-body {
-  padding-top: 0rem;
-  padding-bottom: 3rem;
-  color: #5a5a5a;
-  background-color: #e8eaf6;
-  line-height: 1.6;
-  font-size: 18px;
-}
-
-.featurette-divider {
-  margin: 5rem 0;
-}
-
-#page-title {
-  text-align: center;
-}
-
-blockquote.blockquote {
-  border-left: 6px solid #3131e0;
-  border-radius: 6px;
-  padding-left: 16px;
-  background-color:  #c0c0f0;
-}
-
-#map {
-  height: 800px;
-  width: auto;
-}
-
-.post {
-  background-color: #C5E1A5;
-  margin: 5px 5px 5px 5px;
-  border: 2px solid #FFB300;
-  padding: 2px;
-  display: table;
-}
-
-.post + .highlight {
-  background-color: #9dd162;
-  margin: 5px 5px 5px 5px;
-  border: 2px solid #FFB300;
-  padding: 2px;
-  display: table;
-}
-
-.post + .selected {
-  background-color: #9dd162;
-  margin: 5px 5px 5px 5px;
-  border: 2px solid #FFB300;
-  padding: 2px;
-  display: table;
-}
-
-.post-info {
-  display: block;
-  width: 100%;
-}
-
-.nick {
-  color: #FFB300;
-}
-
-.post-comment {
-  display: block;
-  padding-top: 10px;
-  color: #333333;
-}
-
-.post-image-container {
-  float: left;
-  padding: 5px 5px 5px 5px;
-}
-
-.post-image {
-  max-width: 300px;
-  max-height: 300px;
-}
-
-.post-image-big {
-  max-width: 1200px;
-  height: auto;
-}
-
-.quote {
-  color: green;
-}
-
-.quote-link {
-  background-color: #FCE4EC;
-  padding: 2px;
-  text-align: center;
-  color: #5a5a5a;
-  font-size: 10px;
-  border-radius: 12px;
-  border: 2px solid DodgerBlue;
-}
-
-.quote-link:focus {
-  background-color: #FCE4EC;
-  padding: 2px;
-  text-align: center;
-  color: #5a5a5a;
-  font-size: 10px;
-  border-radius: 12px;
-  border: 2px solid DodgerBlue;
-}
-
-.post-form {
-  background-color: #FCE4EC;
-  margin: 5px 5px 5px 5px;
-  border: 2px solid #FFB300;
-  padding: 2px;
-  display: table;
-  width: 500px;
-}
-
-#newthread-form {
-  visibility: hidden;
-}
-
-a.preview-link {
-  text-decoration: none;
-  color: unset;
-}
-
-.thread-subject {
-  margin: auto;
-  width: 50%;
-  text-align: center;
-  color: #5a5a5a;
-  font-size: 30px;
-}
-
-.tag {
-  background-color: #FFB300;
-  border-radius: 4px;
-  padding: 2px;
-}
-
-.category {
-  background-color: #FFB300;
-  border-radius: 4px;
-  padding: 2px;
-  font-weight: bold;
-  font-size: 20px;
-}
-
-.off {
-  display: none;
-}
-
-.post-menu-div {
-  display: inline;
-}
-
-a.post-menu-link {
-  text-decoration: none;
-  color: green;
-}
-
-.rss-logo {
-  height: 30px;
-  width: auto;
-  float: right;
-}
-
-#submit-button {
-  float: right;
-}

src/content/assets/js/dune

@@ -1,26 +0,0 @@
-(rule
- (target catalog.js)
- (deps
-  (file ../../../js/catalog.bc.js))
- (action
-  (with-stdout-to
-   %{target}
-   (cat ../../../js/catalog.bc.js))))
-
-(rule
- (target babillard.js)
- (deps
-  (file ../../../js/babillard.bc.js))
- (action
-  (with-stdout-to
-   %{target}
-   (cat ../../../js/babillard.bc.js))))
-
-(rule
- (target thread.js)
- (deps
-  (file ../../../js/thread.bc.js))
- (action
-  (with-stdout-to
-   %{target}
-   (cat ../../../js/thread.bc.js))))

src/content/register.md

@@ -1,19 +0,0 @@
-# Register
-
-<form>
-  <div class="mb-3">
-    <label for="inputNick" class="form-label">Nick</label>
-    <input type="text" class="form-control" id="inputNick" aria-describedby="nickHelp">
-    <div id="nickHelp" class="form-text">Who are u ?</div>
-  </div>
-  <div class="mb-3">
-    <label for="inputEmail" class="form-label">Email address</label>
-    <input type="email" class="form-control" id="inputEmail" aria-describedby="emailHelp">
-    <div id="emailHelp" class="form-text">We'll never share your email with anyone else.</div>
-  </div>
-  <div class="mb-3">
-    <label for="inputPassword" class="form-label">Password</label>
-    <input type="password" class="form-control" id="inputPassword">
-  </div>
-  <button type="submit" class="btn btn-primary" formaction="/register">Submit</button>
-</form>

src/db.ml

@@ -1,48 +0,0 @@
-open Caqti_request.Infix
-
-let db_root = App.data_dir
-
-let () =
-  match Bos.OS.Dir.create (Fpath.v db_root) with
-  | Ok true -> Dream.log "created %s" db_root
-  | Ok false -> Dream.log "%s already exists" db_root
-  | Error (`Msg _) ->
-    Dream.warning (fun log -> log "error when creating %s" db_root)
-
-let db = Filename.concat db_root "permap.db"
-
-let db_uri = Format.sprintf "sqlite3://%s" db
-
-module Db =
-  (val Caqti_blocking.connect (Uri.of_string db_uri) |> Caqti_blocking.or_fail)
-
-let () =
-  let set_foreign_keys_on =
-    Caqti_type.(unit ->. unit) "PRAGMA foreign_keys = ON"
-  in
-  if Result.is_error (Db.exec set_foreign_keys_on ()) then
-    Dream.error (fun log -> log "can't set foreign_keys on")
-
-let () =
-  let query =
-    Caqti_type.(unit ->. unit)
-      "CREATE TABLE IF NOT EXISTS dream_session (id TEXT PRIMARY KEY, label \
-       TEXT NOT NULL, expires_at REAL NOT NULL, payload TEXT NOT NULL)"
-  in
-  match Db.exec query () with
-  | Ok () -> ()
-  | Error _e ->
-    Format.eprintf "db error@\n";
-    exit 1
-
-let unwrap_err = function
-  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
-  | Ok _ as ok -> ok
-
-let exec q v = Db.exec q v |> unwrap_err
-
-let find q v = Db.find q v |> unwrap_err
-
-let find_opt q v = Db.find_opt q v |> unwrap_err
-
-let collect_list q v = Db.collect_list q v |> unwrap_err

src/db.mli

@@ -1,13 +0,0 @@
-val exec : ('a, unit, [< `Zero ]) Caqti_request.t -> 'a -> (unit, string) result
-
-val find : ('a, 'b, [< `One ]) Caqti_request.t -> 'a -> ('b, string) result
-
-val find_opt :
-     ('a, 'b, [< `One | `Zero ]) Caqti_request.t
-  -> 'a
-  -> ('b option, string) result
-
-val collect_list :
-     ('a, 'b, [ `Many | `One | `Zero ]) Caqti_request.t
-  -> 'a
-  -> ('b list, string) result

src/db_image.ml

@@ -0,0 +1,162 @@
+(* TODO
+   - delete: error if does not exists
+   - better upload (insert/update)
+   - use join *)
+open Syntax
+open Err
+open Types
+open Caqti_request.Infix
+open Caqti_type
+open Caqti_db
+
+let post_tbl_prefix, post_key_reference = ("post_", "post(id)")
+
+let avatar_tbl_prefix, avatar_key_reference = ("user_", "user(user_id)")
+
+let () =
+  let mk_tables id_kind prefix reference_tbl =
+    [| Fmt.kstr (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS %simage_info (id %s, md5 TEXT, mime TEXT, \
+          w INTEGER, h INTEGER, thumb_w INTEGER, thumb_h INTEGER, name TEXT, \
+          alt TEXT, FOREIGN KEY(id) REFERENCES %s ON DELETE CASCADE)"
+         prefix id_kind reference_tbl
+     ; Fmt.kstr (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS %simage_content (id %s, content TEXT, \
+          FOREIGN KEY(id) REFERENCES %s ON DELETE CASCADE)"
+         prefix id_kind reference_tbl
+     ; Fmt.kstr (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS %simage_thumbnail (id %s, content TEXT, \
+          FOREIGN KEY(id) REFERENCES %s ON DELETE CASCADE)"
+         prefix id_kind reference_tbl
+    |]
+  in
+  let tables =
+    Array.concat
+      [ mk_tables "INTEGER" post_tbl_prefix post_key_reference
+      ; mk_tables "TEXT" avatar_tbl_prefix avatar_key_reference
+      ]
+  in
+  Array.iter (fun query -> Db.exec_unsafe query ()) tables
+
+module type T = sig
+  type t
+
+  val info : t -> img_info option result
+
+  val data : t -> string option result
+
+  val thumbnail_data : t -> string option result
+
+  val delete : t -> unit result
+
+  val upload : t -> img -> unit result
+end
+
+module type A = sig
+  type t
+
+  val caqti_t : t Caqti_type.t
+
+  val prefix : string
+
+  val replace_image : bool
+end
+
+(* Make(A) => T *)
+module Make (M : A) = struct
+  include M
+
+  let upload_info =
+    Db.exec
+    @@ Fmt.kstr
+         (t9 caqti_t string string int int int int string string ->. unit)
+         "INSERT INTO  %simage_info VALUES (?,?,?,?,?,?,?,?,?)" prefix
+
+  let upload_data =
+    Db.exec
+    @@ Fmt.kstr
+         (t2 caqti_t string ->. unit)
+         "INSERT INTO %simage_content VALUES (?,?)" prefix
+
+  let upload_thumbnail_data =
+    Db.exec
+    @@ Fmt.kstr
+         (t2 caqti_t string ->. unit)
+         "INSERT INTO %simage_thumbnail VALUES (?,?)" prefix
+
+  let info =
+    let f =
+      Db.find_opt
+        (Fmt.kstr
+           (caqti_t ->? t9 caqti_t string string int int int int string string)
+           "SELECT * FROM %simage_info WHERE id=?" prefix )
+    in
+    fun id ->
+      let+ opt = f id in
+      Option.map
+        (fun (_id, md5, mime, w, h, thumb_w, thumb_h, name, alt) ->
+          { md5; mime; w; h; thumb_w; thumb_h; name; alt } )
+        opt
+
+  let data =
+    Db.find_opt
+    @@ Fmt.kstr (caqti_t ->? string)
+         "SELECT content FROM %simage_content WHERE id=?" prefix
+
+  let thumbnail_data =
+    Db.find_opt
+    @@ Fmt.kstr (caqti_t ->? string)
+         "SELECT content FROM %simage_thumbnail WHERE id=?" prefix
+
+  let delete_info =
+    Db.exec
+    @@ Fmt.kstr (caqti_t ->. unit) "DELETE FROM %simage_info WHERE id=?" prefix
+
+  let delete_content =
+    Db.exec
+    @@ Fmt.kstr (caqti_t ->. unit) "DELETE FROM %simage_content WHERE id=?"
+         prefix
+
+  let delete_thumbnail =
+    Db.exec
+    @@ Fmt.kstr (caqti_t ->. unit) "DELETE FROM %simage_thumbnail WHERE id=?"
+         prefix
+
+  (* TODO error if does not exists *)
+  let delete id =
+    let* () = delete_info id in
+    let* () = delete_content id in
+    delete_thumbnail id
+
+  let upload id image =
+    (* TODO do something like
+       https://stackoverflow.com/questions/418898/upsert-not-insert-or-replace/4330694#4330694
+       instead of deleting then re-inserting to update(or insert on first time).. *)
+    let* () = if replace_image then delete id else Ok () in
+    (* -- *)
+    let { info; data; thumbnail_data } = image in
+    let { md5; mime; w; h; thumb_w; thumb_h; name; alt } = info in
+    let* () = upload_info (id, md5, mime, w, h, thumb_w, thumb_h, name, alt) in
+    let* () = upload_data (id, data) in
+    upload_thumbnail_data (id, thumbnail_data)
+end
+
+module P = Make (struct
+  type t = int
+
+  let caqti_t = Caqti_type.int
+
+  let prefix = post_tbl_prefix
+
+  let replace_image = false
+end)
+
+module U = Make (struct
+  type t = string
+
+  let caqti_t = Caqti_type.string
+
+  let prefix = avatar_tbl_prefix
+
+  let replace_image = true
+end)

src/db_image.mli

@@ -0,0 +1,28 @@
+(* TODO sql
+   - use JOIN for getting image info instead *)
+(* no sql transaction are started in this module
+   two kind of images: post images and user avatars
+   only difference is avatar image are unique and "persist".
+   kept in different tables
+   :^) ~ horrible functor just to factorize code
+   *)
+open Err
+open Types
+
+module type T = sig
+  type t
+
+  val info : t -> img_info option result
+
+  val data : t -> string option result
+
+  val thumbnail_data : t -> string option result
+
+  val delete : t -> unit result
+
+  val upload : t -> img -> unit result
+end
+
+module P : T with type t = int
+
+module U : T with type t = string

src/db_post.ml

@@ -0,0 +1,269 @@
+(* TODO sql
+   - add index on thread_reply/post_reply
+   - have a table auto-updated for bump_status
+   - JOIN :
+     - use join for image_info
+     - get all thread reply_l in one join + queries for backlinks
+   *)
+open Syntax
+open Err
+open Types
+open Caqti_request.Infix
+open Caqti_type
+open Caqti_db
+
+let () =
+  let tables =
+    [| (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS post (id INTEGER PRIMARY KEY \
+          AUTOINCREMENT, user_id TEXT, date FLOAT, comment TEXT, FOREIGN \
+          KEY(user_id) REFERENCES user(user_id) ON DELETE CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS thread (thread_id INTEGER, lat FLOAT, lng \
+          FLOAT, subject TEXT, reply_count INTEGER, last_reply_date FLOAT, \
+          FOREIGN KEY(thread_id) REFERENCES post(id) ON DELETE CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS thread_reply (thread_id INTEGER, post_id \
+          INTEGER, FOREIGN KEY(thread_id) REFERENCES post(id) ON DELETE \
+          CASCADE, FOREIGN KEY(post_id) REFERENCES post(id) ON DELETE CASCADE)"
+     ; (unit ->. unit)
+         (* backlinks *)
+         "CREATE TABLE IF NOT EXISTS post_reply (id INTEGER, reply_id INTEGER, \
+          FOREIGN KEY(reply_id) REFERENCES post(id) ON DELETE CASCADE)"
+    |]
+  in
+  let indexes =
+    [| (unit ->. unit)
+         "CREATE INDEX IF NOT EXISTS index_thread_bump ON thread \
+          (last_reply_date)"
+    |]
+  in
+  let triggers =
+    [| (unit ->. unit)
+         "CREATE TRIGGER IF NOT EXISTS trigger_incr_reply_count AFTER INSERT \
+          ON thread_reply BEGIN UPDATE thread SET reply_count = reply_count + \
+          1 WHERE thread_id = new.thread_id; END;"
+     ; (unit ->. unit)
+         "CREATE TRIGGER IF NOT EXISTS trigger_decr_reply_count AFTER DELETE \
+          ON thread_reply BEGIN UPDATE thread SET reply_count = reply_count - \
+          1 WHERE thread_id = old.thread_id; END;"
+     ; (unit ->. unit)
+         "CREATE TRIGGER IF NOT EXISTS trigger_update_last_reply_date AFTER \
+          INSERT ON thread_reply BEGIN UPDATE thread SET last_reply_date = \
+          (SELECT date FROM post WHERE id = new.post_id) WHERE thread_id = \
+          new.thread_id; END;"
+    |]
+  in
+  Array.iter (fun query -> Db.exec_unsafe query ()) tables;
+  Array.iter (fun query -> Db.exec_unsafe query ()) indexes;
+  Array.iter (fun query -> Db.exec_unsafe query ()) triggers;
+  ()
+
+let add_post =
+  Db.find
+  @@ (t3 string float string ->! int)
+       "INSERT INTO post (user_id,date,comment) VALUES (?,?,?) RETURNING id"
+
+let add_thread_reply =
+  Db.exec @@ (t2 int int ->. unit) "INSERT INTO thread_reply VALUES (?,?)"
+
+let find_post_w_join =
+  Db.find_opt
+  @@ (int ->! t6 int string float string int string)
+       "SELECT p.id, p.user_id, p.date, p.comment, t_r.thread_id, u.nick FROM \
+        post p JOIN thread_reply t_r ON p.id=t_r.post_id JOIN user u ON \
+        p.user_id = u.user_id WHERE p.id = ?"
+
+let find_post_thread_id =
+  Db.find_opt
+  @@ (int ->! int) "SELECT thread_id FROM thread_reply WHERE post_id=?"
+
+let add_thread =
+  Db.exec
+  @@ (t6 int float float string int float ->. unit)
+       "INSERT INTO thread VALUES (?,?,?,?,?,?)"
+
+let find_thread =
+  Db.find_opt
+  @@ (int ->! t6 int float float string int float)
+       "SELECT * FROM thread WHERE thread_id=?"
+
+let add_post_reply =
+  Db.exec @@ (t2 int int ->. unit) "INSERT INTO post_reply VALUES (?,?)"
+
+let get_thread_replies =
+  Db.collect_list
+  @@ (int ->* int) "SELECT post_id FROM thread_reply WHERE thread_id = ?"
+
+let get_post_backlinks =
+  Db.collect_list
+  @@ (int ->* int) "SELECT reply_id FROM post_reply WHERE id = ?"
+
+let get_all_thread_ids =
+  Db.collect_list @@ (unit ->* int) "SELECT thread_id FROM thread"
+
+let delete_post = Db.exec @@ (int ->. unit) "DELETE FROM post WHERE id=?"
+
+let get_thread_bump_rank =
+  Db.find
+  @@ (int ->! t2 int int)
+       "SELECT reply_count, CAST (rank AS INTEGER) FROM ( SELECT thread_id, \
+        reply_count, ROW_NUMBER () OVER ( ORDER BY last_reply_date DESC ) rank \
+        FROM thread ) WHERE thread_id = ?"
+(* ----- *)
+
+let get_thread_bump_rank id =
+  (* count rank from 0
+     reply_count = nb_row(thread_reply) - 1; because we don't count op *)
+  let+ reply_count, rank = get_thread_bump_rank id in
+  let rank = rank - 1 in
+  if rank > Config.thread_alive_max_count then Locked rank
+  else if reply_count >= Config.thread_replies_max_count then Locked rank
+  else Alive rank
+
+let get_post_thread_id id =
+  let* opt = find_post_thread_id id in
+  match opt with
+  | None -> Error (Internal (Db_not_found (string_of_int id)))
+  | Some v -> Ok v
+
+let delete id =
+  Db.do_transaction @@ fun () ->
+  let* thread_id = get_post_thread_id id in
+  let is_op = thread_id = id in
+  match is_op with
+  | true ->
+    let* replies = get_thread_replies thread_id in
+    let* () = list_iter delete_post replies in
+    Ok ()
+  | false ->
+    let+ () = delete_post id in
+    ()
+
+let find_post id =
+  let* opt = find_post_w_join id in
+  match opt with
+  | None -> Ok None
+  | Some (id, poster_id, date, comment_str, thread_id, poster_nick) ->
+    let* comment =
+      Comment.of_string comment_str
+      |> Result.map_error (fun s -> Unprocessable (Fmt.str "comment: %s" s))
+    in
+    let* image_info = Db_image.P.info id in
+    let+ backlinks = get_post_backlinks id in
+    Some
+      { id
+      ; parent_t_id = thread_id
+      ; date
+      ; poster_id
+      ; poster_nick
+      ; comment
+      ; image_info
+      ; backlinks
+      }
+
+let get_post id =
+  let* opt = find_post id in
+  match opt with
+  | None -> Error (Internal (Db_not_found (string_of_int id)))
+  | Some v -> Ok v
+
+let find_thread id =
+  let* opt = find_thread id in
+  match opt with
+  | None -> Ok None
+  | Some (id, lat, lng, subject, reply_count, _last_reply_date) ->
+    let* op = get_post id in
+    let+ bump_status = get_thread_bump_rank id in
+    Some { op; subject; lat; lng; bump_status; reply_count }
+
+let find_thread_w_reply id =
+  let* opt = find_thread id in
+  match opt with
+  | None -> Ok None
+  | Some { op; subject; lat; lng; bump_status; reply_count } ->
+    let+ reply_l =
+      let* ids = get_thread_replies id in
+      list_map get_post ids
+    in
+    Some
+      Thread_w_reply.
+        { op; subject; lat; lng; bump_status; reply_count; reply_l }
+
+let get_thread id =
+  let* opt = find_thread id in
+  match opt with
+  | None -> Error (Internal (Db_not_found (string_of_int id)))
+  | Some v -> Ok v
+
+let find_post id = Db.do_transaction @@ fun () -> find_post id
+
+let find_thread id = Db.do_transaction @@ fun () -> find_thread id
+
+let find_thread_w_reply id =
+  Db.do_transaction @@ fun () -> find_thread_w_reply id
+
+let get_catalog () =
+  Db.do_transaction @@ fun () ->
+  let* ids = get_all_thread_ids () in
+  list_map get_thread ids
+
+let add_post_aux ~thread_id ~thread_data ~user ~image ~comment =
+  let poster_id = user.user_id in
+  let poster_nick = user.user_nick in
+  let date = Unix.time () in
+  let image_info = Option.map (fun o -> o.info) image in
+  let comment_str = Comment.to_string comment in
+  let* id = add_post (poster_id, date, comment_str) in
+  let thread_id = Option.value ~default:id thread_id in
+  let* () =
+    match thread_data with
+    | None -> Ok ()
+    | Some (subject, lat, lng) ->
+      (* don't count op in thread number of replies
+         -1 because of trigger on thread_reply table insert *)
+      let nb_reply = -1 in
+      add_thread (id, lat, lng, subject, nb_reply, date)
+  in
+  let* () = add_thread_reply (thread_id, id) in
+  let* () =
+    Option.fold ~none:(Ok ()) ~some:(fun img -> Db_image.P.upload id img) image
+  in
+  let+ () =
+    Comment.backlinks comment
+    |> list_iter (fun cited_id -> add_post_reply (cited_id, id))
+  in
+  { id
+  ; parent_t_id = thread_id
+  ; date
+  ; poster_id
+  ; poster_nick
+  ; comment
+  ; image_info
+  ; backlinks =
+      [] (* TODO can be false because of possibility to reply to futur post *)
+  }
+
+let add_post ~thread_id ~user ~image ~comment =
+  Db.do_transaction @@ fun () ->
+  let+ post =
+    add_post_aux ~thread_id:(Some thread_id) ~thread_data:None ~user ~image
+      ~comment
+  in
+  post
+
+let add_thread ~subject ~lat ~lng ~user ~image ~comment =
+  Db.do_transaction @@ fun () ->
+  let subject : v_string = subject in
+  let subject :> string = subject in
+  let thread_data = Some (subject, lat, lng) in
+  let+ op = add_post_aux ~thread_id:None ~thread_data ~user ~image ~comment in
+  Thread_w_reply.
+    { op
+    ; subject
+    ; lat
+    ; lng
+    ; bump_status = Alive 0
+    ; reply_count = 0
+    ; reply_l = [ op ]
+    }

src/db_post.mli

@@ -0,0 +1,28 @@
+open Err
+open Types
+
+val find_post : post_id -> post option result
+
+val find_thread : post_id -> thread option result
+
+val find_thread_w_reply : post_id -> Thread_w_reply.t option result
+
+val get_catalog : unit -> thread list result
+
+val delete : post_id -> unit result
+
+val add_post :
+     thread_id:post_id
+  -> user:user
+  -> image:img option
+  -> comment:comment
+  -> post result
+
+val add_thread :
+     subject:v_string
+  -> lat:float
+  -> lng:float
+  -> user:user
+  -> image:img option
+  -> comment:comment
+  -> Thread_w_reply.t result

src/db_user.ml

@@ -0,0 +1,125 @@
+open Syntax
+open Types
+open Caqti_request.Infix
+open Caqti_type
+open Caqti_db
+
+let () =
+  let tables =
+    [| (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
+          TEXT, email TEXT, bio TEXT, PRIMARY KEY(user_id))"
+    |]
+  in
+  Array.iter (fun query -> Db.exec_unsafe query ()) tables
+
+let get_password_hash =
+  Db.find @@ (string ->! string) "SELECT password FROM user WHERE user_id=?"
+
+let upload_user =
+  Db.exec
+  @@ (t5 string string string string string ->. unit)
+       "INSERT INTO user VALUES (?, ?, ?, ?, ?)"
+
+let update_bio =
+  Db.exec @@ (t2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
+
+let update_nick =
+  Db.exec
+  @@ (t2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
+
+let update_email =
+  Db.exec
+  @@ (t2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
+
+let update_password_hash =
+  Db.exec
+  @@ (t2 string string ->. unit) "UPDATE user SET password=? WHERE user_id=?"
+
+let delete_user =
+  Db.exec @@ (string ->. unit) "DELETE FROM user WHERE user_id=?"
+
+let find =
+  Db.find_opt
+  @@
+  (* there is no "tup6" *)
+  (string ->! t5 string string string string string)
+    "SELECT * FROM user WHERE user_id=?"
+
+let find_of_nick =
+  Db.find_opt
+  @@ (string ->! t5 string string string string string)
+       "SELECT * FROM user WHERE nick=?"
+
+let find_of_email =
+  Db.find_opt
+  @@ (string ->! t5 string string string string string)
+       "SELECT * FROM user WHERE email=?"
+
+(* ----- *)
+
+let find_user_private_aux f s =
+  let* opt = f s in
+  match opt with
+  | None -> Ok None
+  | Some (user_id, user_nick, _password, email, bio) ->
+    let+ avatar_info = Db_image.U.info user_id in
+    let user_is_admin = List.mem user_nick Config_serv.admin_l in
+    Some
+      User_private.
+        { user_id; user_nick; user_is_admin; bio; avatar_info; email }
+
+let private_to_public u =
+  let User_private.
+        { user_id; user_nick; user_is_admin; bio; avatar_info; email = _ } =
+    u
+  in
+  { user_id; user_nick; user_is_admin; bio; avatar_info }
+
+let find_user_aux f s =
+  let+ opt = find_user_private_aux f s in
+  Option.map private_to_public opt
+
+let find_user_of_nick s =
+  Db.do_transaction @@ fun () ->
+  let s : v_string = s in
+  find_user_aux find_of_nick (s :> string)
+
+let find_user_of_email s =
+  Db.do_transaction @@ fun () ->
+  let s : v_string = s in
+  find_user_aux find_of_email (s :> string)
+
+let find_user id = Db.do_transaction @@ fun () -> find_user_aux find id
+
+let find_user_private id =
+  Db.do_transaction @@ fun () -> find_user_private_aux find id
+
+let get_password_hash id = Db.do_transaction @@ fun () -> get_password_hash id
+
+let update_nick user_id s =
+  Db.do_transaction @@ fun () ->
+  let s : v_string = s in
+  update_nick ((s :> string), user_id)
+
+let update_bio user_id s =
+  Db.do_transaction @@ fun () ->
+  let s : v_string = s in
+  update_bio ((s :> string), user_id)
+
+let update_email user_id s =
+  Db.do_transaction @@ fun () ->
+  let s : v_string = s in
+  update_email ((s :> string), user_id)
+
+let update_password_hash user_id password_hash =
+  Db.do_transaction @@ fun () -> update_password_hash (password_hash, user_id)
+
+let add_user ~email ~nick ~password_hash =
+  Db.do_transaction @@ fun () ->
+  let email : v_string = email in
+  let nick : v_string = nick in
+  let user_id = Util.gen_uuid () in
+  upload_user (user_id, (nick :> string), password_hash, (email :> string), "")
+
+let delete_user user_id = Db.do_transaction @@ fun () -> delete_user user_id

src/db_user.mli

@@ -0,0 +1,25 @@
+open Err
+open Types
+
+val find_user : user_id -> user option result
+
+val find_user_of_nick : v_string -> user option result
+
+val find_user_of_email : v_string -> user option result
+
+val find_user_private : user_id -> User_private.t option result
+
+val get_password_hash : user_id -> string result
+
+val update_password_hash : user_id -> string -> unit result
+
+val update_nick : user_id -> v_string -> unit result
+
+val update_bio : user_id -> v_string -> unit result
+
+val update_email : user_id -> v_string -> unit result
+
+val delete_user : user_id -> unit result
+
+val add_user :
+  email:v_string -> nick:v_string -> password_hash:string -> unit result

src/delete_page.eml.html

@@ -1,20 +0,0 @@
-let f post_preview post_id request =
-
-<script type="text/javascript" src="/assets/js/catalog.js" defer="defer"></script>
-      <%s! post_preview %>
-% let url = Format.sprintf "/delete/%s" post_id in
-% begin match Dream.session "nick" request with
-% | None ->
-% let redirect = Dream.to_percent_encoded url in
-  <a href="/login?redirect=<%s redirect%>">Login</a> to delete your post.
-% | Some _nick ->
-  <div class="row mb-3">
-    <div class="col-md-6" id="delete-form">
-      <div class="postForm">
-<%s! Dream.form_tag ~action:url request %>
-          <button type="submit" class="btn btn-primary">DELETE</button>
-        </form>
-      </div>
-    </div>
-  </div>
-% end;

src/discuss.ml

@@ -1,129 +0,0 @@
-open Syntax
-
-(** Creating the table of all messages.
-
-    Each message is made of :
-
-    - an id (msg_id)
-    - the id of the sender (from_id)
-    - the id of the receiver (to_id)
-    - some text (msg)
-
-    TODO: add date ? *)
-
-module Q = struct
-  open Caqti_request.Infix
-  open Caqti_type
-
-  let create_msg_table =
-    Db.exec
-    @@ (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS msg ( msg_id TEXT, from_id TEXT, to_id \
-          TEXT, msg TEXT, PRIMARY KEY(msg_id), FOREIGN KEY(from_id) REFERENCES \
-          user(user_id) ON DELETE CASCADE, FOREIGN KEY(to_id) REFERENCES \
-          user(user_id) ON DELETE CASCADE)"
-
-  let find_comrades =
-    Db.collect_list
-    @@ (tup2 string string ->* tup2 string string)
-         "SELECT from_id, to_id FROM msg WHERE from_id=? OR to_id=?"
-
-  let find_messages =
-    Db.collect_list
-    @@ (tup2 (tup2 string string) (tup2 string string) ->* tup2 string string)
-         "SELECT from_id, msg FROM msg WHERE (from_id=? AND to_id=?) OR \
-          (from_id=? AND to_id=?)"
-
-  let insert_msg =
-    Db.exec
-    @@ (tup3 string string string ->. unit)
-         "INSERT INTO msg VALUES (NULL, ?, ?, ?)"
-end
-
-let () =
-  Result.iter_error
-    (fun _e -> Dream.error (fun log -> log "can't create table"))
-    (Q.create_msg_table ())
-
-(** let's find who the user is talking to so we can know if they're dangerous *)
-let find_comrades user_id =
-  let* comrades = Q.find_comrades (user_id, user_id) in
-  let comrades =
-    List.map (fun (l, r) -> if l = user_id then r else l) comrades
-  in
-  Ok (List.sort_uniq String.compare comrades)
-
-(** find all messages between two товарищи *)
-let find_messages k1 k2 = Q.find_messages ((k1, k2), (k2, k1))
-
-(** display the list of discussions *)
-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
-  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)
-         (Dream.html_escape 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) )
-
-(** display one discussion *)
-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 = Q.insert_msg (from_id, to_id, msg)
-
-(** handle posts *)
-let post 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
-      | form -> Utils.handle_invalid_form form )

src/dune

@@ -1,30 +1,33 @@
 (executable
  (public_name permap)
- (modules
-  app
-  babillard
-  babillard_page
-  catalog_page
-  content
-  db
-  delete_page
-  discuss
-  image
-  emojid
-  login
-  permap
-  post_form
-  pp_babillard
-  register
-  report_page
-  syntax
-  template
-  thread_page
-  user
-  user_account
-  user_profile
-  utils)
+ (modules permap)
+ (package permap)
  (libraries
+  config_serv_impl ; implements config_serv
+  config_impl ; implements config
+  shared
+  permap
+  ;;
+  dream
+  fmt
+  fpath
+  uri
+  prelude)
+ (preprocess
+  (pps lwt_ppx))
+ (flags
+  (:standard -open Prelude)))
+
+(library
+ (name permap)
+ (wrapped false)
+ (modules :standard \ permap json_data syntax types err validate_str)
+ (libraries
+  config_serv ; virtual
+  config ; virtual
+  shared ; virtual
+  comment
+  ;;
   bos
   caqti
   caqti.blocking
@@ -32,97 +35,43 @@
   conan
   conan.string
   conan-database.light
-  containers-data
-  directories
+  digestif
   dream
   dream-pure
   emile
-  emoji
-  fpath
-  lambdasoup
-  omd
+  fmt
+  htmlit
   safepass
-  scfg
-  uri
   uuidm
-  yojson)
+  unix
+  prelude)
  (preprocess
-  (pps lwt_ppx)))
+  (pps lwt_ppx))
+ (flags
+  (:standard -open Prelude)))
+
+(library
+ (name shared)
+ (wrapped false)
+ (modules json_data syntax types err validate_str)
+ (modules_without_implementation types)
+ (libraries
+  config ; virtual
+  comment
+  ;;
+  lwt
+  data-encoding
+  fmt
+  prelude)
+ (flags
+  (:standard -open Prelude)))
 
 (rule
- (targets babillard_page.ml)
- (deps babillard_page.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets catalog_page.ml)
- (deps catalog_page.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets delete_page.ml)
- (deps delete_page.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets login.ml)
- (deps login.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets post_form.ml)
- (deps post_form.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets register.ml)
- (deps register.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets report_page.ml)
- (deps report_page.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets template.ml)
- (deps template.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets thread_page.ml)
- (deps thread_page.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets user_account.ml)
- (deps user_account.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (targets user_profile.ml)
- (deps user_profile.eml.html)
- (action
-  (run dream_eml %{deps} --workspace %{workspace_root})))
-
-(rule
- (target content.ml)
+ (target assets.ml)
  (deps
-  (source_tree content)
-  (file content/assets/js/babillard.js)
-  (file content/assets/js/catalog.js)
-  (file content/assets/js/thread.js))
+  (source_tree assets)
+  (file assets/js/client.js))
  (action
   (with-stdout-to
    %{null}
-   (run ocaml-crunch -m plain content -o %{target}))))
+   (run ocaml-crunch -m plain assets -o %{target}))))

src/emojid.ml

@@ -1,86 +0,0 @@
-open Syntax
-open Caqti_request.Infix
-open Caqti_type
-
-(* todo better: make emojid just string and not string list in this module;
-   problem is we have to split on unicode *)
-
-module Q = struct
-  (* we save emojid in a string with emoji separated by '-' *)
-  let upload_emojid uuid emojid =
-    let emojid = String.concat "-" emojid in
-    Db.exec
-      ((tup2 string string ->. unit) "INSERT INTO uuid_emojid VALUES (?,?)")
-      (uuid, emojid)
-
-  let get_emojid uuid =
-    Db.find
-      ((string ->! string) "SELECT emojid FROM uuid_emojid WHERE uuid=?")
-      uuid
-    |> Result.map (String.split_on_char '-')
-
-  let get_all_emojid () =
-    let* l =
-      Db.collect_list ((unit ->* string) "SELECT emojid FROM uuid_emojid") ()
-    in
-    Ok (List.map (String.split_on_char '-') l)
-end
-
-module Trie = CCTrie.Make (struct
-  type t = string list
-
-  type char_ = string
-
-  let compare = String.compare
-
-  let to_iter o f = List.iter f o
-
-  let of_list = Fun.id
-end)
-
-let max_emojid_lenght = 16
-
-let alphabet =
-  Array.append Emoji.category_animals_and_nature Emoji.category_food_and_drink
-
-let trie =
-  let tables =
-    [| (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS uuid_emojid (uuid TEXT, emojid TEXT)"
-    |]
-  in
-  if
-    Array.exists Result.is_error
-      (Array.map (fun query -> Db.exec query ()) tables)
-  then failwith "can't create emojid's tables"
-  else
-    match Q.get_all_emojid () with
-    | Error e ->
-      failwith (Format.sprintf "Error with Emojid.Q.select_all: %s" e)
-    | Ok l ->
-      let l = List.map (fun e -> (e, ())) l in
-      ref (Trie.of_list l)
-
-let make uuid =
-  (* pick a list of emojis *)
-  let random_emojis =
-    List.init max_emojid_lenght (fun _i ->
-        let n = Random.int (Array.length alphabet) in
-        Array.get alphabet n )
-  in
-  (* pick the smallest emojid possible *)
-  let longest_prefix = Trie.longest_prefix random_emojis !trie in
-  (* add one more emoji to longest_prefix *)
-  match List.nth_opt random_emojis (List.length longest_prefix) with
-  | None ->
-    Dream.error (fun log -> log "Emojid error: longest prefix is too long");
-    Error "Could not create emojid"
-  | Some x ->
-    let emojid = longest_prefix @ [ x ] in
-    let* () = Q.upload_emojid uuid emojid in
-    trie := Trie.add emojid () !trie;
-    Ok (String.concat "" emojid)
-
-let get uuid =
-  let* l = Q.get_emojid uuid in
-  Ok (String.concat "" l)

src/emojid.mli

@@ -1,5 +0,0 @@
-(** [make uuid] creates an emojid for [uuid]; hopefully returns [Ok emojid] *)
-val make : string -> (string, string) result
-
-(** [get uuid] is [Ok emoji] if [uuid] has an emojid *)
-val get : string -> (string, string) result

src/err.ml

@@ -0,0 +1,46 @@
+type internal_err =
+  | No_msg (* used to not expose detail to client *)
+  | Db of string
+  | Db_not_found of string
+  | Bos of string
+  | Conan of string
+
+type t =
+  | Internal of internal_err
+  (* error due to client *)
+  | Bad_form
+  | Bad_form_suspicious
+  | Unauthorized
+  | Unauthorized_login of string
+  | Forbidden
+  | Not_found
+  | Not_found_thread of int
+  | Not_found_post of int
+  | Not_found_user of string
+  | Not_found_image of int
+  | Unprocessable of string
+
+type nonrec 'a result = ('a, t) result
+
+let pp_internal fmt = function
+  | No_msg -> Fmt.pf fmt "no msg"
+  | Db s -> Fmt.pf fmt "db: %s" s
+  | Db_not_found s -> Fmt.pf fmt "db (not found): %s" s
+  | Bos s -> Fmt.pf fmt "bos: %s" s
+  | Conan s -> Fmt.pf fmt "conan: %s" s
+
+let pp fmt = function
+  | Internal e -> Fmt.pf fmt "%a" pp_internal e
+  | Bad_form -> Fmt.pf fmt "bad form"
+  | Bad_form_suspicious -> Fmt.pf fmt "bad form suspicious"
+  | Unauthorized -> Fmt.pf fmt "unauthorized"
+  | Unauthorized_login s -> Fmt.pf fmt "unauthorized login: %s" s
+  | Forbidden -> Fmt.pf fmt "forbidden"
+  | Not_found -> Fmt.pf fmt "not found"
+  | Not_found_thread s -> Fmt.pf fmt "thread not found: %d" s
+  | Not_found_post s -> Fmt.pf fmt "post not found: %d" s
+  | Not_found_user s -> Fmt.pf fmt "user not found: %s" s
+  | Not_found_image s -> Fmt.pf fmt "image not found: %d" s
+  | Unprocessable s -> Fmt.pf fmt "unprocessable: %s" s
+
+let hide_internal_err_detail = function Internal _ -> Internal No_msg | e -> e

src/html.ml

@@ -0,0 +1,35 @@
+open Htmlit
+
+let page_to_string page = Htmlit.El.to_string ~doctype:true page
+
+let page_of_res res =
+  let res_str, msg =
+    match res with Error msg -> ("Error", msg) | Ok msg -> ("Ok", msg)
+  in
+  let title = Fmt.str "%s: %s" res_str msg in
+  let content = El.div [ El.h1 [ El.txt res_str ]; El.p [ El.txt msg ] ] in
+  let page =
+    El.page ~lang:"en" ~styles:[] ~scripts:[] ~more_head:El.void ~title content
+  in
+  page
+
+(* TODO have a loading animation *)
+let app_start_page =
+  let title = "Permap" in
+  let body = El.body [] in
+  let styles =
+    let leaflet_style = "/assets/css/leaflet.css" in
+    let style = "/assets/css/style.css" in
+    [ leaflet_style; style ]
+  in
+  let more_head =
+    let icon =
+      El.link
+        ~at:At.[ rel "icon"; type' "image/png"; href "/assets/img/favicon.png" ]
+        ()
+    in
+    icon
+  in
+  let scripts = [ "/assets/js/client.js" ] in
+  let page = El.page ~lang:"en" ~styles ~scripts ~more_head ~title body in
+  page

src/html.mli

@@ -0,0 +1,7 @@
+open Htmlit.El
+
+val page_to_string : html -> string
+
+val page_of_res : (string, string) result -> html
+
+val app_start_page : html

src/image.ml

@@ -1,163 +1,87 @@
 open Syntax
-open Caqti_request.Infix
-open Caqti_type
+open Err
+open Types
 
-type t =
-  { name : string
-  ; alt : string
-  ; content : string
-  ; thumbnail : string
-  }
+let read_mime =
+  let database = Conan.Process.database ~tree:Conan_light.tree in
+  fun data ->
+    try
+      match Conan_string.run ~database data with
+      | Error (`Msg e) -> Error (Internal (Conan e))
+      | Ok m -> (
+        match Conan.Metadata.mime m with
+        | None -> Error (Unprocessable "no mime found")
+        | Some mime ->
+          (* Case Closed ~~! *)
+          Ok mime )
+    with _ ->
+      (* conan is still experimental and can leak exceptions *)
+      Error (Internal (Conan "conan error"))
 
-let () =
-  let tables =
-    [| (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS image_info (post_id TEXT, image_name \
-          TEXT, image_alt TEXT, FOREIGN KEY(post_id) REFERENCES \
-          post_user(post_id) ON DELETE CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS image_content (post_id TEXT, content \
-          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
-          CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS image_thumbnail (post_id TEXT, content \
-          TEXT, FOREIGN KEY(post_id) REFERENCES post_user(post_id) ON DELETE \
-          CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS user_image_content (user_id TEXT, content \
-          TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE \
-          CASCADE)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS user_image_thumbnail (user_id TEXT, \
-          content TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON \
-          DELETE CASCADE)"
-    |]
-  in
-  if
-    Array.exists Result.is_error
-      (Array.map (fun query -> Db.exec query ()) tables)
-  then Dream.error (fun log -> log "can't create images tables")
-
-let upload_info =
-  Db.exec
-  @@ (tup3 string string string ->. unit)
-       "INSERT INTO image_info VALUES (?,?,?)"
-
-let upload_content =
-  Db.exec
-  @@ (tup2 string string ->. unit) "INSERT INTO image_content VALUES (?,?)"
-
-let upload_thumbnail =
-  Db.exec
-  @@ (tup2 string string ->. unit) "INSERT INTO image_thumbnail VALUES (?,?)"
-
-let get_content =
-  Db.find_opt
-  @@ (string ->? string) "SELECT content FROM image_content WHERE post_id=?"
-
-let get_thumbnail =
-  Db.find_opt
-  @@ (string ->? string) "SELECT content FROM image_thumbnail WHERE post_id=?"
-
-let get_info =
-  Db.find_opt
-  @@ (string ->? tup2 string string)
-       "SELECT image_name,image_alt FROM image_info WHERE post_id=?"
-
-let upload_user_content =
-  Db.exec
-  @@ (tup2 string string ->. unit) "INSERT INTO user_image_content VALUES (?,?)"
-
-let upload_user_thumbnail =
-  Db.exec
-  @@ (tup2 string string ->. unit)
-       "INSERT INTO user_image_thumbnail VALUES (?,?)"
-
-let get_user_content =
-  Db.find_opt
-  @@ (string ->? string)
-       "SELECT content FROM user_image_content WHERE user_id=?"
-
-let get_user_thumbnail =
-  Db.find_opt
-  @@ (string ->? string)
-       "SELECT content FROM user_image_thumbnail WHERE user_id=?"
-
-let delete_user_content =
-  Db.exec @@ (string ->. unit) "DELETE FROM user_image_content WHERE user_id=?"
-
-let delete_user_thumbnail =
-  Db.exec
-  @@ (string ->. unit) "DELETE FROM user_image_thumbnail WHERE user_id=?"
-
-let upload image id =
-  let* () = upload_info (id, image.name, image.alt) in
-  let* () = upload_content (id, image.content) in
-  upload_thumbnail (id, image.thumbnail)
-
-let upload_avatar image id =
-  let* () = delete_user_content id in
-  let* () = delete_user_thumbnail id in
-  let* () = upload_user_content (id, image.content) in
-  upload_user_thumbnail (id, image.thumbnail)
-
-let make_thumbnail content =
+let magick =
   let open Bos in
-  (* jpp *)
-  let ( let* ) o f =
-    Result.fold ~ok:f ~error:(function `Msg s -> Result.error s) o
+  let strip_exif file =
+    let cmd = Cmd.(v "magick" % p file % "-strip" % p file) in
+    OS.Cmd.(run cmd)
   in
-
-  let* image_file = OS.File.tmp "%s" in
-  let* thumb_file = OS.File.tmp "%s_thumb" in
-  let* () = OS.File.write image_file content in
+  let make_thumbnail in_file out_file =
     let cmd =
       Cmd.(
-      v "convert" % "-define" % "jpeg:size=700x700" % p image_file
+        v "magick" % "-define" % "jpeg:size=700x700" % p in_file
         % "-auto-orient" % "-thumbnail" % "300x300>" % "-unsharp" % "0x.5"
-      % "-format" % "jpg" % p thumb_file )
+        % "-format" % "jpg" % p out_file )
     in
-  let* () = OS.Cmd.run cmd in
+    OS.Cmd.run cmd
+  in
+  let read_dimension file =
+    let cmd = Cmd.(v "magick" % "identify" % "-format" % "%w#%h" % p file) in
+    let* s = OS.Cmd.(run_out cmd |> out_string |> success) in
+    match String.split_on_char '#' s |> List.map int_of_string_opt with
+    | [] -> assert false
+    | [ Some w; Some h ] -> Ok (w, h)
+    | _ -> Fmt.error_msg "magick identify, invalid format"
+  in
+  fun data ->
+    Result.map_error (function `Msg s -> Internal (Bos s))
+    @@
+    let* image_file = OS.File.tmp "%s" in
+    let* thumb_file = OS.File.tmp "%s_thumb" in
+    let res =
+      let* () = OS.File.write image_file data in
+      let* () = strip_exif image_file in
+      let* () = make_thumbnail image_file thumb_file in
+      let* image = OS.File.read image_file in
       let* thumbnail = OS.File.read thumb_file in
+      let* img_dim = read_dimension image_file in
+      let* thumb_dim = read_dimension thumb_file in
+      Ok ((image, img_dim), (thumbnail, thumb_dim))
+    in
     let* () = OS.File.delete image_file in
     let* () = OS.File.delete thumb_file in
-  Ok thumbnail
+    res
 
-let mime =
-  let database = Conan.Process.database ~tree:Conan_light.tree in
-  fun content ->
-    match Conan_string.run ~database content with
-    | Ok m -> Conan.Metadata.mime m
-    | Error _ -> None
-
-let make_image image =
-  let max_name = 1000 in
-  let max_alt = 3000 in
-  let max_content = 4200000 in
-
-  let name, alt, content = image in
-  let name =
-    match name with
-    | Some name -> Dream.html_escape name
-    | None ->
-      (* make up random name if no name was given *)
-      Uuidm.to_string (Uuidm.v4_gen App.random_state ())
-  in
-  let alt = if String.trim alt = "" then name else alt in
-  if String.length name > max_name then
-    Error (Format.sprintf "Image name too long: More than %dB" max_name)
-  else if String.length alt > max_alt then
-    Error (Format.sprintf "Image description too long: More than %dB" max_alt)
-  else if String.length content > max_content then
-    Error (Format.sprintf "Image size too big: More than %dB" max_content)
+let build ~name ~alt data =
+  let* name = Validate_str.image_name name in
+  let* alt = Validate_str.image_alt alt in
+  let* () =
+    let data_len = String.length data in
+    if data_len <= Config.image_max_size then Ok ()
     else
-    match mime content with
-    | None -> Error "invalid image type"
-    | Some mime -> (
-      match mime with
-      | "image/jpeg" | "image/png" | "image/webp" | "image/gif" -> (
-        match make_thumbnail content with
-        | Error e -> Error e
-        | Ok thumbnail -> Ok { name; alt; content; thumbnail } )
-      | _unsupported_mime_type ->
-        Error (Format.sprintf "unsupported image type: %s" mime) )
+      let s =
+        Fmt.str "Image is too big (%a), maximum size is %a" Fmt.bi_byte_size
+          data_len Fmt.bi_byte_size Config.image_max_size
+      in
+      Error (Unprocessable s)
+  in
+  let* mime = read_mime data in
+  let* () =
+    match Array.mem mime Config.supported_mime_type with
+    | true -> Ok ()
+    | false -> Error (Unprocessable (Fmt.str "unsupported image type: %s" mime))
+  in
+  let+ (data, (w, h)), (thumbnail_data, (thumb_w, thumb_h)) = magick data in
+  let md5 = Digestif.MD5.(to_hex (digest_string data)) in
+  let info =
+    { md5; mime; w; h; thumb_w; thumb_h; name :> string; alt :> string }
+  in
+  { info; data; thumbnail_data }

src/image.mli

@@ -0,0 +1,5 @@
+open Err
+open Types
+
+(* validate data, make thumbnail *)
+val build : name:string -> alt:string -> string -> img result

src/js/babillard.ml

@@ -1,124 +0,0 @@
-open Brr
-open Utils
-open Map
-
-module Visibility = struct
-  let new_thread_div = find_by_id "new-thread"
-
-  let thread_comment = find_by_id "comment"
-
-  let thread_preview_div = find_by_id "thread-preview"
-
-  let return_button = find_by_id "return-button"
-
-  (* new-thread-button is new-thread-button-redirect if not logged in *)
-  let new_thread_button = find_by_id_opt "new-thread-button"
-
-  let is_in_new_thread_mode = ref false
-
-  let set_visible el =
-    log "set_visible@\n";
-    El.set_class (Jstr.of_string "off") false el
-
-  let set_invisible el =
-    log "set_invisible@\n";
-    El.set_class (Jstr.of_string "off") true el
-
-  let to_new_thread_mode _event =
-    log "change_page_mode@\n";
-    is_in_new_thread_mode := true;
-    set_visible new_thread_div;
-    set_visible return_button;
-    set_invisible thread_preview_div;
-    Option.iter set_invisible new_thread_button;
-    El.set_has_focus true thread_comment;
-    Leaflet.Map.close_popup ~popup:None map
-
-  let to_babillard_mode _event =
-    log "change_page_mode@\n";
-    is_in_new_thread_mode := false;
-    set_invisible new_thread_div;
-    set_invisible return_button;
-    set_visible thread_preview_div;
-    Option.iter set_visible new_thread_button;
-    Leaflet.Map.close_popup ~popup:None map
-
-  let () =
-    log "add events on return/new thread button@\n";
-    let (_ : Ev.listener) =
-      Ev.listen Ev.click to_babillard_mode (El.as_target return_button)
-    in
-    Option.iter
-      (fun button ->
-        let (_ : Ev.listener) =
-          Ev.listen Ev.click to_new_thread_mode (El.as_target button)
-        in
-        () )
-      new_thread_button
-end
-
-module Marker = struct
-  let thread_preview_div = find_by_id "thread-preview"
-
-  let marker_on_click thread_preview _e =
-    log "marker_on_click@\n";
-    if not !Visibility.is_in_new_thread_mode then (
-      let inner_html = El.Prop.jstr (Jstr.of_string "innerHTML") in
-      El.set_prop inner_html thread_preview thread_preview_div;
-      Pretty_post.make_pretty () )
-
-  let on_each_feature feature layer =
-    log "on_each_feature@\n";
-    let feature_properties = Jv.get feature "properties" in
-    let thread_preview = Jv.get feature_properties "content" |> Jv.to_jstr in
-    Leaflet.Layer.on Leaflet.Event.Click (marker_on_click thread_preview) layer
-
-  let handle_geojson geojson =
-    log "handle_geojson@\n";
-    let layer =
-      Leaflet.Layer.create_geojson geojson [ On_each_feature on_each_feature ]
-    in
-    let _marker_layer = Leaflet.Layer.add_to map layer in
-    ()
-
-  let markers_handle_response response =
-    log "markers_handle_response@\n";
-    let geo_json_list_futur = Jv.call response "json" [||] in
-    ignore @@ Jv.call geo_json_list_futur "then" [| Jv.repr handle_geojson |]
-
-  let () =
-    log "fetch thread geojson@\n";
-    let link = Jv.of_string "/markers" in
-    (* todo: fetch with Brr *)
-    let window = Jv.get Jv.global "window" in
-    let fetchfutur = Jv.call window "fetch" [| link |] in
-    ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |]
-end
-
-let lat_input = find_by_id "lat-input"
-
-let lng_input = find_by_id "lng-input"
-
-let button = find_by_id "submit-button"
-
-(* set input lat/lng when clicked*)
-let on_click_set_latlng e =
-  log "on_click_set_latlng@\n";
-  if !Visibility.is_in_new_thread_mode then (
-    let latlng = Leaflet.Event.latlng e in
-    let popup =
-      Leaflet.Popup.create ~content:(Some "create thread here")
-        ~latlng:(Some latlng) []
-    in
-    Leaflet.Map.open_popup popup map;
-
-    (* TODO add a marker with special icon here *)
-    let lat = Leaflet.Latlng.lat latlng |> Jstr.of_float in
-    let lng = Leaflet.Latlng.lng latlng |> Jstr.of_float in
-    let value_jstr = Jstr.of_string "value" in
-    El.set_at value_jstr (Some lat) lat_input;
-    El.set_at value_jstr (Some lng) lng_input;
-    El.set_at (Jstr.of_string "disabled") None button )
-
-(*add on_click callback to map*)
-let () = Leaflet.Map.on Leaflet.Event.Click on_click_set_latlng map

src/js/dune

@@ -1,51 +0,0 @@
-(library
- (name utils)
- (modules utils)
- (libraries brr)
- (preprocess
-  (pps js_of_ocaml-ppx)))
-
-(library
- (name post_form)
- (modules post_form)
- (libraries js_of_ocaml brr utils)
- (preprocess
-  (pps js_of_ocaml-ppx)))
-
-(library
- (name pretty_post)
- (modules pretty_post)
- (libraries js_of_ocaml brr unix utils)
- (preprocess
-  (pps js_of_ocaml-ppx)))
-
-(library
- (name map)
- (modules map)
- (libraries js_of_ocaml brr leaflet utils)
- (preprocess
-  (pps js_of_ocaml-ppx)))
-
-(executable
- (name catalog)
- (modules catalog)
- (libraries js_of_ocaml brr pretty_post)
- (modes js)
- (preprocess
-  (pps js_of_ocaml-ppx)))
-
-(executable
- (name babillard)
- (modules babillard)
- (libraries js_of_ocaml brr map post_form pretty_post leaflet utils)
- (modes js)
- (preprocess
-  (pps js_of_ocaml-ppx)))
-
-(executable
- (name thread)
- (modules thread)
- (libraries js_of_ocaml brr post_form pretty_post)
- (modes js)
- (preprocess
-  (pps js_of_ocaml-ppx)))

src/js/map.ml

@@ -1,99 +0,0 @@
-open Utils
-
-let map = Leaflet.Map.create_on "map"
-
-let () =
-  let osm_layer = Leaflet.Layer.create_tile_osm None in
-  Leaflet.Layer.add_to map osm_layer
-
-let storage = Brr_io.Storage.local Brr.G.window
-
-(* set map's view *)
-(* try to set map's view to last position viewed by using web storage *)
-let () =
-  log "setting view@\n";
-  let lat = Brr_io.Storage.get_item storage (Jstr.of_string "lat") in
-  let lng = Brr_io.Storage.get_item storage (Jstr.of_string "lng") in
-  let zoom = Brr_io.Storage.get_item storage (Jstr.of_string "zoom") in
-  match (lat, lng, zoom) with
-  | Some lat, Some lng, Some zoom ->
-    let lat = Jstr.to_float lat in
-    let lng = Jstr.to_float lng in
-    let zoom =
-      match Jstr.to_int zoom with
-      | None -> failwith "view storage bug"
-      | Some zoom -> Some zoom
-    in
-    let latlng = Leaflet.Latlng.create lat lng in
-    ignore @@ Leaflet.Map.set_view latlng ~zoom map
-  | _ ->
-    let latlng = Leaflet.Latlng.create 51.505 (-0.09) in
-    ignore @@ Leaflet.Map.set_view latlng ~zoom:(Some 13) map
-
-let on_moveend _event =
-  log "on moveend event@\n";
-  let latlng = Leaflet.Map.get_center map in
-  (*we need to wrap coordinates so we don't drift into a parralel universe and lose track of markers :^) *)
-  let wrapped_latlng = Leaflet.Map.wrap_latlng latlng map in
-  let lat = Leaflet.Latlng.lat latlng |> Jv.of_float |> Jv.to_jstr in
-  let lng = Leaflet.Latlng.lng latlng |> Jv.of_float |> Jv.to_jstr in
-  match Brr_io.Storage.set_item storage (Jstr.of_string "lat") lat with
-  | (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
-  | Ok () -> (
-    match Brr_io.Storage.set_item storage (Jstr.of_string "lng") lng with
-    | (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
-    | Ok () ->
-      let is_wrapped = not @@ Leaflet.Latlng.equals latlng wrapped_latlng in
-      if is_wrapped then (
-        log "setView to wrapped coordinate@\n";
-        (* warning: calling setView in on_moveend can cause recursion *)
-        Leaflet.Map.set_view wrapped_latlng ~zoom:None map ) )
-
-let on_zoomend _event =
-  log "on zoomend event@\n";
-  let zoom = Leaflet.Map.get_zoom map in
-  match
-    Brr_io.Storage.set_item storage (Jstr.of_string "zoom") (Jstr.of_int zoom)
-  with
-  | (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
-  | Ok () -> ()
-
-let () =
-  log "add on (move/zoom)end event@\n";
-  Leaflet.Map.on Leaflet.Event.Move_end on_moveend map;
-  Leaflet.Map.on Leaflet.Event.Zoom_end on_zoomend map
-
-module Geolocalize = struct
-  let update_location geo =
-    log "update_location@\n";
-    match geo with
-    | Error _ -> failwith "error in geolocation"
-    | Ok geo ->
-      let lat = Brr_io.Geolocation.Pos.latitude geo in
-      let lng = Brr_io.Geolocation.Pos.longitude geo in
-      let latlng = Leaflet.Latlng.create lat lng in
-      Leaflet.Map.set_view latlng ~zoom:(Some 13) map
-
-  let geolocalize _ =
-    log "geolocalize@\n";
-    let update_location geo =
-      log "update_location@\n";
-      match geo with
-      | Error e ->
-        (* todo: popup error message for user *)
-        log "geolocation failure: %s@\n"
-        @@ Jstr.to_string
-        @@ Brr_io.Geolocation.Error.message e
-      | Ok geo ->
-        (* todo: add a special marker to map *)
-        let lat = Brr_io.Geolocation.Pos.latitude geo in
-        let lng = Brr_io.Geolocation.Pos.longitude geo in
-        let latlng = Leaflet.Latlng.create lat lng in
-        Leaflet.Map.set_view latlng ~zoom:(Some 17) map
-    in
-
-    let l = Brr_io.Geolocation.of_navigator Brr.G.navigator in
-    let opts = Brr_io.Geolocation.opts ~high_accuracy:true () in
-    (* todo: use `Geolocation.watch` instead ? it may improve precision *)
-    ignore @@ Fut.await (Brr_io.Geolocation.get l ~opts) update_location
-end

src/js/newthread.ml

@@ -1,3 +0,0 @@
-open Js_map
-
-let log = Format.printf

src/js/post_form.ml

@@ -1,52 +0,0 @@
-open Brr
-open Utils
-
-(* called by clicking post_id *)
-(* insert emojid into reply form *)
-let insert_quote el _event =
-  log "quote@\n";
-  let emojid =
-    match El.at (Jstr.of_string "data-emojid") el with
-    | None -> failwith "no data-emojid on element"
-    | Some emojid -> Jstr.to_string emojid
-  in
-  match find_by_id_opt "comment" with
-  | None -> log "element `comment` not found, not logged in?@\n"
-  | Some textarea ->
-    let value = El.Prop.value in
-    let content = Jstr.to_string @@ El.prop value textarea in
-    let new_content =
-      if String.ends_with ~suffix:"\n" content || String.length content = 0 then
-        (* don't skip a line *)
-        Format.sprintf "%s[>%s] " content emojid
-      else Format.sprintf "%s@\n[>%s] " content emojid
-    in
-    El.set_prop value (Jstr.of_string new_content) textarea;
-    El.set_has_focus true textarea
-
-(* make image description field visible when a file is selected*)
-let make_visible el _event = El.set_class (Jstr.of_string "off") false el
-
-let add_events _load =
-  log "add post_form events @\n";
-  match find_by_id_opt "file" with
-  | None -> log "element `file` not found, not logged in?@\n"
-  | Some file_input ->
-    let alt_input = find_by_id "alt" in
-    let alt_label = find_by_id "alt-label" in
-    let change = Ev.Type.create (Jstr.of_string "change") in
-    let (_ : Ev.listener) =
-      Ev.listen change (make_visible alt_input) (El.as_target file_input)
-    in
-    let (_ : Ev.listener) =
-      Ev.listen change (make_visible alt_label) (El.as_target file_input)
-    in
-    log "add inser_quote event on post links@\n";
-    add_event_to_class Ev.click "quote-link" insert_quote
-
-(*make events after page load*)
-let () =
-  let (_ : Ev.listener) =
-    Ev.listen Ev.load add_events (Window.as_target G.window)
-  in
-  ()

src/js/pretty_post.ml

@@ -1,203 +0,0 @@
-open Brr
-open Utils
-
-type image_size =
-  | Big
-  | Small
-
-let of_string = function
-  | "post-image" -> Some Small
-  | "post-image-big" -> Some Big
-  | _ -> None
-
-let to_string = function Small -> "post-image" | Big -> "post-image-big"
-
-(*change postImage class to make it bigger/smaller on click*)
-let image_click post_image event =
-  log "image_click@\n";
-  let class_jstr = Jstr.of_string "class" in
-  let current_class =
-    match El.at class_jstr post_image with
-    | None -> failwith "no class for post_image"
-    | Some c -> Jstr.to_string c
-  in
-  let new_class =
-    match of_string current_class with
-    | Some image_size -> ( match image_size with Big -> Small | Small -> Big )
-    | None -> failwith "invalid image class name"
-  in
-  El.set_at class_jstr (Some (Jstr.of_string (to_string new_class))) post_image;
-  let id =
-    match El.at (Jstr.of_string "data-id") post_image with
-    | None -> failwith "no data-id on post_image"
-    | Some id -> Jstr.to_string id
-  in
-  let src =
-    match new_class with
-    | Small -> Format.sprintf "/img/s/%s" id
-    | Big -> Format.sprintf "/img/%s" id
-  in
-  El.set_at (Jstr.of_string "src") (Some (Jstr.of_string src)) post_image;
-  (*prevent redirect to /img/:img*)
-  Ev.prevent_default event;
-  Ev.stop_propagation event
-
-let render_time date_span =
-  log "render time@\n";
-  let data_time =
-    match El.at (Jstr.of_string "data-time") date_span with
-    | None -> failwith "no attribute data-time for date element"
-    | Some data_time -> Jstr.to_float data_time
-  in
-  let t = Unix.localtime data_time in
-  let date =
-    Format.sprintf "%02d-%02d-%02d %02d:%02d" (1900 + t.tm_year) (1 + t.tm_mon)
-      t.tm_mday t.tm_hour t.tm_min
-  in
-  let inner_html = El.Prop.jstr (Jstr.of_string "innerHTML") in
-  El.set_prop inner_html (Jstr.of_string date) date_span
-
-let preview_ref = ref None
-
-let highlighted_ref = ref None
-
-let selected_ref = ref None
-
-let on_hashchange _event =
-  log "on hashchange";
-  let frag = Jstr.to_string @@ Uri.fragment @@ Window.location G.window in
-  if frag = "" then ()
-  else
-    match find_by_id_opt frag with
-    | None -> log "fragment not found on the page"
-    | Some reply ->
-      let () =
-        match !selected_ref with
-        | None -> ()
-        | Some item -> El.set_class (Jstr.of_string "selected") false item
-      in
-      El.set_class (Jstr.of_string "selected") true reply;
-      selected_ref := Some reply
-
-let clone_element el =
-  (* TODO: how to clone with Brr? *)
-  let id =
-    match El.at (Jstr.of_string "id") el with
-    | None -> failwith "element as no id for cloning"
-    | Some id -> Jstr.to_string id
-  in
-  (* get reply_div as a Jv.t *)
-  let original_div = Jv.get Jv.global id in
-  let div = Jv.call original_div "cloneNode" [| Jv.of_bool true |] in
-  ignore
-  @@ Jv.call div "setAttribute"
-       [| Jv.of_string "id"; Jv.of_string "floating-reply-preview" |];
-  ignore
-  @@ Jv.call div "setAttribute"
-       [| Jv.of_string "class"; Jv.of_string "post highlight" |];
-
-  (* append to DOM *)
-  (* we needs to add it to `body` and not `original_div` or it might change the display
-   * and do buggy things with mouse events on `original_div`*)
-  let document = Jv.get Jv.global "document" in
-  let body = Jv.get document "body" in
-  ignore @@ Jv.call body "append" [| div |];
-  (* go back to El *)
-  match find_by_id_opt "floating-reply-preview" with
-  | None -> failwith "error cloning element"
-  | Some el -> el
-
-let on_mouse_over el _event =
-  log "on mouse over@\n";
-
-  let reply_id =
-    match El.at (Jstr.of_string "data-id") el with
-    | None -> failwith "no data-id on element"
-    | Some data_id -> Jstr.to_string data_id
-  in
-
-  match find_by_id_opt reply_id with
-  | None -> failwith "error getting reply_div, this reply is not on this page"
-  | Some reply_div ->
-    (* check if it in view, if it is, just make it of class `highlight` *)
-    let window_height =
-      let window = Jv.get Jv.global "window" in
-      Jv.get window "innerHeight" |> Jv.to_int
-    in
-    let reply_top = El.bound_y reply_div |> int_of_float in
-    if reply_top < window_height - 50 && reply_top + 50 > 0 then (
-      (* just highlight if reply is in viewport *)
-      El.set_class (Jstr.of_string "highlight") true reply_div;
-      highlighted_ref := Some reply_div )
-    else
-      (* copy it to make new div  `floating-reply-preview` *)
-      let preview_div = clone_element reply_div in
-
-      (* place it next to the reply-link el*)
-      let top =
-        let el_top = El.bound_y el in
-        let h = El.bound_h preview_div in
-        (* clamp to viewport *)
-        let top =
-          Float.min
-            (el_top -. (0.5 *. h))
-            (float_of_int window_height -. h -. 7.0)
-        in
-        let top = Float.max top 0.0 in
-        top |> int_of_float |> Format.sprintf "%dpx" |> Jstr.of_string
-      in
-      let left =
-        El.bound_x el +. El.bound_w el
-        |> int_of_float |> Format.sprintf "%dpx" |> Jstr.of_string
-      in
-      El.set_inline_style El.Style.position (Jstr.of_string "fixed") preview_div;
-      El.set_inline_style El.Style.z_index (Jstr.of_string "42") preview_div;
-      El.set_inline_style El.Style.top top preview_div;
-      El.set_inline_style El.Style.left left preview_div;
-      (* also highlight class doesn't work if we set inline style idk why wtf css *)
-      El.set_inline_style El.Style.background_color (Jstr.of_string "#9dd162")
-        preview_div;
-
-      (* set preview_div ref for on_mouse_out *)
-      preview_ref := Some preview_div
-
-let on_mouse_out _el _event =
-  log "on mouse out@\n";
-  (* get the `reply-preview` element, delete it if Some*)
-  let () =
-    match !highlighted_ref with
-    | None -> ()
-    | Some highlighted_div ->
-      El.set_class (Jstr.of_string "highlight") false highlighted_div
-  in
-  match !preview_ref with
-  | None -> ()
-  | Some preview_div -> El.remove preview_div
-
-let make_pretty _event =
-  log "make pretty@\n";
-
-  let dates = El.find_by_class (Jstr.of_string "date") in
-  List.iter render_time dates;
-
-  (*add event image_click to all postImage*)
-  let () = add_event_to_class Ev.click "post-image" image_click in
-
-  (*add event mouse_over/out to all reply-link *)
-  let () = add_event_to_class Ev.mouseover "reply-link" on_mouse_over in
-  let () = add_event_to_class Ev.mouseout "reply-link" on_mouse_out in
-
-  (* add fragment listener to mark as selected the linked post *)
-  let (_ : Ev.listener) =
-    Ev.listen Ev.hashchange on_hashchange (Window.as_target G.window)
-  in
-  (* call hashchange on page load too *)
-  on_hashchange ()
-
-(*make pretty after page load*)
-let () =
-  log "add load eventlistener to make pretty@\n";
-  let (_ : Ev.listener) =
-    Ev.listen Ev.load make_pretty (Window.as_target G.window)
-  in
-  ()

src/js/utils.ml

@@ -1,18 +0,0 @@
-open Brr
-
-let log = Format.printf
-
-let find_by_id_opt id = Document.find_el_by_id G.document (Jstr.of_string id)
-
-let find_by_id id =
-  match find_by_id_opt id with
-  | None -> failwith (Format.sprintf "element `%s` not found" id)
-  | Some el -> el
-
-let add_event_to_class event name handler =
-  let el_list = El.find_by_class (Jstr.of_string name) in
-  List.iter
-    (fun el ->
-      let (_ : Ev.listener) = Ev.listen event (handler el) (El.as_target el) in
-      () )
-    el_list

src/json_data.ml

@@ -0,0 +1,364 @@
+open Data_encoding
+open Types
+
+type nonrec 'a result = ('a, string) result
+
+let internal_err =
+  let open Err in
+  union
+    [ (let title = "No_msg" in
+       case ~title (Tag 0)
+         (obj1 (req title unit))
+         (function No_msg -> Some () | _ -> None)
+         (fun () -> No_msg) )
+    ; (let title = "Db" in
+       case ~title (Tag 1)
+         (obj1 (req title string))
+         (function Db s -> Some s | _ -> None)
+         (fun s -> Db s) )
+    ; (let title = "Db_not_found" in
+       case ~title (Tag 2)
+         (obj1 (req title string))
+         (function Db_not_found s -> Some s | _ -> None)
+         (fun s -> Db_not_found s) )
+    ; (let title = "Bos" in
+       case ~title (Tag 3)
+         (obj1 (req title string))
+         (function Bos s -> Some s | _ -> None)
+         (fun s -> Bos s) )
+    ; (let title = "Conan" in
+       case ~title (Tag 4)
+         (obj1 (req title string))
+         (function Conan s -> Some s | _ -> None)
+         (fun s -> Conan s) )
+    ]
+
+let err =
+  let open Err in
+  union
+    [ (let title = "Internal" in
+       case ~title (Tag 0) internal_err
+         (function Internal o -> Some o | _ -> None)
+         (fun o -> Internal o) )
+    ; (let title = "Bad_form" in
+       case ~title (Tag 1)
+         (obj1 (req title unit))
+         (function Bad_form -> Some () | _ -> None)
+         (fun () -> Bad_form) )
+    ; (let title = "Bad_form_suspicious" in
+       case ~title (Tag 2)
+         (obj1 (req title unit))
+         (function Bad_form_suspicious -> Some () | _ -> None)
+         (fun () -> Bad_form_suspicious) )
+    ; (let title = "Unauthorized" in
+       case ~title (Tag 3)
+         (obj1 (req title unit))
+         (function Unauthorized -> Some () | _ -> None)
+         (fun () -> Unauthorized) )
+    ; (let title = "Unauthorized_login" in
+       case ~title (Tag 4)
+         (obj1 (req title string))
+         (function Unauthorized_login s -> Some s | _ -> None)
+         (fun s -> Unauthorized_login s) )
+    ; (let title = "Forbidden" in
+       case ~title (Tag 5)
+         (obj1 (req title unit))
+         (function Forbidden -> Some () | _ -> None)
+         (fun () -> Forbidden) )
+    ; (let title = "Not_found" in
+       case ~title (Tag 6)
+         (obj1 (req title unit))
+         (function Not_found -> Some () | _ -> None)
+         (fun () -> Not_found) )
+    ; (let title = "Not_found_thread" in
+       case ~title (Tag 7)
+         (obj1 (req title int31))
+         (function Not_found_thread s -> Some s | _ -> None)
+         (fun s -> Not_found_thread s) )
+    ; (let title = "Not_found_post" in
+       case ~title (Tag 8)
+         (obj1 (req title int31))
+         (function Not_found_post s -> Some s | _ -> None)
+         (fun s -> Not_found_post s) )
+    ; (let title = "Not_found_user" in
+       case ~title (Tag 9)
+         (obj1 (req title string))
+         (function Not_found_user s -> Some s | _ -> None)
+         (fun s -> Not_found_user s) )
+    ; (let title = "Not_found_image" in
+       case ~title (Tag 10)
+         (obj1 (req title int31))
+         (function Not_found_image s -> Some s | _ -> None)
+         (fun s -> Not_found_image s) )
+    ; (let title = "Unprocessable" in
+       case ~title (Tag 11)
+         (obj1 (req title string))
+         (function Unprocessable s -> Some s | _ -> None)
+         (fun s -> Unprocessable s) )
+    ]
+
+let img_info =
+  conv
+    (fun { md5; mime; w; h; thumb_w; thumb_h; name; alt } ->
+      (md5, mime, w, h, thumb_w, thumb_h, name, alt) )
+    (fun (md5, mime, w, h, thumb_w, thumb_h, name, alt) ->
+      { md5; mime; w; h; thumb_w; thumb_h; name; alt } )
+    (obj8 (req "md5" string) (req "mime" string) (req "w" int31) (req "h" int31)
+       (req "thumb_w" int31) (req "thumb_h" int31) (req "name" string)
+       (req "alt" string) )
+
+let post =
+  conv_with_guard
+    (fun { id
+         ; parent_t_id
+         ; date
+         ; poster_id
+         ; poster_nick
+         ; comment
+         ; image_info
+         ; backlinks
+         } ->
+      ( id
+      , parent_t_id
+      , date
+      , poster_id
+      , poster_nick
+      , Comment.to_string comment
+      , image_info
+      , backlinks ) )
+    (fun ( id
+         , parent_t_id
+         , date
+         , poster_id
+         , poster_nick
+         , comment_str
+         , image_info
+         , backlinks ) ->
+      let open Syntax in
+      let+ comment = Comment.of_string comment_str in
+      { id
+      ; parent_t_id
+      ; date
+      ; poster_id
+      ; poster_nick
+      ; comment
+      ; image_info
+      ; backlinks
+      } )
+    (obj8 (req "id" int31) (req "parent_t_id" int31) (req "date" float)
+       (req "poster_id" string) (req "poster_nick" string)
+       (req "comment" string)
+       (req "image_info" (option img_info))
+       (req "replies" (list int31)) )
+
+let bump_status =
+  union
+    [ case ~title:"Dead" (Tag 0)
+        (obj1 (req "dead" empty))
+        (function Dead -> Some () | _ -> None)
+        (fun () -> Dead)
+    ; case ~title:"Locked" (Tag 1)
+        (obj1 (req "locked" int31))
+        (function Locked c -> Some c | _ -> None)
+        (fun c -> Locked c)
+    ; case ~title:"Alive" (Tag 2)
+        (obj1 (req "alive" int31))
+        (function Alive c -> Some c | _ -> None)
+        (fun c -> Alive c)
+    ]
+
+let thread =
+  conv
+    (fun { op; subject; lat; lng; bump_status; reply_count } ->
+      (op, subject, lat, lng, bump_status, reply_count) )
+    (fun (op, subject, lat, lng, bump_status, reply_count) ->
+      { op; subject; lat; lng; bump_status; reply_count } )
+    (obj6 (req "op" post) (req "subject" string) (req "lat" float)
+       (req "lng" float)
+       (req "bump_status" bump_status)
+       (req "reply_count" int31) )
+
+let thread_w_reply =
+  let open Thread_w_reply in
+  conv
+    (fun { op; subject; lat; lng; bump_status; reply_count; reply_l } ->
+      (op, subject, lat, lng, bump_status, reply_count, reply_l) )
+    (fun (op, subject, lat, lng, bump_status, reply_count, reply_l) ->
+      { op; subject; lat; lng; bump_status; reply_count; reply_l } )
+    (obj7 (req "op" post) (req "subject" string) (req "lat" float)
+       (req "lng" float)
+       (req "bump_status" bump_status)
+       (req "reply_count" int31)
+       (req "reply_l" (list post)) )
+
+let catalog : thread list encoding =
+  conv (fun l -> l) (fun l -> l) (obj1 (req "catalog" (list thread)))
+
+let report =
+  conv
+    (fun { report_id
+         ; report_date
+         ; reported_post
+         ; reporter_user_id
+         ; reporter_nick
+         ; reason
+         } ->
+      ( report_id
+      , report_date
+      , reported_post
+      , reporter_user_id
+      , reporter_nick
+      , reason ) )
+    (fun ( report_id
+         , report_date
+         , reported_post
+         , reporter_user_id
+         , reporter_nick
+         , reason ) ->
+      { report_id
+      ; report_date
+      ; reported_post
+      ; reporter_user_id
+      ; reporter_nick
+      ; reason
+      } )
+    (obj6 (req "report_id" string) (req "report_date" float)
+       (req "reported_post" post)
+       (req "reporter_user_id" string)
+       (req "reporter_nick" string)
+       (req "reason" string) )
+
+let reports : report list encoding =
+  conv (fun o -> o) (fun o -> o) (obj1 (req "reports" (list report)))
+
+let user =
+  conv
+    (fun { user_id; user_nick; user_is_admin; bio; avatar_info } ->
+      (user_id, user_nick, user_is_admin, bio, avatar_info) )
+    (fun (user_id, user_nick, user_is_admin, bio, avatar_info) ->
+      { user_id; user_nick; user_is_admin; bio; avatar_info } )
+    (obj5 (req "user_id" string) (req "user_nick" string)
+       (req "user_is_admin" bool) (req "bio" string)
+       (req "avatar_info" (option img_info)) )
+
+let user_private =
+  let open User_private in
+  conv
+    (fun { user_id; user_nick; user_is_admin; bio; avatar_info; email } ->
+      (user_id, user_nick, user_is_admin, bio, avatar_info, email) )
+    (fun (user_id, user_nick, user_is_admin, bio, avatar_info, email) ->
+      { user_id; user_nick; user_is_admin; bio; avatar_info; email } )
+    (obj6 (req "user_id" string) (req "user_nick" string)
+       (req "user_is_admin" bool) (req "bio" string)
+       (req "avatar_info" (option img_info))
+       (req "email" string) )
+
+let geojson_marker : (float * float * post_id) encoding =
+  let geometry =
+    conv
+      (* !! geojson coordinates are lng first then lat *)
+      (fun (lat, lng) -> ((), [ lng; lat ]) )
+      (fun ((), coordinates) ->
+        match coordinates with [ lng; lat ] -> (lat, lng) | _ -> assert false )
+      (obj2
+         (req "type" (constant "Point"))
+         (req "coordinates" (Fixed.list 2 float)) )
+  in
+  let properties = conv (fun id -> id) (fun id -> id) (obj1 (req "id" int31)) in
+  conv
+    (fun (lat, lng, id) -> ((), (lat, lng), id))
+    (fun ((), (lat, lng), id) -> (lat, lng, id))
+    (obj3
+       (req "type" (constant "Feature"))
+       (req "geometry" geometry)
+       (req "properties" properties) )
+
+let geojson_markers : (float * float * post_id) list encoding =
+  conv
+    (fun l -> ((), l))
+    (fun ((), l) -> l)
+    (obj2
+       (req "type" (constant "FeatureCollection"))
+       (req "features" (list geojson_marker)) )
+
+let session : session encoding =
+  conv
+    (fun { user_private; csrf_token; csrf_time_limit } ->
+      (user_private, csrf_token, csrf_time_limit) )
+    (fun (user_private, csrf_token, csrf_time_limit) ->
+      { user_private; csrf_token; csrf_time_limit } )
+    (obj3
+       (req "user_private" (option user_private))
+       (req "csrf_token" string)
+       (req "csrf_time_limit" float) )
+
+let unit : unit encoding =
+  conv (fun o -> o) (fun o -> o) (obj1 (req "unit" unit))
+
+let to_string enc =
+  let json = Data_encoding.Json.construct enc in
+  fun v -> Data_encoding.Json.to_string (json v)
+
+let of_string enc =
+  let destruct = Data_encoding.Json.destruct enc in
+  fun s -> Data_encoding.Json.from_string s |> Result.map destruct
+
+module Read = struct
+  let err = of_string err
+
+  let session = of_string session
+
+  let img_info = of_string img_info
+
+  let post = of_string post
+
+  let bump_status = of_string bump_status
+
+  let thread = of_string thread
+
+  let thread_w_reply = of_string thread_w_reply
+
+  let catalog = of_string catalog
+
+  let reports = of_string reports
+
+  let user = of_string user
+
+  let user_private = of_string user_private
+
+  let geojson_marker = of_string geojson_marker
+
+  let geojson_markers = of_string geojson_markers
+
+  let unit = of_string unit
+end
+
+module Write = struct
+  let err = to_string err
+
+  let session = to_string session
+
+  let img_info = to_string img_info
+
+  let post = to_string post
+
+  let bump_status = to_string bump_status
+
+  let thread = to_string thread
+
+  let thread_w_reply = to_string thread_w_reply
+
+  let catalog = to_string catalog
+
+  let reports = to_string reports
+
+  let user = to_string user
+
+  let user_private = to_string user_private
+
+  let geojson_marker = to_string geojson_marker
+
+  let geojson_markers = to_string geojson_markers
+
+  let unit = to_string unit
+end

src/json_data.mli

@@ -0,0 +1,68 @@
+(* TODO
+   - clean up unused
+   - expose pp?
+   - test (later)
+ *)
+open Types
+
+type nonrec 'a result = ('a, string) result
+
+module Read : sig
+  val err : string -> Err.t result
+
+  val img_info : string -> img_info result
+
+  val post : string -> post result
+
+  val bump_status : string -> bump_status result
+
+  val thread : string -> thread result
+
+  val thread_w_reply : string -> Thread_w_reply.t result
+
+  val catalog : string -> thread list result
+
+  val reports : string -> report list result
+
+  val user : string -> user result
+
+  val user_private : string -> User_private.t result
+
+  val geojson_marker : string -> (float * float * post_id) result
+
+  val geojson_markers : string -> (float * float * post_id) list result
+
+  val session : string -> session result
+
+  val unit : string -> unit result
+end
+
+module Write : sig
+  val err : Err.t -> string
+
+  val img_info : img_info -> string
+
+  val post : post -> string
+
+  val bump_status : bump_status -> string
+
+  val thread : thread -> string
+
+  val thread_w_reply : Thread_w_reply.t -> string
+
+  val catalog : thread list -> string
+
+  val reports : report list -> string
+
+  val user : user -> string
+
+  val user_private : User_private.t -> string
+
+  val geojson_marker : float * float * post_id -> string
+
+  val geojson_markers : (float * float * post_id) list -> string
+
+  val session : session -> string
+
+  val unit : unit -> string
+end

src/login.eml.html

@@ -1,20 +0,0 @@
-let f request =
-
-% let url =
-%   match Dream.query request "redirect" with
-%       | None -> "/login"
-%       | Some r -> 
-%     Format.sprintf "/login?redirect=%s" r
-% in
-<%s! Dream.form_tag ~action:url request %>
-  <div class="mb-3">
-    <label for="login" class="form-label">Nick</label>
-    <input name="login" type="text" class="form-control" id="login" aria-describedby="login-help">
-    <div id="login-help" class="form-text">What is you nickname or email?</div>
-  </div>
-  <div class="mb-3">
-    <label for="password" class="form-label">Password</label>
-    <input name="password" type="password" class="form-control" id="password">
-  </div>
-  <button type="submit" class="btn btn-primary">Submit</button>
-</form>

src/moderation.ml

@@ -0,0 +1,107 @@
+open Syntax
+open Types
+open Caqti_request.Infix
+open Caqti_type
+open Caqti_db
+
+(* TODO do something for multiples report on same post
+   - don't allow multiple report on same post from same user
+   - add TEST *)
+
+let () =
+  let tables =
+    [| (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS report (report_id TEXT, date FLOAT, \
+          post_id INTEGER, user_id TEXT, reason TEXT, FOREIGN KEY(post_id) \
+          REFERENCES post(id) ON DELETE CASCADE, FOREIGN KEY(user_id) \
+          REFERENCES user(user_id) ON DELETE CASCADE)"
+     ; (unit ->. unit)
+         "CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)"
+    |]
+  in
+  Array.iter (fun query -> Db.exec_unsafe query ()) tables
+
+module Q = struct
+  let upload_report =
+    Db.exec
+      ((t5 string float int string string ->. unit)
+         "INSERT INTO report VALUES (?,?,?,?,?)" )
+
+  let get_reports_all =
+    Db.collect_list
+      ((unit ->* t6 string float int string string string)
+         "SELECT r.report_id, r.date, r.post_id, r.user_id, u.nick, reason \
+          FROM report r JOIN user u ON r.user_id = u.user_id" )
+
+  let get_reports_made_by =
+    Db.collect_list
+      ((string ->* t6 string float int string string string)
+         "SELECT r.report_id, r.date, r.post_id, r.user_id, u.nick, reason \
+          FROM report r JOIN user u ON r.user_id = u.user_id WHERE r.user_id=?" )
+
+  let delete_report =
+    Db.exec @@ (int ->. unit) "DELETE FROM report WHERE post_id=?"
+
+  let upload_banished =
+    Db.exec @@ (t2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
+
+  let find_banished =
+    Db.find_opt
+    @@ (t2 string string ->! t2 string string)
+         "SELECT * FROM banished WHERE nick=? OR email=?"
+end
+
+let get_report_aux
+    ( report_id
+    , report_date
+    , reported_post_id
+    , reporter_user_id
+    , reporter_nick
+    , reason ) =
+  let+ reported_post = Post.get_post reported_post_id in
+  { report_id
+  ; report_date
+  ; reported_post
+  ; reporter_user_id
+  ; reporter_nick
+  ; reason
+  }
+
+let get_reports_all () =
+  Db.do_transaction @@ fun () ->
+  let* l = Q.get_reports_all () in
+  list_map get_report_aux l
+
+let get_reports_made_by user_id =
+  Db.do_transaction @@ fun () ->
+  let* l = Q.get_reports_made_by user_id in
+  list_map get_report_aux l
+
+let make_report ~reporter_user_id ~reason reported_post_id =
+  let* reason = Validate_str.report reason in
+  (* check post exists *)
+  let* _post = Post.get_post reported_post_id in
+  let report_date = Unix.time () in
+  let report_id = Util.gen_uuid () in
+  Db.do_transaction @@ fun () ->
+  Q.upload_report
+    ( report_id
+    , report_date
+    , reported_post_id
+    , reporter_user_id
+    , (reason :> string) )
+
+(* todo sql: no need to use transaction for a single query? *)
+let delete_report id = Db.do_transaction @@ fun () -> Q.delete_report id
+
+let is_banished login =
+  let+ opt = Db.do_transaction @@ fun () -> Q.find_banished (login, login) in
+  match opt with None -> false | Some _ -> true
+
+(* it would be better to also invalidate banned user's session here
+   since Api.get_logged_user check for user existance it should be fine *)
+let banish user_id =
+  let* user_private = User.get_user_private user_id in
+  let* () = User.delete_user user_id in
+  Db.do_transaction @@ fun () ->
+  Q.upload_banished (user_private.user_nick, user_private.email)

src/permap.ml

@@ -1,436 +1,151 @@
-open Utils
 open Syntax
 
+(* TODO http cache *)
+let cache_max_age = 0
+
+(* TODO https://cheatsheetseries.owasp.org/cheatsheets/Logging_Cheat_Sheet.html *)
+let log_err =
+  let open Err in
+  let _debug ~request e = Dream.debug (fun log -> log ~request "%a" pp e) in
+  let info ~request e = Dream.info (fun log -> log ~request "%a" pp e) in
+  let warning ~request e = Dream.warning (fun log -> log ~request "%a" pp e) in
+  let error ~request e = Dream.error (fun log -> log ~request "%a" pp e) in
+  fun request (e : Err.t) ->
+    if Config_serv.custom_logger then
+      match e with
+      | Internal _ -> error ~request e
+      | Bad_form_suspicious | Unauthorized_login _ -> warning ~request e
+      | _ -> info ~request e
+
+let status_of_err (err : Err.t) =
+  let open Err in
+  match err with
+  | Internal _ -> `Internal_Server_Error
+  | Bad_form | Bad_form_suspicious -> `Bad_Request
+  | Unauthorized | Unauthorized_login _ -> `Unauthorized
+  | Forbidden -> `Forbidden
+  | Not_found | Not_found_thread _ | Not_found_post _ | Not_found_user _
+  | Not_found_image _ ->
+    `Not_Found
+  | Unprocessable _ -> `Bad_Request
+
+let render_result_img request ~headers res =
+  let headers = [ ("Content-Type", "image") ] @ headers in
+  match res with
+  | Ok v -> Dream.respond ~headers v
+  | Error e ->
+    log_err request e;
+    let e = Err.hide_internal_err_detail e in
+    let status = status_of_err e in
+    let body = Fmt.str "%a" Err.pp e in
+    Dream.respond ~headers ~status body
+
+let render_result_json request ~headers res =
+  match res with
+  | Ok v -> Dream.json ~headers v
+  | Error e ->
+    log_err request e;
+    let e = Err.hide_internal_err_detail e in
+    let status = status_of_err e in
+    let body = Json_data.Write.err e in
+    Dream.json ~headers ~status body
+
 let asset_loader _root path _request =
-  match Content.read ("assets/" ^ path) with
+  match Assets.read 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 ) )
+    Dream.respond
+      ~headers:[ ("Cache-Control", Fmt.str "max-age=%d" cache_max_age) ]
+      asset
 
 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
+  (* posts images do not change so we cache them
+     todo don't cache if not found? *)
+  let headers =
+    [ ("Cache-Control", Fmt.str "max-age=%d, immutable" cache_max_age) ]
   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 f = if thumbnail then Post.get_thumbnail_data else Post.get_image_data in
+  let res =
+    let* image_id = Api.url_param request Post_image_id in
+    f image_id
+  in
+  render_result_img request ~headers res
 
 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
+    let* user_id = Api.url_param request User_id in
+    User.get_image 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 )
+  render_result_img request ~headers:[] res
 
-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 app_start_page _request =
+  Html.app_start_page |> Html.page_to_string |> Dream.html
 
 let routes =
-  (* this is just so that they're visually aligned *)
-  let get_ = Dream.get in
-  let post = Dream.post in
+  (* wrap api function with render_result_json *)
+  let get_ path f =
+    let handler request = render_result_json request ~headers:[] (f request) in
+    Dream.get path handler
+  in
+  let post path f =
+    let handler request =
+      Lwt.bind (f request) (render_result_json request ~headers:[])
+    in
+    Dream.post path handler
+  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
+  (* TODO
+     - origin_referrer_check
+     - custom CSRF header instead of having client insert csrf in form *)
+  Dream.scope "/api" [ (* middlewear *) ]
+    Api.
+      [ get_ "/catalog" GET.catalog
+      ; get_ "/thread/:thread_id" GET.thread_w_reply
+      ; get_ "/post/:post_id" GET.post
+      ; get_ "/admin" GET.admin
+      ; get_ "/user/:user_id" GET.user_page
+      ; get_ "/session" GET.session
+      ; post "/register" POST.register
+      ; post "/login" POST.login
+      ; post "/admin/ignore/:post_id" POST.admin_ignore
+      ; post "/admin/delete/:post_id" POST.admin_delete
+      ; post "/admin/banish/:user_id" POST.admin_banish
+      ; post "/profile" POST.profile
+      ; post "/account" POST.account
+      ; post "/logout" POST.logout
+      ; post "/" POST.new_thread
+      ; post "/thread/:thread_id" POST.reply
+      ; post "/delete/:post_id" POST.delete
+      ; post "/report/:post_id" POST.report
+      ]
+  :: [ Dream.get "/assets/**" (Dream.static ~loader:asset_loader "")
+     ; Dream.get "/img/:image_id" (get_post_image ~thumbnail:false)
+     ; Dream.get "/img/s/:image_id" (get_post_image ~thumbnail:true)
+     ; Dream.get "/user/:user_id/avatar" get_avatar_image
+     ; Dream.get "/**" app_start_page
      ]
-  @
-  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
-  *)
+  let () =
+    let open Config_serv in
+    Dream.log "config file: %a" Fpath.pp config_path;
+    Dream.log "default_logger: %b" default_logger;
+    Dream.log "custom_logger: %b" custom_logger
+  in
+  let () =
+    let open Config in
+    Dream.log "open_registration: %b" open_registration;
+    Dream.log "hostname: %s" hostname;
+    Dream.log "port: %d" port
+  in
+  ()
+
+let () =
+  let logger = if Config_serv.default_logger then Dream.logger else Fun.id in
+  Dream.run ~port:Config.port
+  @@ logger
+  @@ Dream.sql_pool (Uri.to_string Config_serv.db_uri)
+  @@ Dream.sql_sessions ~lifetime:(float_of_int Config.session_lifetime)
   @@ Dream.router routes

src/post.ml

@@ -0,0 +1,84 @@
+open Syntax
+open Types
+open Err
+
+let get_post id =
+  let* opt = Db_post.find_post id in
+  match opt with None -> Error (Not_found_post id) | Some v -> Ok v
+
+let get_thread id =
+  let* opt = Db_post.find_thread id in
+  match opt with None -> Error (Not_found_thread id) | Some v -> Ok v
+
+let get_thread_w_reply id =
+  let* opt = Db_post.find_thread_w_reply id in
+  match opt with None -> Error (Not_found_thread id) | Some v -> Ok v
+
+let get_catalog () = Db_post.get_catalog ()
+
+(* todo id type is string here.. *)
+let get_thumbnail_data id =
+  let* opt = Db_image.P.thumbnail_data id in
+  match opt with None -> Error (Not_found_image id) | Some image -> Ok image
+
+let get_image_data id =
+  let* opt = Db_image.P.data id in
+  match opt with None -> Error (Not_found_image id) | Some image -> Ok image
+
+let get_image_info id =
+  let* opt = Db_image.P.info id in
+  match opt with None -> Error (Not_found_image id) | Some image -> Ok image
+
+let delete ~user id =
+  let* post = get_post id in
+  if user.user_is_admin || String.equal post.poster_id user.user_id then
+    Db_post.delete id
+  else Error Forbidden
+
+let not_empty image_opt comment =
+  if Option.is_some image_opt || String.length comment <> 0 then Ok ()
+  else Error (Unprocessable "Your post must contain an image or a comment")
+
+let build_image image_data =
+  match image_data with
+  | None -> Ok None
+  | Some (name_opt, alt, content) ->
+    let name = Option.value ~default:"" name_opt in
+    let+ image = Image.build ~name ~alt content in
+    Some image
+
+let build_comment comment =
+  (* todo: move validation to Comment.parse *)
+  let* _comment = Validate_str.comment comment in
+  let+ comment =
+    Comment.of_string comment
+    |> Result.map_error (fun s -> Unprocessable (Fmt.str "comment: %s" s))
+  in
+  comment
+
+let make_post ~comment ~image_data ~parent_thread user =
+  let* () = not_empty image_data comment in
+  let* thread_id =
+    match parent_thread.bump_status with
+    | Dead -> Error (Unprocessable "This thread is dead, you cannot reply.")
+    | Locked _rank ->
+      Error (Unprocessable "This thread is locked, you cannot reply.")
+    | Alive _rank -> Ok parent_thread.op.id
+  in
+  let* comment = build_comment comment in
+  let* image = build_image image_data in
+  let+ post = Db_post.add_post ~thread_id ~user ~image ~comment in
+  post
+
+let make_thread ~comment ~image_data ~subject ~lat ~lng user =
+  let* () = not_empty image_data comment in
+  let* subject = Validate_str.subject subject in
+  let* () =
+    (* TODO latlng validation *)
+    let is_valid_latlng = true in
+    if is_valid_latlng then Ok () else Error (Unprocessable "Invalid coordinate")
+  in
+  let* comment = build_comment comment in
+  let* image = build_image image_data in
+  let+ thread = Db_post.add_thread ~subject ~lat ~lng ~user ~image ~comment in
+  thread

src/post_form.eml.html

@@ -1,34 +0,0 @@
-let f thread_id request =
-% let action = match thread_id with |None -> "/" | Some id -> Format.sprintf "/thread/%s" id in
-% let checkboxes = match thread_id with |None -> Format.asprintf "%a" Pp_babillard.pp_checkboxes () | Some _id -> "" in
-<div class="post-form">
-<%s! Dream.form_tag ~action ~enctype:`Multipart_form_data request %>
-% begin if Option.is_none thread_id then
-    <input type="hidden" id="lat-input" name="lat-input">
-    <input type="hidden" id="lng-input" name="lng-input">
-
-    <label for="subject" id="subject-label" class="form-label">Subject</label>
-    <input name="subject" type="text" class="form-control" id="subject" aria-labelledby="subject-label" />
-% end;
-    <label for="comment" id="comment-label" class="form-label">Comment</label>
-    <textarea name="comment" type="text" class="form-control" id="comment" aria-labelledby="comment-label"></textarea>
-
-    <label for="tags" id="tags-label" class="form-label">Tags</label>
-    <%s! checkboxes %>
-    <input name="tags" type="text" class="form-control" id="tags" aria-labelledby="tags-label" />
-    
-    <label for="file" id="file-label" class="form-label">Add picture</label>
-    <input id="file" class="form-control" name="file" aria-describedby="file-label" type="file" accept="image/png,image/jpeg,image/webp,image/gif">
-    <br />
-
-    <label for="alt" id="alt-label" class="form-label off">Image description</label>
-    <input name="alt" type="text" class="form-control off" id="alt" aria-labelledby="alt-label" />
-% begin match thread_id with
-% | None ->
-    <br />
-    <button type="submit" class="btn btn-primary" id="submit-button" disabled>Make Thread</button>
-% | Some _id ->
-    <button type="submit" class="btn btn-primary" id="submit-button">Reply</button>
-% end;
-  </form>
-</div>

src/pp_babillard.ml

@@ -1,364 +0,0 @@
-open Syntax
-open Babillard
-
-let pp_post fmt t =
-  let thread_data_opt, post =
-    match t with
-    | Op (data, post) -> (Some data, post)
-    | Post post -> (None, post)
-  in
-  let { id
-      ; emojid
-      ; parent_id = _parent_id
-      ; date
-      ; user_id
-      ; nick
-      ; comment
-      ; image_info
-      ; tags
-      ; replies
-      ; citations = _citations
-      } =
-    post
-  in
-
-  let image_view fmt () =
-    match image_info with
-    | Some (_image_name, image_alt) ->
-      Format.fprintf fmt
-        {|
-    <div class="post-image-container">
-        <a href="/img/%s">
-        <img class="post-image" src="/img/s/%s" alt="%s" title="%s" data-id="%s" loading="lazy">
-        </a>
-    </div>
-|}
-        id id image_alt image_alt id
-    | None -> Format.fprintf fmt ""
-  in
-
-  let pp_print_reply fmt reply =
-    Format.fprintf fmt {|<a class="reply-link" href="#%s">&gt;&gt;%s</a>|} reply
-      reply
-  in
-  let pp_print_replies fmt replies =
-    Format.fprintf fmt {|<div class="replies">%a</div>|}
-      (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_print_reply)
-      replies
-  in
-
-  let replies_view fmt () =
-    if Option.is_some thread_data_opt then
-      (* TODO put thread_posts count in thread_info ? *)
-      let res_nb = Q.count_thread_posts id in
-      match res_nb with
-      | Error _ -> Format.fprintf fmt ""
-      | Ok ((1 | 2) as nb) ->
-        Format.fprintf fmt {|<div class="replies">%d reply</div>|} (nb - 1)
-      | Ok nb ->
-        Format.fprintf fmt {|<div class="replies">%d replies</div>|} (nb - 1)
-    else pp_print_replies fmt replies
-  in
-
-  let post_links_view fmt () =
-    if Option.is_some thread_data_opt then
-      Format.fprintf fmt {|
-        %a
-        |} replies_view ()
-    else
-      Format.fprintf fmt
-        {|
-        <span class=postNo>
-            <button data-id="%s" data-emojid="%s" class="quote-link" title="Reply to this post">%s</button>
-        </span>
-        %a
-        |}
-        id emojid emojid replies_view ()
-  in
-
-  let post_info_view fmt () =
-    Format.fprintf fmt
-      {|
-    <div class="post-info">
-        <span class="nick" data-user-id="%s">%s</span>
-        <span class="date" data-time="%f"></span>
-        <div class="dropend post-menu-div">
-          <a class="dropdown-toggle post-menu-link" href="#" role="button" id="dropdownMenuLink" data-bs-toggle="dropdown" aria-expanded="false">
-          </a>
-          <ul class="dropdown-menu post-menu-content" aria-labelledby="dropdownMenuLink">
-            <li><a class="dropdown-item" href="#%s">Link to this post</a></li>
-            <li><a class="dropdown-item" href="/delete/%s">Delete</a></li>
-            <li><a class="dropdown-item" href="/report/%s">Report</a></li>
-          </ul>
-        </div>
-        %a
-    </div>|}
-      user_id nick date id id id post_links_view ()
-  in
-
-  let pp_print_category fmt category =
-    Format.fprintf fmt {|<span class="category tag">%s</span>|} category
-  in
-  let pp_print_tag fmt tag =
-    Format.fprintf fmt {|<span class="tag">%s</span>|} tag
-  in
-  let pp_print_tags fmt tags =
-    let categories, tags =
-      List.partition (fun tag -> List.mem tag App.categories) tags
-    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 pp_print_category)
-      categories
-      (Format.pp_print_list ~pp_sep pp_print_tag)
-      tags
-  in
-  let tags = List.sort String.compare tags in
-  let tags_view fmt () = pp_print_tags fmt tags in
-
-  let pp_subject fmt () =
-    match thread_data_opt with
-    | None -> Format.fprintf fmt ""
-    | Some thread_data ->
-      Format.fprintf fmt
-        {|
-        <div class="thread-subject">
-            %s
-        </div>
-        |}
-        thread_data.subject
-  in
-  (* put a link in if its a preview *)
-  let link fmt () =
-    if Option.is_some thread_data_opt then
-      Format.fprintf fmt
-        {|<a class="stretched-link preview-link" href="/thread/%s"></a>|} id
-  in
-
-  Format.fprintf fmt
-    {|
-    <div class="position-relative post" id="%s">
-        %a
-        %a
-        %a
-        %a
-        <blockquote class="post-comment">%s</blockquote>
-        %a
-    </div>
-|}
-    id pp_subject () link () post_info_view () image_view () comment tags_view
-    ()
-
-let view_post id =
-  let* post = get_post id in
-  Ok (Format.asprintf "%a" pp_post (Post post))
-
-let pp_thread_preview fmt op =
-  let thread_data, post = op in
-  let thread_preview =
-    Format.fprintf fmt
-      {|
-    <div class="thread-preview">
-        %a
-    </div>
-|}
-      pp_post
-      (Op (thread_data, post))
-  in
-  thread_preview
-
-let catalog_content () =
-  let* ids = Q.get_threads () in
-  let* ops = get_ops ids in
-  Ok
-    (Format.asprintf "%a"
-       (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_thread_preview)
-       ops )
-
-let pp_report fmt post report request =
-  let url = "/admin" in
-  let _reporter_id, reporter_nick, reason, _date, id = report in
-  let input_post_id fmt id =
-    Format.fprintf fmt
-      {|<input value="%s" name="post_id" type="hidden"></input>|} id
-  in
-  let button fmt action =
-    let s = moderation_action_to_string action in
-    Format.fprintf fmt
-      {|<button value="%s" name="action" type="submit" class="btn btn-primary">%s</button>|}
-      s (String.uppercase_ascii s)
-  in
-  let form fmt action =
-    Format.fprintf fmt {|%s %a %a </form>|}
-      (Dream.form_tag ~action:url request)
-      input_post_id id button action
-  in
-
-  Format.fprintf fmt
-    {|
-<div class="report">
-    <div class="row mb-3">
-        <div class="col-md-6">
-            %a
-        </div>
-        <div class="col-md-6">
-            <span> From: %s Reason: %s</span>
-            <div>
-                %a
-                </form><br>
-                %a
-                </form><br>
-                %a
-                </form><br>
-            </div>
-        </div>
-    </div>
-</div><br>
-|}
-    pp_post (Post post) reporter_nick reason form Ignore form Delete form Banish
-
-let admin_page_content posts reports request =
-  let posts_reports = List.combine posts reports in
-  Format.asprintf "%a"
-    (Format.pp_print_list ~pp_sep:Format.pp_print_space
-       (fun fmt (post, report) -> pp_report fmt post report request) )
-    posts_reports
-
-let pp_thread fmt op posts =
-  let thread_data, _post = op in
-  (*order by date *)
-  let posts = List.sort (fun a b -> compare a.date b.date) posts in
-  let posts_view fmt () =
-    Format.pp_print_list ~pp_sep:Format.pp_print_space
-      (fun fmt post -> pp_post fmt (Post post))
-      fmt posts
-  in
-  Format.fprintf fmt
-    {|
-<div class="thread">
-    <div class="thread-subject">
-        <h1>%s</h1>
-    </div>
-    <div class="thread-posts">
-        %a
-    </div>
-</div>
-|}
-    thread_data.subject posts_view ()
-
-let view_thread thread_id =
-  let* op = get_op thread_id in
-  let* ids = Q.get_thread_posts thread_id in
-  let* posts = get_posts ids in
-  let s =
-    (Format.asprintf "%a" (fun fmt (op, posts) -> pp_thread fmt op posts))
-      (op, posts)
-  in
-  Ok s
-
-let pp_marker fmt op =
-  let thread_data, post = op in
-  let content = Format.asprintf "%a" pp_thread_preview op in
-  (* geojson use lng lat, and not lat lng*)
-  let json =
-    `Assoc
-      [ ("type", `String "Feature")
-      ; ( "geometry"
-        , `Assoc
-            [ ("type", `String "Point")
-            ; ( "coordinates"
-              , `List [ `Float thread_data.lng; `Float thread_data.lat ] )
-            ] )
-      ; ( "properties"
-        , `Assoc
-            [ ("content", `String content); ("thread_id", `String post.id) ] )
-      ]
-  in
-  Yojson.pretty_print fmt json
-
-let get_markers () =
-  let* ids = Q.get_threads () in
-  let* ops = get_ops ids in
-  let markers =
-    Format.asprintf "[%a]"
-      (Format.pp_print_list
-         ~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
-         pp_marker )
-      ops
-  in
-  Ok markers
-
-let pp_checkboxes fmt () =
-  let pp_checkbox fmt category =
-    Format.fprintf fmt
-      {|
-<div class="form-check col">
-    <input name="category" id="category-%s" type="checkbox" class"form-check-input" value="%s">
-    <label class="form-check-label" for="category-%s">%s</label>
-</div>
-|}
-      category category category category
-  in
-  Format.fprintf fmt
-    {|
-<div class="row">
-   %a
-</div>|}
-    (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_checkbox)
-    App.categories
-
-(* RFC-3339 date-time *)
-let pp_date fmt date =
-  let date = Unix.gmtime date in
-  Format.fprintf fmt "%04d-%02d-%02dT%02d:%02d:%02dZ" (1900 + date.tm_year)
-    (1 + date.tm_mon) date.tm_mday date.tm_hour date.tm_min date.tm_sec
-
-let pp_feed_entry fmt post =
-  Format.fprintf fmt
-    {|
-  <entry>
-    <title></title>
-    <id>urn:uuid:%s</id>
-    <updated>%a</updated>
-  <author>
-    <name>%s</name>
-  </author>
-    <content type="html">%s</content>
-    <link rel="alternate" href="%s/thread/%s#%s"/>
-  </entry>
-    |}
-    post.id pp_date post.date post.nick
-    (Dream.html_escape post.comment)
-    App.hostname post.parent_id post.id
-
-let feed thread_id =
-  let* thread_data, op_post = get_op thread_id in
-  let* ids = Q.get_thread_posts thread_id in
-  let* posts = get_posts ids in
-  let posts = List.sort (fun a b -> compare b.date a.date) posts in
-  let* last_update =
-    match posts with [] -> Error "empty thread" | op :: _l -> Ok op.date
-  in
-
-  let entries fmt () =
-    (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_feed_entry) fmt posts
-  in
-  let feed =
-    Format.asprintf
-      {|<?xml version="1.0" encoding="utf-8"?>
-<feed xmlns="http://www.w3.org/2005/Atom">
-  <title>%s</title>
-  <link rel="self" href="%s/thread/%s"/>
-  <updated>%a</updated>
-  <author>
-    <name>%s</name>
-  </author>
-  <id>urn:uuid:%s</id>
-  %a
-</feed>|}
-      thread_data.subject App.hostname thread_id pp_date last_update
-      op_post.nick op_post.id entries ()
-  in
-  Ok feed

src/register.eml.html

@@ -1,16 +0,0 @@
-let f request =
-<%s! Dream.form_tag ~action:"/register" request %>
-  <div class="mb-3">
-    <label for="nick" class="form-label">Nick</label>
-    <input name="nick" type="text" class="form-control" id="nick">
-  </div>
-  <div class="mb-3">
-    <label for="email" class="form-label">Email address</label>
-    <input name="email" type="email" class="form-control" id="email">
-  </div>
-  <div class="mb-3">
-    <label for="password" class="form-label">Password</label>
-    <input name="password" type="password" class="form-control" id="password">
-  </div>
-  <button type="submit" class="btn btn-primary">Submit</button>
-</form>

src/report_page.eml.html

@@ -1,22 +0,0 @@
-let f post_preview post_id request =
-
-<script type="text/javascript" src="/assets/js/catalog.js" defer="defer"></script>
-      <%s! post_preview %>
-% let url = Format.sprintf "/report/%s" post_id in
-% begin match Dream.session "nick" request with
-% | None ->
-% let redirect = Dream.to_percent_encoded url in
-  <a href="/login?redirect=<%s redirect%>">Login</a> to report a post.
-% | Some _nick ->
-  <div class="row mb-3">
-    <div class="col-md-6" id="report-form">
-      <div class="postForm">
-<%s! Dream.form_tag ~action:url request %>
-          <label for="reason" id="reason-label" class="form-label">Reason:</label>
-          <input name="reason" id="reason" type="text" class="form-control" aria-labelledby="reason-label"></input>
-          <button type="submit" class="btn btn-primary">REPORT</button>
-        </form>
-      </div>
-    </div>
-  </div>
-% end;

src/syntax.ml

@@ -1,12 +1,73 @@
-(* let bindings for early return when encountering an error *)
-(* see https://ocaml.org/releases/4.13/htmlman/bindingops.html *)
+let ( let* ) o f = match o with Ok v -> f v | Error _ as e -> e
 
-let ( let* ) o f = Result.fold ~ok:f ~error:Result.error o
+let ( let+ ) o f = match o with Ok v -> Ok (f v) | Error _ as e -> e
 
-let unwrap_list f ids =
-  let l = List.map f ids in
-  let res = List.find_opt Result.is_error l in
-  match res with
-  | None -> Ok (List.map Result.get_ok l)
-  | Some (Ok _) -> assert false
-  | Some (Error _e as error) -> error
+let ( let*! ) o f = match o with Ok v -> f v | Error _ as e -> Lwt.return e
+
+let list_iter f l =
+  let err = ref None in
+  try
+    List.iter
+      (fun v ->
+        match f v with
+        | Error _e as e ->
+          err := Some e;
+          raise Exit
+        | Ok () -> () )
+      l;
+    Ok ()
+  with Exit -> ( match !err with None -> assert false | Some v -> v )
+
+let list_map f l =
+  let err = ref None in
+  try
+    Ok
+      (List.map
+         (fun v ->
+           match f v with
+           | Error _e as e ->
+             err := Some e;
+             raise Exit
+           | Ok v -> v )
+         l )
+  with Exit -> ( match !err with None -> assert false | Some v -> v )
+
+let list_fold_left f acc l =
+  List.fold_left
+    (fun acc v ->
+      let* acc = acc in
+      f acc v )
+    (Ok acc) l
+
+let array_iter f a =
+  let err = ref None in
+  try
+    for i = 0 to Array.length a - 1 do
+      match f (Array.unsafe_get a i) with
+      | Error _e as e ->
+        err := Some e;
+        raise Exit
+      | Ok () -> ()
+    done;
+    Ok ()
+  with Exit -> ( match !err with None -> assert false | Some v -> v )
+
+let array_map f a =
+  let err = ref None in
+  try
+    Ok
+      (Array.init (Array.length a) (fun i ->
+           let v = Array.get a i in
+           match f v with
+           | Error _e as e ->
+             err := Some e;
+             raise Exit
+           | Ok v -> v ) )
+  with Exit -> ( match !err with None -> assert false | Some v -> v )
+
+let array_fold_left f acc l =
+  Array.fold_left
+    (fun acc v ->
+      let* acc = acc in
+      f acc v )
+    (Ok acc) l

src/template.eml.html

@@ -1,84 +0,0 @@
-let render_unsafe ~title ~content request =
-  <!DOCTYPE html>
-  <html lang="en">
-    <head>
-      <title><%s title %> | Permap</title>
-      <link rel="icon" type="image/svg+xml" href="/assets/img/favicon.png">
-      <link href="/assets/css/bootstrap.min.css" rel="stylesheet"/>
-      <link href="/assets/css/leaflet.css" rel="stylesheet">
-      <link href="/assets/css/style.css" rel="stylesheet">
-    </head>
-    <body>
-      <header>
-          <nav class="navbar navbar-expand-md navbar-dark bg-dark">
-              <div class="container-fluid">
-                <a class="navbar-brand" href="/"><img src="/assets/img/favicon.png" alt="Permap" height="22" /></a>
-                  <button class="navbar-toggler" type="button" data-bs-toggle="collapse" data-bs-target="#navbarCollapse" aria-controls="navbarCollapse" aria-expanded="false" aria-label="Toggle navigation">
-                      <span class="navbar-toggler-icon"></span>
-                  </button>
-                  <div class="collapse navbar-collapse" id="navbarCollapse">
-                      <ul class="navbar-nav me-auto mb-2 mb-md-0">
-                          <li class="nav-item">
-                              <a class="nav-link" href="/">🗺️ Babillard</a>
-                          </li>
-                          <li class="nav-item">
-                              <a class="nav-link" href="/catalog">📑 Catalog</a>
-                          </li>
-                          <li class="nav-item">
-                              <a class="nav-link" href="/user">🫂 Discover users</a>
-                          </li>
-% begin if Option.is_some @@ Dream.session "nick" request then
-                          <li class="nav-item">
-                              <a class="nav-link" href="/discuss">📫 Discuss</a>
-                          </li>
-% end;
-                      </ul>
-                      <ul class="navbar-nav ms-auto mb-2 mb-md-0">
-% begin match Dream.session "nick" request with
-% | None ->
-%   begin if App.open_registration then
-                          <li class="nav-item">
-                              <a class="nav-link" href="/register">🍎 Register</a>
-                          </li>
-%   end;
-                          <li class="nav-item">
-                              <a class="nav-link" href="/login">🚪 Login</a>
-                          </li>
-% | Some nick ->
-                          <li class="nav-item dropdown">
-                            <a class="nav-link dropdown-toggle" id="navbarDarkDropdownMenuLink" role="button" data-bs-toggle="dropdown" aria-expanded="false">
-                              🏡 <%s! nick %>
-                            </a>
-                            <ul class="dropdown-menu dropdown-menu-dark dropdown-menu-end" aria-labelledby="navbarDarkDropdownMenuLink">
-                              <li><a class="dropdown-item" href="/account">🧬 Account</a></li>
-                              <li><a class="dropdown-item" href="/profile">🦩 Your profile</a></li>
-%   begin if List.mem nick App.admins then
-                              <li><a class="dropdown-item" href="/admin">🪄 Administration</a></li>
-%   end;
-                              <li><a class="dropdown-item" href="/logout">❌ Sign out</a></li>
-                            </ul>
-                          </li>
-% end;
-                      </ul>
-                  </div>
-              </div>
-          </nav>
-      </header>
-      <br />
-      <br />
-      <br />
-      <br />
-      <main>
-        <div class="container">
-            <%s! content %>
-        </div>
-        <hr class="featurette-divider">
-        <footer class="container">
-          <p> <a href="/about">🤓 about permap</a>
-            | <a href="https://git.zapashcanon.fr/zapashcanon/permap">🛸 source code</a>
-          </p>
-        </footer>
-      </main>
-      <script src="/assets/js/bootstrap.bundle.min.js"></script>
-    </body>
-  </html>

src/thread_page.eml.html

@@ -1,16 +0,0 @@
-let f thread_view thread_id request =
-<script type="text/javascript" src="/assets/js/thread.js" defer="defer"></script>
-      <%s! thread_view %>
-% let thread_url = Format.sprintf "/thread/%s" thread_id in
-% begin match Dream.session "nick" request with
-% | None ->
-% let redirect = Dream.to_percent_encoded thread_url in
-<a href="/login?redirect=<%s redirect%>">Login to reply!</a>
-% | Some _ ->
-<%s! Post_form.f (Some thread_id) request %>
-% end;
-% let feed_url = Format.sprintf "%s/feed" thread_url in
-<a type="application/atom+xml" href=<%s! feed_url %> >
-    <img src="/assets/img/atom.svg" class="rss-logo" />
-</a>
-<link rel="alternate" type="application/atom+xml" href=<%s! feed_url %> />

src/types.mli

@@ -0,0 +1,104 @@
+(* shared server and client types *)
+(* TODO
+   - rm not shared types
+   - type alias for better naming in other modules? *)
+
+type post_id = int
+
+type thread_id = int
+
+type user_id = string
+
+type v_string = Validate_str.v_string
+
+type img_info =
+  { md5 : string
+  ; mime : string
+  ; w : int
+  ; h : int
+  ; thumb_w : int
+  ; thumb_h : int
+  ; name : string
+  ; alt : string
+  }
+
+type img =
+  { info : img_info
+  ; data : string
+  ; thumbnail_data : string
+  }
+
+type comment = Comment.t
+
+type bump_status =
+  | Dead
+  | Locked of int
+  | Alive of int
+
+module User_private : sig
+  type t =
+    { user_id : user_id
+    ; user_nick : string
+    ; user_is_admin : bool
+    ; bio : string
+    ; avatar_info : img_info option
+    ; email : string
+    }
+end
+
+type user =
+  { user_id : user_id
+  ; user_nick : string
+  ; user_is_admin : bool
+  ; bio : string
+  ; avatar_info : img_info option
+  }
+
+type session =
+  { user_private : User_private.t option
+  ; csrf_token : string
+  ; csrf_time_limit : float
+  }
+
+type post =
+  { id : post_id
+  ; parent_t_id : thread_id
+  ; date : float
+  ; poster_id : user_id
+  ; poster_nick : string
+  ; comment : comment
+  ; image_info : img_info option
+  ; (* TODO get this out of this record? *)
+    backlinks : post_id list
+  }
+
+(* TODO util conversion function for Thread_w_reply.t and user_private *)
+module Thread_w_reply : sig
+  type t =
+    { op : post
+    ; subject : string
+    ; lat : float
+    ; lng : float
+    ; bump_status : bump_status
+    ; reply_count : int
+    ; reply_l : post list
+    }
+end
+
+type thread =
+  { op : post
+  ; subject : string
+  ; lat : float
+  ; lng : float
+  ; bump_status : bump_status
+  ; reply_count : int
+  }
+
+type report =
+  { report_id : string
+  ; report_date : float
+  ; reported_post : post
+  ; reporter_user_id : user_id
+  ; reporter_nick : string
+  ; reason : string
+  }

src/user.ml

@@ -1,336 +1,115 @@
 open Syntax
-open Caqti_request.Infix
-open Caqti_type
+open Types
+open Err
 
-type t =
-  { user_id : string
-  ; nick : string
-  ; password : string
-  ; email : string
-  ; bio : string
-  ; metadata : (string * string) list
-  }
+let check_nick nick =
+  let* nick = Validate_str.nick nick in
+  let* opt = Db_user.find_user_of_nick nick in
+  match opt with
+  | None -> Ok nick
+  | Some _user -> Error (Unprocessable "nick already taken")
 
-let () =
-  let tables =
-    [| (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
-          TEXT, email TEXT, bio TEXT, PRIMARY KEY(user_id))"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)"
-     ; (unit ->. unit)
-         "CREATE TABLE IF NOT EXISTS user_metadata (user_id TEXT, metadata \
-          TEXT, FOREIGN KEY(user_id) REFERENCES user(user_id) ON DELETE \
-          CASCADE)"
-    |]
-  in
-  if
-    Array.exists Result.is_error
-      (Array.map (fun query -> Db.exec query ()) tables)
-  then Dream.error (fun log -> log "can't create user tables")
-
-module Q = struct
-  let upload_metadata =
-    Db.exec
-    @@ (tup2 string string ->. unit) "INSERT INTO user_metadata VALUES (?, ?)"
-
-  let delete_metadata =
-    Db.exec @@ (string ->. unit) "DELETE FROM user_metadata WHERE user_id=?"
-
-  let get_user_id_from_email =
-    Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE email=?"
-
-  let get_password =
-    Db.find @@ (string ->! string) "SELECT password FROM user WHERE user_id=?"
-
-  let is_already_user =
-    Db.find
-    @@ (tup2 string string ->! int)
-         "SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)"
-
-  let upload_user =
-    Db.exec
-    @@ (tup4 string string string (tup2 string string) ->. unit)
-         "INSERT INTO user VALUES (?, ?, ?, ?, ?)"
-
-  let list_nicks = Db.collect_list @@ (unit ->* string) "SELECT nick FROM user"
-
-  let get_user =
-    Db.find
-    @@ (* there is no "tup6" *)
-    (string ->! tup4 string string string (tup2 string string))
-      "SELECT * FROM user WHERE user_id=?"
-
-  let update_bio =
-    Db.exec
-    @@ (tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
-
-  let update_nick =
-    Db.exec
-    @@ (tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
-
-  let update_email =
-    Db.exec
-    @@ (tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
-
-  let update_password =
-    Db.exec
-    @@ (tup2 string string ->. unit)
-         "UPDATE user SET password=? WHERE user_id=?"
-
-  let get_bio =
-    Db.find @@ (string ->! string) "SELECT bio FROM user WHERE user_id=?"
-
-  let get_email =
-    Db.find @@ (string ->! string) "SELECT email FROM user WHERE user_id=?"
-
-  let delete_user =
-    Db.exec @@ (string ->. unit) "DELETE FROM user WHERE user_id=?"
-
-  let upload_banished =
-    Db.exec @@ (tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
-
-  let get_banished =
-    Db.find
-    @@ (tup2 string string ->! tup2 string string)
-         "SELECT * FROM banished WHERE nick=? OR email=?"
-end
-
-let get_nick =
-  Db.find @@ (string ->! string) "SELECT nick FROM user WHERE user_id=?"
-
-let get_id_from_nick =
-  Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE nick=?"
-
-let exist id = Result.is_ok (Q.get_user id)
-
-let exist_nick nick = Result.is_ok (get_id_from_nick nick)
-
-let exist_email email = Result.is_ok (Q.get_user_id_from_email email)
-
-let get_metadata =
-  let query =
-    Db.find
-    @@ (string ->! string) "SELECT metadata FROM user_metadata WHERE user_id=?"
-  in
-  fun nick ->
-    let* metadata = query nick in
-    let metadata : (string * string) list = Marshal.from_string metadata 0 in
-    Ok metadata
+let check_email email =
+  let* email = Validate_str.email email in
+  match Emile.of_string (email :> string) with
+  | Error _ -> Error (Unprocessable "invalid email format")
+  | Ok _ -> (
+    let* opt = Db_user.find_user_of_email email in
+    match opt with
+    | None -> Ok email
+    | Some _user -> Error (Unprocessable "email already taken") )
 
 let get_user user_id =
-  let* user_id, nick, password, (email, bio) = Q.get_user user_id in
-  let* metadata = get_metadata user_id in
-  Ok { user_id; nick; password; email; bio; metadata }
+  let* opt = Db_user.find_user user_id in
+  match opt with None -> Error (Not_found_user user_id) | Some o -> Ok o
 
-let is_banished login = Result.is_ok (Q.get_banished (login, login))
+let get_user_private user_id =
+  let* opt = Db_user.find_user_private user_id in
+  match opt with None -> Error (Not_found_user user_id) | Some o -> Ok o
 
-let login ~login ~password request =
-  let try_password user_id =
-    let* good_password = Q.get_password user_id in
+(* login can be nick or email *)
+let login ~login ~password =
+  let f find s =
+    let* opt = find s in
+    match opt with
+    | None -> Ok None
+    | Some user ->
+      let* good_password = Db_user.get_password_hash user.user_id in
       if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
-      let _unit_lwt = Dream.invalidate_session request in
-      let _unit_lwt = Dream.put_session "user_id" user_id request in
-      let* nick = get_nick user_id in
-      let _unit_lwt = Dream.put_session "nick" nick request in
-      Ok ()
-    else if is_banished login then Error "YOU ARE BANISHED"
-    else Error "wrong password"
+        let* opt = Db_user.find_user_private user.user_id in
+        match opt with
+        | None ->
+          Error
+            (Internal (Db_not_found (Fmt.str "user_private `%s`" user.user_id)))
+        | Some o -> Ok (Some o)
+      else Error (Unauthorized_login login)
   in
-
-  let id_from_nick = get_id_from_nick login in
-  let id_from_email = Q.get_user_id_from_email login in
-  let user_id_list =
-    List.filter_map Result.to_option [ id_from_nick; id_from_email ]
+  (* assume login is nick *)
+  let* opt =
+    match Validate_str.nick login with
+    | Error _ -> Ok None
+    | Ok nick -> f Db_user.find_user_of_nick nick
   in
-  try
-    List.iter
-      (fun id -> if Result.is_ok @@ try_password id then raise Exit)
-      user_id_list;
-    Error "invalid login"
-  with Exit -> Ok ()
-
-let valid_nick nick =
-  String.length nick < 64
-  && String.length nick > 0
-  && Dream.html_escape nick = nick
-
-let valid_password password =
-  String.length password < 128 && String.length password > 0
-
-let valid_email email = Result.is_ok @@ Emile.of_string email
+  match opt with
+  | Some u -> Ok u
+  | None -> (
+    (* assume login is email *)
+    let* email = Validate_str.email login in
+    let* opt = f Db_user.find_user_of_email email in
+    match opt with Some u -> Ok u | None -> Error (Unauthorized_login login) )
 
 let register ~email ~nick ~password =
-  let valid = valid_nick nick && valid_email email && valid_password password in
-
-  let password = Bcrypt.hash password in
-  let password = Bcrypt.string_of_hash password in
-
-  if not valid then Error "Something is wrong"
-  else
-    let* nb = Q.is_already_user (nick, email) in
-    if nb = 0 then
-      let user_id = Uuidm.to_string (Uuidm.v4_gen App.random_state ()) in
-      let* () = Q.upload_user (user_id, nick, password, (email, "")) in
-      Q.upload_metadata (user_id, Marshal.to_string [] [])
-    else Error "nick or email already exists"
-
-let list () =
-  let* users = Q.list_nicks () in
-  Ok
-    (Format.asprintf "<ul>%a</ul>"
-       (Format.pp_print_list (fun fmt -> function
-          | s -> Format.fprintf fmt {|<li><a href="/user/%s">%s</a></li>|} s s )
-       )
-       users )
-
-let profile request =
-  match Dream.session "nick" request with
-  | None -> "not logged in"
-  | Some nick -> Format.sprintf "Hello %s !" nick
-
-let update_bio bio user_id =
-  let bio = Dream.html_escape bio in
-  let valid = String.length bio < 10000 in
-  if not valid then Error "Not biologic" else Q.update_bio (bio, user_id)
-
-let upload_avatar files user_id =
-  match files with
-  | [] -> Error "No file provided"
-  | [ (name_opt, content) ] ->
-    let* image = Image.make_image (name_opt, "avatar", content) in
-    let* () = Image.upload_avatar image user_id in
-    Ok ()
-  | _files -> Error "More than one file provided"
-
-let is_admin user_id =
-  match get_nick user_id with
-  | Error _e -> false
-  | Ok nick -> List.mem nick App.admins
-
-let banish user_id =
-  let* nick = get_nick user_id in
-  let* email = Q.get_email user_id in
-  let* () = Q.delete_user user_id in
-  Q.upload_banished (nick, email)
-
-let delete_user user_id = Q.delete_user user_id
-
-let update_nick nick user_id =
-  if valid_nick nick then
-    if not (exist_nick nick) then Q.update_nick (nick, user_id)
-    else Error "nick already taken"
-  else Error "invalid nick"
-
-let update_email email user_id =
-  if valid_email email then
-    if not (exist_email email) then Q.update_email (email, user_id)
-    else Error "email already taken"
-  else Error "invalid email"
-
-let update_password password user_id =
-  if valid_password password then
-    let password = Bcrypt.hash password |> Bcrypt.string_of_hash in
-    Q.update_password (password, user_id)
-  else Error "invalid password"
-
-let update_metadata count label content user_id =
-  let label = Dream.html_escape label in
-  let content = Dream.html_escape content in
-  if String.length label > 200 || String.length content > 400 then
-    Error "label or content is too long"
-  else
-    let* metadata = get_metadata user_id in
-    let length = List.length metadata in
-    if count < 0 || count > length then Error "invalid count"
-    else
-      let n = max (count + 1) @@ length in
-      let metadata = Array.of_list metadata in
-      let metadata =
-        List.init n (fun i ->
-            if i = count then (label, content) else metadata.(i) )
+  let* password = Validate_str.password password in
+  let* nick = check_nick nick in
+  let* email = check_email email in
+  let* () =
+    let* opt1 = Db_user.find_user_of_nick nick in
+    let* opt2 = Db_user.find_user_of_email email in
+    let loggin_not_taken = Option.is_none opt1 && Option.is_none opt2 in
+    if loggin_not_taken then Ok ()
+    else Error (Unprocessable "nick or email already taken")
   in
-      let metadata =
-        List.filter (fun (l, c) -> not (l = "" && c = "")) metadata
+  let password_hash =
+    Bcrypt.hash (password :> string) |> Bcrypt.string_of_hash
   in
-      if List.length metadata >= 42 then Error "to many metadata"
-      else
-        let s = Marshal.to_string metadata [] in
-        let* () = Q.delete_metadata user_id in
-        Q.upload_metadata (user_id, s)
+  Db_user.add_user ~email ~nick ~password_hash
 
-let pp_metadata fmt (label, content) =
-  Format.fprintf fmt
-    {|
-<div class="row">
-    <div class="col metadata-label">%s</div>
-    <div class="col metadata-content">%s</div>
-</div>
-    |}
-    label content
+let delete_user user_id = Db_user.delete_user user_id
 
-let pp_metadata_form fmt is_last count (label, content) request =
-  let form_tag = Dream.form_tag ~action:"/profile" request in
-  let button_text = if is_last then "Add" else "Save" in
-  Format.fprintf fmt
-    {|
-<div class="row">
-    %s
-        <input name="label" class="metadata-label" value="%s"/>
-        <input name="content" class="metadata-content" value="%s"/>
-    <button name="count" value="%d" type="submit" class="btn btn-primary">%s</button>
-    </form>
-</div>
-    |}
-    form_tag label content count button_text
+let update_bio user_id bio =
+  let* bio = Validate_str.bio bio in
+  Db_user.update_bio user_id bio
 
-let pp_metadata_table fmt metadata =
-  Format.fprintf fmt
-    {|
-<div class="metadata-table">
-    %a
-</div>
-|}
-    (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_metadata)
-    metadata
+let update_nick user_id nick =
+  let* nick = check_nick nick in
+  Db_user.update_nick user_id nick
 
-let pp_metadata_table_form fmt metadata request =
-  let l = List.mapi (fun i e -> (i, e)) metadata in
-  Format.fprintf fmt
-    {|
-<div class="metadata-form-table">
-    %a
-    %a
-</div>
-|}
-    (Format.pp_print_list ~pp_sep:Format.pp_print_space
-       (fun fmt (count, metadata) ->
-         pp_metadata_form fmt false count metadata request ) )
-    l
-    (fun fmt (count, metadata) ->
-      pp_metadata_form fmt true count metadata request )
-    (List.length l, ("", ""))
+let update_email user_id email =
+  let* email = check_email email in
+  Db_user.update_email user_id email
 
-let public_profile user_id =
-  let* user = get_user user_id in
-  let user_info =
-    Format.asprintf
-      {|
-    <h1>%s</h1>
-    <br />
-    <div class="row">
-      <div class="col-md-6">
-        <blockquote>%s</blockquote>
-      </div>
-      <div class="col-md-6">
-        <img src="/user/%s/avatar" class="img-thumbnail" alt="Your avatar picture">
-      </div>
-      <a href="/discuss/%s">Speak to me !</a>
-      <div class="col-md-6">
-        %a
-      </div>
-    </div>
-|}
-      user.nick user.bio user.nick user_id pp_metadata_table user.metadata
+let update_password user_id password =
+  let* password = Validate_str.password password in
+  let password_hash =
+    Bcrypt.hash (password :> string) |> Bcrypt.string_of_hash
   in
-  Ok user_info
+  Db_user.update_password_hash user_id password_hash
+
+let get_image user_id =
+  let default_avatar_path = "/img/default_avatar.png" in
+  let* opt = Db_image.U.data user_id in
+  match opt with
+  | Some data -> Ok data
+  | None -> (
+    match Assets.read default_avatar_path with
+    | None -> Error (Internal (Db_not_found "can not find default avatar file"))
+    | Some avatar -> Ok avatar )
+
+(* TODO sql : rm image db functor, handle avatar image and transaction in db_user *)
+let upload_avatar user_id (name_opt, alt, content) =
+  let name = Option.value ~default:"" name_opt in
+  let* image = Image.build ~name ~alt content in
+  Caqti_db.Db.do_transaction @@ fun () -> Db_image.U.upload user_id image
+
+let delete_avatar user_id =
+  Caqti_db.Db.do_transaction @@ fun () -> Db_image.U.delete user_id

src/user_account.eml.html

@@ -1,28 +0,0 @@
-let f (user: User.t) request =
-  <h1><%s  Format.sprintf "Account settings" %></h1>
-  <h2>Change email</h2>
-  <%s! Dream.form_tag ~action:"/account" request %>
-    <div class="mb-3">
-      <label for="email" class="form-label">Email:</label>
-      <input name="email" type="text" class="form-control" id="email" value="<%s! user.email %>"></input>
-    </div>
-    <button type="submit" class="btn btn-primary">Save</button>
-  </form>
-  <br />
-  <br />
-  <h2>Change password</h2>
-  <%s! Dream.form_tag ~action:"/account" request %>
-    <div class="mb-3">
-      <label for="new-password" class="form-label">New password:</label>
-      <input name="new-password" type="password" class="form-control" id="new-password"></input>
-      <label for="confirm-new-password" class="form-label">Confirm new password:</label>
-      <input name="confirm-new-password" type="password" class="form-control" id="confirm-new-password"></input>
-    </div>
-    <button type="submit" class="btn btn-primary">Save</button>
-  </form>
-  <br />
-  <br />
-  <h2>Delete account</h2>
-  <%s! Dream.form_tag ~action:"/account" request %>
-    <button name="delete" id="delete-button" type="submit" class="btn btn-danger">DELETE ACCOUNT</button>
-  </form>

src/user_profile.eml.html

@@ -1,40 +0,0 @@
-let f (user: User.t) request =
-% let metadata_table = Format.asprintf "%a" (fun fmt metadata -> User.pp_metadata_table_form fmt metadata request) user.metadata in
-  <h1>Edit your profile</h1>
-  <p>Check your <a href="/user/<%s user.nick %>">public profile rendering</a>.</p>
-  <h2>Display nickname</h2>
-  <%s! Dream.form_tag ~action:"/profile" request %>
-    <div class="mb-3">
-      <label for="nick" class="form-label">Change display name</label>
-      <input name="nick" type="text" class="form-control" id="nick" value="<%s! user.nick %>"></input>
-    </div>
-    <button type="submit" class="btn btn-primary">Save</button>
-  </form>
-  <br />
-  <br />
-  <h2>Profile metadata</h2>
-  <p>Add items displayed as a table on your profile.</p>
-<%s! metadata_table %>
-  <br />
-  <br />
-  <h2>Bio</h2>
-  <%s! Dream.form_tag ~action:"/profile" request %>
-    <div class="mb-3">
-      <label for="bio" class="form-label">Change your bio</label>
-      <textarea name="bio" type="text" class="form-control" id="bio" aria-describedby="bio-help"><%s! user.bio %></textarea>
-      <div id="bio-help" class="form-text">Who are you?</div>
-    </div>
-    <button type="submit" class="btn btn-primary">Save</button>
-  </form>
-  <br />
-  <h2>Avatar</h2>
-  <img src="/user/<%s user.nick %>/avatar" class="img-thumbnail" alt="Your avatar picture" />
-  <br />
-  <br />
-  <%s! Dream.form_tag ~action:"/profile" ~enctype:`Multipart_form_data request %>
-    <br />
-    <label for="file" id="file-label" class="form-label">Change avatar</label>
-    <input id="file" class="form-control" name="file" aria-describedby="file-label" type="file" accept="image/png,image/jpeg,image/webp,image/gif">
-    <br />
-    <button class="btn btn-primary">Submit avatar!</button>
-  </form>