swrup/geochan
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

rm scfg wip

Browse source
This commit is contained in:
Swrup 2026-03-19 21:29:27 +01:00
parent 8c2c90b3c2
commit 872cf1b72f
13 changed files with 156 additions and 343 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.ocamlformat
View file

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

52
geochan.opam
View file

@ -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 <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
authors: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
synopsis: "OCaml library/executable to TODO"
description: "geochan is an OCaml library/executable to TODO."
authors: ["swrup <swrup@protonmail.com>"]
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"

3
src/client/db.ml
View file

@ -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;
()

16
src/client/html_form.ml
View file

@ -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 =

62
src/client/html_post.ml
View file

@ -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

8
src/client/html_util.ml
View file

@ -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;

32
src/client/leaflet_map.ml
View file

@ -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

28
src/client/model.ml
View file

@ -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

15
src/client/navigation.ml
View file

@ -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 "<a> 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 "<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

104
src/client/network.ml
View file

@ -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;
()

4
src/validate_str.ml
View file

@ -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

167
src/virtual/make_config_lib.ml
View file

@ -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

6
test/test.ml
View file

@ -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 *)