.ocamlformat

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

dune-project

@@ -1,17 +1,30 @@
 (lang dune 3.0)
-(name geochan)
 (using menhir 2.1)
-(implicit_transitive_deps false)
+
 (generate_opam_files true)
 
-(authors "swrup <swrup@protonmail.com>" "pena <pena@kumikode.org>")
+(implicit_transitive_deps false)
-(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://forge.kumikode.org/swrup/geochan.git))
+ (uri git+https://git.zapashcanon.fr/zapashcanon/geochan.git))
-(homepage https://forge.kumikode.org/swrup/geochan)
+
-(bug_reports https://forge.kumikode.org/swrup/geochan/issues)
+(homepage https://git.zapashcanon.fr/zapashcanon/geochan)
+
+(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>" "pena <pena@kumikode.org>"]
+maintainer: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
-authors: ["swrup <swrup@protonmail.com>" "pena <pena@kumikode.org>"]
+authors: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
 license: "AGPL-3.0-or-later"
 tags: [
   "imageboard"
@@ -14,8 +14,9 @@ tags: [
   "single-page-application"
   "functional-reactive-programming"
 ]
-homepage: "https://forge.kumikode.org/swrup/geochan"
+homepage: "https://git.zapashcanon.fr/zapashcanon/geochan"
-bug-reports: "https://forge.kumikode.org/swrup/geochan/issues"
+doc: "https://doc.zapashcanon.fr/geochan"
+bug-reports: "https://git.zapashcanon.fr/zapashcanon/geochan/issues"
 depends: [
   "dune" {>= "3.0"}
   "bos"
@@ -63,4 +64,4 @@ build: [
     "@doc" {with-doc}
   ]
 ]
-dev-repo: "git+https://forge.kumikode.org/swrup/geochan.git"
+dev-repo: "git+https://git.zapashcanon.fr/zapashcanon/geochan.git"

src/client/db.ml

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

src/client/html_form.ml

@@ -148,7 +148,9 @@ let mk_comment_div t_s =
       t_s
     |> S.changes
     |> E.filter_map (fun rf ->
-        match rf.Post_form_data.is_open with false -> None | true -> Some true )
+           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 ]
@@ -255,11 +257,13 @@ let profile user =
     let delete =
       user.avatar_info
       |> Option.map (fun _ ->
-          let input_el =
+             let input_el =
-            El.input ~at:[ type' "hidden"; name "delete-avatar"; value "" ] ()
+               El.input
-          in
+                 ~at:[ type' "hidden"; name "delete-avatar"; value "" ]
-          let btn = mk_btn "delete current avatar" in
+                 ()
-          mk ~btn [ input_el ] )
+             in
+             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,9 +258,10 @@ let do_action : Client_types.action -> t -> t =
     let quickview =
       opt |> Option.map (fun (rect, v) -> (rect, Loading v)) |> load_quickview
     in
-    begin match quickview with
+    begin
-    | Some (_, Loading post_id) -> Network.GET.post post_id
+      match quickview with
-    | _ -> ()
+      | Some (_, Loading post_id) -> Network.GET.post post_id
+      | _ -> ()
     end;
     { t with quickview }
   | Image_change opened_image -> { t with opened_image }
@@ -269,14 +270,15 @@ 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 match action with
+  begin
-  | Post_update v -> Db.add_post v
+    match action with
-  | Thread_update thread_w_reply ->
+    | Post_update v -> Db.add_post v
-    Db.update_thread_w_reply (Some thread_w_reply)
+    | Thread_update thread_w_reply ->
-  | Catalog_update l -> Db.update_catalog l
+      Db.update_thread_w_reply (Some thread_w_reply)
-  | User_update u -> Db.update_user (Some u)
+    | Catalog_update l -> Db.update_catalog l
-  | Reports_update reports -> Db.update_reports reports
+    | User_update u -> Db.update_user (Some u)
-  | Session_update session -> Db.update_session session
+    | Reports_update reports -> Db.update_reports reports
+    | Session_update session -> Db.update_session session
   end;
   load_model t
 

src/client/navigation.ml

@@ -72,13 +72,14 @@ let on_link_click () =
   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
+    begin
-      match El.at (Jstr.v "href") el with
+      if Jstr.equal (El.tag_name el) (Jstr.v "a") then
-      | None -> Fmt.failwith "<a> element with no href"
+        match El.at (Jstr.v "href") el with
-      | Some href -> begin
+        | None -> Fmt.failwith "<a> element with no href"
-        Ev.prevent_default ev;
+        | Some href -> begin
-        handle_link (Jstr.to_string href)
+          Ev.prevent_default ev;
-      end
+          handle_link (Jstr.to_string href)
+        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,13 +81,14 @@ module GET = struct
    fun req v ->
     let open Client_types in
     let open Events in
-    begin match req with
+    begin
-    | Catalog -> send_data_update (Catalog_update v)
+      match req with
-    | Thread _id -> send_data_update (Thread_update v)
+      | Catalog -> send_data_update (Catalog_update v)
-    | Post _id -> send_data_update (Post_update v)
+      | Thread _id -> send_data_update (Thread_update v)
-    | Admin -> send_data_update (Reports_update v)
+      | Post _id -> send_data_update (Post_update v)
-    | User _id -> send_data_update (User_update v)
+      | Admin -> send_data_update (Reports_update v)
-    | Session -> send_data_update (Session_update v)
+      | User _id -> send_data_update (User_update v)
+      | Session -> send_data_update (Session_update v)
     end;
     ()
 
@@ -154,41 +155,42 @@ module POST = struct
    fun o v ->
     let open Client_types in
     let open Events in
-    begin match o with
+    begin
-    | Home ->
+      match o with
-      send_data_update (Thread_update v);
+      | Home ->
-      send_action (Post_form_change Form_reset);
+        send_data_update (Thread_update v);
-      let id = v.op.id in
+        send_action (Post_form_change Form_reset);
-      Navigation.load (Thread (Loading id))
+        let id = v.op.id in
-    | Thread _ ->
+        Navigation.load (Thread (Loading id))
-      (* server respond to successful POST with full thread *)
+      | Thread _ ->
-      send_data_update (Thread_update v);
+        (* server respond to successful POST with full thread *)
-      send_action (Post_form_change Form_reset);
+        send_data_update (Thread_update v);
-      let id = v.op.id in
+        send_action (Post_form_change Form_reset);
-      Navigation.load (Thread (Loading id))
+        let id = v.op.id in
-    | Register ->
+        Navigation.load (Thread (Loading id))
-      send_data_update (Session_update v);
+      | Register ->
-      Navigation.load Profile
+        send_data_update (Session_update v);
-    | Login ->
+        Navigation.load Profile
-      send_data_update (Session_update v);
+      | Login ->
-      Navigation.load Home
+        send_data_update (Session_update v);
-    | Logout ->
+        Navigation.load Home
-      send_data_update (Session_update v);
+      | Logout ->
-      Navigation.load Home
+        send_data_update (Session_update v);
-    | Delete _ -> (
+        Navigation.load Home
-      let is_op = Int.equal v.id v.parent_t_id in
+      | Delete _ -> (
-      match is_op with
+        let is_op = Int.equal v.id v.parent_t_id in
-      | true -> Navigation.load Home
+        match is_op with
-      | false -> Navigation.load (Thread (Loading v.parent_t_id)) )
+        | true -> Navigation.load Home
-    | Report _ ->
+        | false -> Navigation.load (Thread (Loading v.parent_t_id)) )
-      send_data_update (Reports_update v);
+      | Report _ ->
-      (* TODO need redirection to page before report here *)
+        send_data_update (Reports_update v);
-      Navigation.load Home
+        (* TODO need redirection to page before report here *)
-    | Admin_ignore _ -> send_data_update (Reports_update v)
+        Navigation.load Home
-    | Admin_delete _ -> ()
+      | Admin_ignore _ -> send_data_update (Reports_update v)
-    | Admin_banish _ -> ()
+      | Admin_delete _ -> ()
-    | Profile -> send_data_update (Session_update v)
+      | Admin_banish _ -> ()
-    | Account -> send_data_update (Session_update v)
+      | Profile -> 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://forge.kumikode.org/swrup/geochan"
+source_code_url "https://git.zapashcanon.fr/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 *)