.ocamlformat

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

dune-project

@@ -1,30 +1,17 @@
 (lang dune 3.0)
+(name geochan)
 (using menhir 2.1)
-
+(implicit_transitive_deps false)
 (generate_opam_files true)
 
-(implicit_transitive_deps false)
+(authors "swrup <swrup@protonmail.com>" "pena <pena@kumikode.org>")
-
+(maintainers "swrup <swrup@protonmail.com>" "pena <pena@kumikode.org>")
-(name geochan)
-
 (license AGPL-3.0-or-later)
 
-(authors
-  "swrup <swrup@protonmail.com>"
-  "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/geochan.git))
+ (uri git+https://forge.kumikode.org/swrup/geochan.git))
-
+(homepage https://forge.kumikode.org/swrup/geochan)
-(homepage https://git.zapashcanon.fr/zapashcanon/geochan)
+(bug_reports https://forge.kumikode.org/swrup/geochan/issues)
-
-(bug_reports https://git.zapashcanon.fr/zapashcanon/geochan/issues)
-
-(documentation https://doc.zapashcanon.fr/geochan)
 
 (package
  (name geochan)

geochan.opam

@@ -3,8 +3,8 @@ opam-version: "2.0"
 synopsis: "A geo-imageboard written in OCaml"
 description:
   "Geochan is an open source imageboard with threads pinned to a geolocation."
-maintainer: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
+maintainer: ["swrup <swrup@protonmail.com>" "pena <pena@kumikode.org>"]
-authors: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
+authors: ["swrup <swrup@protonmail.com>" "pena <pena@kumikode.org>"]
 license: "AGPL-3.0-or-later"
 tags: [
   "imageboard"
@@ -14,9 +14,8 @@ tags: [
   "single-page-application"
   "functional-reactive-programming"
 ]
-homepage: "https://git.zapashcanon.fr/zapashcanon/geochan"
+homepage: "https://forge.kumikode.org/swrup/geochan"
-doc: "https://doc.zapashcanon.fr/geochan"
+bug-reports: "https://forge.kumikode.org/swrup/geochan/issues"
-bug-reports: "https://git.zapashcanon.fr/zapashcanon/geochan/issues"
 depends: [
   "dune" {>= "3.0"}
   "bos"
@@ -64,4 +63,4 @@ build: [
     "@doc" {with-doc}
   ]
 ]
-dev-repo: "git+https://git.zapashcanon.fr/zapashcanon/geochan.git"
+dev-repo: "git+https://forge.kumikode.org/swrup/geochan.git"

src/client/db.ml

@@ -123,7 +123,6 @@ let add_user_404 id =
     | _ -> session
   in
   update_session session;
-  begin
+  begin match find_user id with Some _ -> update_user None | None -> ()
-    match find_user id with Some _ -> update_user None | None -> ()
   end;
   ()

src/client/html_form.ml

@@ -148,9 +148,7 @@ let mk_comment_div t_s =
       t_s
     |> S.changes
     |> E.filter_map (fun rf ->
-           match rf.Post_form_data.is_open with
+        match rf.Post_form_data.is_open with false -> None | true -> Some true )
-           | false -> None
-           | true -> Some true )
   in
   Elr.set_has_focus ~on:focus_e textarea;
   El.div ~at:[ class' "comment-input-div" ] [ label; textarea ]
@@ -257,13 +255,11 @@ let profile user =
     let delete =
       user.avatar_info
       |> Option.map (fun _ ->
-             let input_el =
+          let input_el =
-               El.input
+            El.input ~at:[ type' "hidden"; name "delete-avatar"; value "" ] ()
-                 ~at:[ type' "hidden"; name "delete-avatar"; value "" ]
+          in
-                 ()
+          let btn = mk_btn "delete current avatar" in
-             in
+          mk ~btn [ input_el ] )
-             let btn = mk_btn "delete current avatar" in
-             mk ~btn [ input_el ] )
       |> Option.to_list
     in
     let upload =

src/client/html_post.ml

@@ -94,30 +94,30 @@ let post_id_quote =
         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
+            let quickview_id = unwrap_post_id v in
-               fun last_value ->
+            fun last_value ->
-                 match quickview_id = id with
+              match quickview_id = id with
-                 | true -> Some (rect, v)
+              | true -> Some (rect, v)
-                 | false -> last_value )
+              | false -> last_value )
         |> S.accum None
         |> S.map (function
-             | None -> [ El.button ~at [ txt ] ]
+          | None -> [ El.button ~at [ txt ] ]
-             | Some (_rect, v) -> (
+          | Some (_rect, v) -> (
-               match v with
+            match v with
-               | Loading _ ->
+            | Loading _ ->
-                 let at = [ class' "loading" ] @ at in
+              let at = [ class' "loading" ] @ at in
-                 [ El.button ~at [ txt ] ]
+              [ El.button ~at [ txt ] ]
-               | Not_found _ ->
+            | Not_found _ ->
-                 let at = [ class' "not-found" ] @ at in
+              let at = [ class' "not-found" ] @ at in
-                 [ El.button ~at [ txt ] ]
+              [ El.button ~at [ txt ] ]
-               | Ready p ->
+            | Ready p ->
-                 let at =
+              let at =
-                   [ class' "ready"
+                [ class' "ready"
-                   ; Fmt.kstr href "/thread/%d#%d" p.parent_t_id p.id
+                ; Fmt.kstr href "/thread/%d#%d" p.parent_t_id p.id
-                   ]
+                ]
-                   @ at
+                @ at
-                 in
+              in
-                 [ El.a ~at [ txt ] ] ) )
+              [ El.a ~at [ txt ] ] ) )
       in
       Elr.def_children container children;
       container
@@ -138,8 +138,8 @@ let post_menu t_s post =
     let own_post =
       S.map Model.get_user t_s
       |> S.map (function
-           | None -> false
+        | None -> false
-           | Some u -> String.equal u.user_id post.poster_id )
+        | Some u -> String.equal u.user_id post.poster_id )
     in
     def_visibility `On own_post delete;
     [ delete; report ]
@@ -221,8 +221,8 @@ let post_view t_s post =
   let is_highlighted =
     S.map (fun t -> t.Model.quickview) t_s
     |> S.map (function
-         | None -> false
+      | None -> false
-         | Some (_rect, v) -> Int.equal post.id (Page.unwrap_post_id v) )
+      | Some (_rect, v) -> Int.equal post.id (Page.unwrap_post_id v) )
   in
   Elr.def_class (Jstr.v "highlighted") is_highlighted el;
   el
@@ -281,11 +281,11 @@ module Quickview = struct
     let children =
       S.map (fun t -> t.quickview) t_s
       |> S.map (function
-           | None -> []
+        | None -> []
-           | Some (rect, v) -> (
+        | Some (rect, v) -> (
-             match v with
+          match v with
-             | Page.Loading _ | Not_found _ -> []
+          | Page.Loading _ | Not_found _ -> []
-             | Ready post -> mk rect post ) )
+          | Ready post -> mk rect post ) )
     in
     Elr.def_children container children;
     container

src/client/html_util.ml

@@ -96,10 +96,10 @@ let new_thread_link_el t_s =
   let content_s =
     is_logged_in
     |> S.map (function
-         | false ->
+      | false ->
-           (* TODO redirect after login *)
+        (* TODO redirect after login *)
-           [ el_txt "Login to post a thread!" ]
+        [ el_txt "Login to post a thread!" ]
-         | true -> [ el_txt "New thread" ] )
+      | true -> [ el_txt "New thread" ] )
   in
   let el = El.a [] in
   Elr.def_at At.Name.href href_s el;

src/client/leaflet_map.ml

@@ -84,17 +84,17 @@ let geolocalize _ev =
   let _fut : unit Fut.t =
     get l ~opts
     |> Fut.map (fun pos_res ->
-           match pos_res with
+        match pos_res with
-           | Error err ->
+        | Error err ->
-             Events.send_action (Map_input (Geolocation (Geo_error err)))
+          Events.send_action (Map_input (Geolocation (Geo_error err)))
-           | Ok pos ->
+        | Ok pos ->
-             Events.send_action (Map_input (Geolocation (Geo_located pos)));
+          Events.send_action (Map_input (Geolocation (Geo_located pos)));
-             let lat = Pos.latitude pos in
+          let lat = Pos.latitude pos in
-             let lng = Pos.longitude pos in
+          let lng = Pos.longitude pos in
-             let zoom = 17 in
+          let zoom = 17 in
-             set_view (lat, lng, zoom);
+          set_view (lat, lng, zoom);
-             Storage.set_map_view (lat, lng, zoom);
+          Storage.set_map_view (lat, lng, zoom);
-             () )
+          () )
   in
   ()
 
@@ -174,9 +174,9 @@ let mk t_s =
       ( t_s
       |> S.map (fun t -> t.Model.geolocation)
       |> S.map (function
-           (* TODO need a loading animation *)
+        (* TODO need a loading animation *)
-           | Client_types.Geo_located _ -> "/assets/img/location_on.png"
+        | Client_types.Geo_located _ -> "/assets/img/location_on.png"
-           | _ -> "/assets/img/location_off.png" )
+        | _ -> "/assets/img/location_off.png" )
       |> S.map (fun s -> s |> Jstr.v |> Option.some) )
       img;
     let el = El.button ~at:[ class' "geolocalize-btn" ] [ img ] in
@@ -205,8 +205,8 @@ let f t_s =
   |> S.map (Option.map Page.unwrap_thread_id)
   |> S.changes
   |> hold_endless (fun id_opt ->
-         Markers.select id_opt;
+      Markers.select id_opt;
-         Markers.refresh (S.value t_s).catalog );
+      Markers.refresh (S.value t_s).catalog );
   let children = mk t_s in
   let el = El.div ~at:[ class' "home-right" ] children in
   el

src/client/model.ml

@@ -150,8 +150,8 @@ let load_page = function
 let load_quickview opt =
   opt
   |> Option.map (fun (rect, v) ->
-         ( rect
+      ( rect
-         , match v with Ready _ | Not_found _ -> v | Loading _ -> load_post v ) )
+      , match v with Ready _ | Not_found _ -> v | Loading _ -> load_post v ) )
 
 let load_model t =
   let session = Db.get_session () in
@@ -258,10 +258,9 @@ let do_action : Client_types.action -> t -> t =
     let quickview =
       opt |> Option.map (fun (rect, v) -> (rect, Loading v)) |> load_quickview
     in
-    begin
+    begin match quickview with
-      match quickview with
+    | Some (_, Loading post_id) -> Network.GET.post post_id
-      | Some (_, Loading post_id) -> Network.GET.post post_id
+    | _ -> ()
-      | _ -> ()
     end;
     { t with quickview }
   | Image_change opened_image -> { t with opened_image }
@@ -270,15 +269,14 @@ let do_action : Client_types.action -> t -> t =
 let do_data_update : Client_types.data_update -> t -> t =
  fun action t ->
   Fmt.pr {|do data update: "%a"@.|} pp_data_update action;
-  begin
+  begin match action with
-    match action with
+  | Post_update v -> Db.add_post v
-    | Post_update v -> Db.add_post v
+  | Thread_update thread_w_reply ->
-    | Thread_update thread_w_reply ->
+    Db.update_thread_w_reply (Some thread_w_reply)
-      Db.update_thread_w_reply (Some thread_w_reply)
+  | Catalog_update l -> Db.update_catalog l
-    | Catalog_update l -> Db.update_catalog l
+  | User_update u -> Db.update_user (Some u)
-    | User_update u -> Db.update_user (Some u)
+  | Reports_update reports -> Db.update_reports reports
-    | Reports_update reports -> Db.update_reports reports
+  | Session_update session -> Db.update_session session
-    | Session_update session -> Db.update_session session
   end;
   load_model t
 

src/client/navigation.ml

@@ -72,14 +72,13 @@ let on_link_click () =
   let navigation_handler ev =
     (* TODO rm magick if possible *)
     let el : El.t = Obj.magic (Ev.target ev) in
-    begin
+    begin if Jstr.equal (El.tag_name el) (Jstr.v "a") then
-      if Jstr.equal (El.tag_name el) (Jstr.v "a") then
+      match El.at (Jstr.v "href") el with
-        match El.at (Jstr.v "href") el with
+      | None -> Fmt.failwith "<a> element with no href"
-        | None -> Fmt.failwith "<a> element with no href"
+      | Some href -> begin
-        | Some href -> begin
+        Ev.prevent_default ev;
-          Ev.prevent_default ev;
+        handle_link (Jstr.to_string href)
-          handle_link (Jstr.to_string href)
+      end
-        end
     end
   in
   hold_on body Ev.click navigation_handler

src/client/network.ml

@@ -34,15 +34,15 @@ let handle_response meth fetch read_ok on_ok =
   let f res =
     read_response res
     |> Fut.map (function
-         | Error e ->
+      | Error e ->
-           Events.send_error (Network_err e);
+        Events.send_error (Network_err e);
-           ()
+        ()
-         | Ok (Either.Left v) ->
+      | Ok (Either.Left v) ->
-           on_ok v;
+        on_ok v;
-           ()
+        ()
-         | Ok (Either.Right err) ->
+      | Ok (Either.Right err) ->
-           Events.send_error (Err_response err);
+        Events.send_error (Err_response err);
-           () )
+        () )
   in
   Fut.bind (fetch ()) f
 
@@ -81,14 +81,13 @@ module GET = struct
    fun req v ->
     let open Client_types in
     let open Events in
-    begin
+    begin match req with
-      match req with
+    | Catalog -> send_data_update (Catalog_update v)
-      | Catalog -> send_data_update (Catalog_update v)
+    | Thread _id -> send_data_update (Thread_update v)
-      | Thread _id -> send_data_update (Thread_update v)
+    | Post _id -> send_data_update (Post_update v)
-      | Post _id -> send_data_update (Post_update v)
+    | Admin -> send_data_update (Reports_update v)
-      | Admin -> send_data_update (Reports_update v)
+    | User _id -> send_data_update (User_update v)
-      | User _id -> send_data_update (User_update v)
+    | Session -> send_data_update (Session_update v)
-      | Session -> send_data_update (Session_update v)
     end;
     ()
 
@@ -155,42 +154,41 @@ module POST = struct
    fun o v ->
     let open Client_types in
     let open Events in
-    begin
+    begin match o with
-      match o with
+    | Home ->
-      | Home ->
+      send_data_update (Thread_update v);
-        send_data_update (Thread_update v);
+      send_action (Post_form_change Form_reset);
-        send_action (Post_form_change Form_reset);
+      let id = v.op.id in
-        let id = v.op.id in
+      Navigation.load (Thread (Loading id))
-        Navigation.load (Thread (Loading id))
+    | Thread _ ->
-      | Thread _ ->
+      (* server respond to successful POST with full thread *)
-        (* server respond to successful POST with full thread *)
+      send_data_update (Thread_update v);
-        send_data_update (Thread_update v);
+      send_action (Post_form_change Form_reset);
-        send_action (Post_form_change Form_reset);
+      let id = v.op.id in
-        let id = v.op.id in
+      Navigation.load (Thread (Loading id))
-        Navigation.load (Thread (Loading id))
+    | Register ->
-      | Register ->
+      send_data_update (Session_update v);
-        send_data_update (Session_update v);
+      Navigation.load Profile
-        Navigation.load Profile
+    | Login ->
-      | Login ->
+      send_data_update (Session_update v);
-        send_data_update (Session_update v);
+      Navigation.load Home
-        Navigation.load Home
+    | Logout ->
-      | Logout ->
+      send_data_update (Session_update v);
-        send_data_update (Session_update v);
+      Navigation.load Home
-        Navigation.load Home
+    | Delete _ -> (
-      | Delete _ -> (
+      let is_op = Int.equal v.id v.parent_t_id in
-        let is_op = Int.equal v.id v.parent_t_id in
+      match is_op with
-        match is_op with
+      | true -> Navigation.load Home
-        | true -> Navigation.load Home
+      | false -> Navigation.load (Thread (Loading v.parent_t_id)) )
-        | false -> Navigation.load (Thread (Loading v.parent_t_id)) )
+    | Report _ ->
-      | Report _ ->
+      send_data_update (Reports_update v);
-        send_data_update (Reports_update v);
+      (* TODO need redirection to page before report here *)
-        (* TODO need redirection to page before report here *)
+      Navigation.load Home
-        Navigation.load Home
+    | Admin_ignore _ -> send_data_update (Reports_update v)
-      | Admin_ignore _ -> send_data_update (Reports_update v)
+    | Admin_delete _ -> ()
-      | Admin_delete _ -> ()
+    | Admin_banish _ -> ()
-      | Admin_banish _ -> ()
+    | Profile -> send_data_update (Session_update v)
-      | Profile -> send_data_update (Session_update v)
+    | Account -> send_data_update (Session_update v)
-      | Account -> send_data_update (Session_update v)
     end;
     ()
 

src/validate_str.ml

@@ -63,8 +63,8 @@ let map_err_to_invalid_submission ~kind_str f =
  fun s ->
   f s
   |> Result.map_error (fun e ->
-         let s = Fmt.str "%s %a" kind_str pp_err e in
+      let s = Fmt.str "%s %a" kind_str pp_err e in
-         Err.Unprocessable s )
+      Err.Unprocessable s )
 
 open Config
 

test/config.scfg

@@ -1,7 +1,7 @@
 default_logger true
 custom_logger true
 admin admin
-source_code_url "https://git.zapashcanon.fr/swrup/geochan"
+source_code_url "https://forge.kumikode.org/swrup/geochan"
 hostname "localhost"
 port 3696
 csrf_lifetime 3600

test/test.ml

@@ -183,7 +183,7 @@ module Test_post = struct
        let* expected_comment =
          Comment.of_string comment
          |> Result.map_error (fun s ->
-                Err.Unprocessable (Fmt.str "comment: %s" s) )
+             Err.Unprocessable (Fmt.str "comment: %s" s) )
        in
        let expected_op =
          { id = post_id
@@ -221,7 +221,7 @@ module Test_post = struct
        let* expected_comment =
          Comment.of_string comment
          |> Result.map_error (fun s ->
-                Err.Unprocessable (Fmt.str "comment: %s" s) )
+             Err.Unprocessable (Fmt.str "comment: %s" s) )
        in
        let expected_post =
          { id = post.id
@@ -256,7 +256,7 @@ module Test_post = struct
       let* expected_comment =
         Comment.of_string comment
         |> Result.map_error (fun s ->
-               Err.Unprocessable (Fmt.str "comment: %s" s) )
+            Err.Unprocessable (Fmt.str "comment: %s" s) )
       in
       (* image read/write to file for thumbnail creation + strip exif change image data
          thumbnail dimension can be <> than image dimension *)