diff --git a/.ocamlformat b/.ocamlformat index 6f010c4..eb9f4e0 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.28.1 +version=0.27.0 assignment-operator=end-line break-cases=fit break-fun-decl=wrap diff --git a/dune-project b/dune-project index 79c6e02..7749f09 100644 --- a/dune-project +++ b/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 " "pena ") -(maintainers "swrup " "pena ") +(implicit_transitive_deps false) + +(name geochan) + (license AGPL-3.0-or-later) +(authors + "swrup " + "Léo Andrès ") + +(maintainers + "swrup " + "Léo Andrès ") + (source - (uri git+https://forge.kumikode.org/swrup/geochan.git)) -(homepage https://forge.kumikode.org/swrup/geochan) -(bug_reports https://forge.kumikode.org/swrup/geochan/issues) + (uri git+https://git.zapashcanon.fr/zapashcanon/geochan.git)) + +(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) diff --git a/geochan.opam b/geochan.opam index f6d5545..36776a8 100644 --- a/geochan.opam +++ b/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 " "pena "] -authors: ["swrup " "pena "] +maintainer: ["swrup " "Léo Andrès "] +authors: ["swrup " "Léo Andrès "] 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" -bug-reports: "https://forge.kumikode.org/swrup/geochan/issues" +homepage: "https://git.zapashcanon.fr/zapashcanon/geochan" +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" diff --git a/src/client/db.ml b/src/client/db.ml index 7e23b66..f2a3589 100644 --- a/src/client/db.ml +++ b/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; () diff --git a/src/client/html_form.ml b/src/client/html_form.ml index d83c131..223f1f4 100644 --- a/src/client/html_form.ml +++ b/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 = - El.input ~at:[ type' "hidden"; name "delete-avatar"; value "" ] () - in - let btn = mk_btn "delete current avatar" in - mk ~btn [ input_el ] ) + 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 = diff --git a/src/client/html_post.ml b/src/client/html_post.ml index be9abbf..ecbe8c4 100644 --- a/src/client/html_post.ml +++ b/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 - fun last_value -> - match quickview_id = id with - | true -> Some (rect, v) - | false -> last_value ) + 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 ] ] ) ) + | 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 @@ -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 - | Some u -> String.equal u.user_id post.poster_id ) + | None -> false + | 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 - | Some (_rect, v) -> Int.equal post.id (Page.unwrap_post_id v) ) + | 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 @@ -281,11 +281,11 @@ module Quickview = struct 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 ) ) + | None -> [] + | Some (rect, v) -> ( + match v with + | Page.Loading _ | Not_found _ -> [] + | Ready post -> mk rect post ) ) in Elr.def_children container children; container diff --git a/src/client/html_util.ml b/src/client/html_util.ml index b02e1a2..06da401 100644 --- a/src/client/html_util.ml +++ b/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 -> - (* TODO redirect after login *) - [ el_txt "Login to post a thread!" ] - | true -> [ el_txt "New thread" ] ) + | false -> + (* TODO redirect after login *) + [ el_txt "Login to post a thread!" ] + | true -> [ el_txt "New thread" ] ) in let el = El.a [] in Elr.def_at At.Name.href href_s el; diff --git a/src/client/leaflet_map.ml b/src/client/leaflet_map.ml index a963f36..5e67971 100644 --- a/src/client/leaflet_map.ml +++ b/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 - | Error err -> - Events.send_action (Map_input (Geolocation (Geo_error err))) - | Ok pos -> - Events.send_action (Map_input (Geolocation (Geo_located 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); - () ) + match pos_res with + | Error err -> + Events.send_action (Map_input (Geolocation (Geo_error err))) + | Ok pos -> + Events.send_action (Map_input (Geolocation (Geo_located 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 () @@ -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 *) - | Client_types.Geo_located _ -> "/assets/img/location_on.png" - | _ -> "/assets/img/location_off.png" ) + (* TODO need a loading animation *) + | Client_types.Geo_located _ -> "/assets/img/location_on.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.refresh (S.value t_s).catalog ); + Markers.select id_opt; + Markers.refresh (S.value t_s).catalog ); let children = mk t_s in let el = El.div ~at:[ class' "home-right" ] children in el diff --git a/src/client/model.ml b/src/client/model.ml index 2f27ad5..6d122f7 100644 --- a/src/client/model.ml +++ b/src/client/model.ml @@ -150,8 +150,8 @@ let load_page = function let load_quickview opt = opt |> Option.map (fun (rect, v) -> - ( rect - , match v with Ready _ | Not_found _ -> v | Loading _ -> load_post v ) ) + ( rect + , 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 - | Some (_, Loading post_id) -> Network.GET.post post_id - | _ -> () + begin + 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 - | 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 + 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 diff --git a/src/client/navigation.ml b/src/client/navigation.ml index f92c70d..20d6b00 100644 --- a/src/client/navigation.ml +++ b/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 - match El.at (Jstr.v "href") el with - | None -> Fmt.failwith " element with no href" - | Some href -> begin - Ev.prevent_default ev; - handle_link (Jstr.to_string href) - end + begin + if Jstr.equal (El.tag_name el) (Jstr.v "a") then + match El.at (Jstr.v "href") el with + | None -> Fmt.failwith " 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 diff --git a/src/client/network.ml b/src/client/network.ml index a16d481..2ce9fb6 100644 --- a/src/client/network.ml +++ b/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 -> - Events.send_error (Network_err e); - () - | Ok (Either.Left v) -> - on_ok v; - () - | Ok (Either.Right err) -> - Events.send_error (Err_response err); - () ) + | 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 @@ -81,13 +81,14 @@ module GET = struct 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) + 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; () @@ -154,41 +155,42 @@ module POST = struct 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); - Navigation.load Home - | 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) + 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); + Navigation.load Home + | 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; () diff --git a/src/validate_str.ml b/src/validate_str.ml index 8be1ff0..eb83428 100644 --- a/src/validate_str.ml +++ b/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 - Err.Unprocessable s ) + let s = Fmt.str "%s %a" kind_str pp_err e in + Err.Unprocessable s ) open Config diff --git a/test/config.scfg b/test/config.scfg index 49bc3e2..4ef3629 100644 --- a/test/config.scfg +++ b/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 diff --git a/test/test.ml b/test/test.ml index 8898aa0..044ba25 100644 --- a/test/test.ml +++ b/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 *)