diff --git a/.ocamlformat b/.ocamlformat index eb9f4e0..6f010c4 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.27.0 +version=0.28.1 assignment-operator=end-line break-cases=fit break-fun-decl=wrap diff --git a/geochan.opam b/geochan.opam index 36776a8..3983d35 100644 --- a/geochan.opam +++ b/geochan.opam @@ -1,53 +1,44 @@ # This file is generated by dune, edit dune-project instead 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 " "Léo Andrès "] -authors: ["swrup " "Léo Andrès "] +synopsis: "OCaml library/executable to TODO" +description: "geochan is an OCaml library/executable to TODO." +authors: ["swrup "] license: "AGPL-3.0-or-later" tags: [ - "imageboard" - "forum" - "map" - "leaflet" - "single-page-application" - "functional-reactive-programming" + "permap" "forum" "map" "local-knownledge" "ecology" "permaculture" "plant" ] -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" + "dune" {>= "2.8"} + "dream" + "lwt" + "yojson" "brr" + "leaflet" + "js_of_ocaml" + "uuidm" + "scfg" + "crunch" + "safepass" + "omd" + "lambdasoup" + "bos" "caqti" "caqti-driver-sqlite3" "conan" "conan-database" - "crunch" - "data-encoding" - "digestif" "directories" "dream" "dream-pure" "emile" - "fmt" "fpath" - "htmlit" - "js_of_ocaml" - "leaflet" - "lwt" - "note" + "lambdasoup" + "omd" "safepass" "scfg" "uri" "uuidm" - "alcotest" {with-test} - "re" {with-test} - "ocamlformat" {with-dev-setup} - "prelude" - "ocaml" {>= "5.1"} + "yojson" + "ocaml" {>= "4.08"} "odoc" {with-doc} ] build: [ @@ -64,4 +55,3 @@ build: [ "@doc" {with-doc} ] ] -dev-repo: "git+https://git.zapashcanon.fr/zapashcanon/geochan.git" diff --git a/src/client/db.ml b/src/client/db.ml index f2a3589..7e23b66 100644 --- a/src/client/db.ml +++ b/src/client/db.ml @@ -123,7 +123,6 @@ 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 223f1f4..d83c131 100644 --- a/src/client/html_form.ml +++ b/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 - | 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 ] @@ -257,13 +255,11 @@ 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 ecbe8c4..be9abbf 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 06da401..b02e1a2 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 5e67971..a963f36 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 6d122f7..2f27ad5 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,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 - 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 } @@ -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 - 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 20d6b00..f92c70d 100644 --- a/src/client/navigation.ml +++ b/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 - 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 2ce9fb6..a16d481 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,14 +81,13 @@ 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; () @@ -155,42 +154,41 @@ 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 eb83428..8be1ff0 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/src/virtual/make_config_lib.ml b/src/virtual/make_config_lib.ml index bd0af5a..0fb40c3 100644 --- a/src/virtual/make_config_lib.ml +++ b/src/virtual/make_config_lib.ml @@ -1,170 +1,3 @@ -(* TODO - custom parameter type - print a scfg - handle failures *) -module M = struct - open Scfg - - type nil = NIL - - type dir - - type param - - type ('a, 'b) directive = - { name : string - ; params : 'a - ; children : 'b - } - - type ('r, _) t = - | Bool : (param, bool) t - | Int : (param, int) t - | Float : (param, float) t - | String : (param, string) t - | Directive : - (string * (param, 'a) t_list * (dir, 'b) t_list) - -> (dir, ('a, 'b) directive) t - | Leaf : (string * (param, 'a) t_list) -> (dir, ('a, nil) directive) t - - and ('r, _) t_list = - | Nil : ('r, nil) t_list - | One : ('r, 'a) t -> ('r, 'a) t_list - | Cons : (('r, 'a) t * ('r, 'b) t_list) -> ('r, 'a * 'b) t_list - - let error () = Fmt.failwith "invalid schema" - - let conv_param : type a. (param, a) t -> string -> a = - fun param_t v -> - try - match param_t with - | Bool -> bool_of_string v - | Int -> int_of_string v - | Float -> float_of_string v - | String -> v - with Invalid_argument _ -> error () - - let rec conv_param_list : type a. (param, a) t_list -> string list -> a = - fun param_l_t l -> - match param_l_t with - | Nil -> ( match l with [] -> NIL | _ -> error () ) - | One k -> ( match l with [ hd ] -> conv_param k hd | _ -> error () ) - | Cons (k, k_l) -> ( - match l with - | [] -> error () - | hd :: tl -> (conv_param k hd, conv_param_list k_l tl) ) - - let rec conv_dir : type a. (dir, a) t -> Types.directive -> a = - fun dir_t dir -> - match dir_t with - | Directive (name, params, children) -> ( - match String.equal name dir.name with - | false -> error () - | true -> - { name - ; params = conv_param_list params dir.params - ; children = conv children dir.children - } ) - | Leaf (name, params) -> ( - match String.equal name dir.name with - | false -> error () - | true -> - { name; params = conv_param_list params dir.params; children = NIL } ) - - and conv : type a. (dir, a) t_list -> Types.config -> a = - fun dir_l_t l -> - match dir_l_t with - | Nil -> ( match l with [] -> NIL | _ -> error () ) - | One k -> ( match l with [ hd ] -> conv_dir k hd | _ -> error () ) - | Cons (k, k_l) -> ( - match l with [] -> error () | hd :: tl -> (conv_dir k hd, conv k_l tl) ) - - let ( @^ ) = fun a b -> Cons (a, b) - - let ( @+ ) = fun a b -> Cons (a, One b) - - let ( !@ ) = fun a -> One a - - let directive : type a b. - string - -> (param, a) t_list - -> (dir, b) t_list - -> (dir, (a, b) directive) t = - fun name params children -> Directive (name, params, children) - - let leaf : type a. string -> (param, a) t_list -> (dir, (a, nil) directive) t - = - fun name params -> Leaf (name, params) -end - -module M_test = struct - open M - - module Uuu = struct - module Pp = struct - let hide_data : (param, 'a) t * ('a ) -> (param, 'a) t = - fun (t, _v) -> - - let ( @^ ) = fun a b -> Cons (hide_data a, b) - - let ( @+ ) = fun a b -> Cons (hide_data a, One (hide_data b)) - - let ( !@ ) = fun a -> One (hide_data a) - end - - open Pp - - let sch = !@(leaf "cc" (!@ (String, "uu" ) ) ) - end - - let schema_1 = !@(leaf "cc" !@String) - - let schema_2 = - !@(directive "salut" (String @^ Bool @+ Float) !@(leaf "euj" !@Int)) - - let schema_3 = leaf "cc" !@String @^ leaf "cc" !@String @+ leaf "cc" !@String - - let txt_1 = Scfg.Parse.from_string {|cc param_1 - |} |> Result.get_ok - - let txt_2 = - Scfg.Parse.from_string - {|salut param_str true 0.46 { - euj 3456 - } - |} - |> Result.get_ok - - let txt_3 = - Scfg.Parse.from_string {|cc sava - cc sava - cc sava - |} - |> Result.get_ok - - let () = - let v_1 = conv schema_1 txt_1 in - let { name; params; children } = v_1 in - assert (name = "cc"); - assert (params = "param_1"); - assert (children = NIL); - - let v_2 = conv schema_2 txt_2 in - let { name; params; children } = v_2 in - assert (name = "salut"); - assert (params = ("param_str", (true, 0.46))); - assert (children.name = "euj"); - assert (children.params = 3456); - - let v_3 = conv schema_3 txt_3 in - let dir1, (dir2, dir3) = v_3 in - assert (dir1 = dir2); - assert (dir2 = dir3); - () -end - -(* ------ *) - type _ tag = | String : string tag | Bool : bool tag diff --git a/test/test.ml b/test/test.ml index 044ba25..8898aa0 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 *)