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 assignment-operator=end-line
break-cases=fit break-cases=fit
break-fun-decl=wrap break-fun-decl=wrap

52
geochan.opam
View file

@ -1,53 +1,44 @@
# This file is generated by dune, edit dune-project instead # This file is generated by dune, edit dune-project instead
opam-version: "2.0" opam-version: "2.0"
synopsis: "A geo-imageboard written in OCaml" synopsis: "OCaml library/executable to TODO"
description: description: "geochan is an OCaml library/executable to TODO."
"Geochan is an open source imageboard with threads pinned to a geolocation." authors: ["swrup <swrup@protonmail.com>"]
maintainer: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
authors: ["swrup <swrup@protonmail.com>" "Léo Andrès <contact@ndrs.fr>"]
license: "AGPL-3.0-or-later" license: "AGPL-3.0-or-later"
tags: [ tags: [
"imageboard" "permap" "forum" "map" "local-knownledge" "ecology" "permaculture" "plant"
"forum"
"map"
"leaflet"
"single-page-application"
"functional-reactive-programming"
] ]
homepage: "https://git.zapashcanon.fr/zapashcanon/geochan"
doc: "https://doc.zapashcanon.fr/geochan"
bug-reports: "https://git.zapashcanon.fr/zapashcanon/geochan/issues"
depends: [ depends: [
"dune" {>= "3.0"} "dune" {>= "2.8"}
"bos" "dream"
"lwt"
"yojson"
"brr" "brr"
"leaflet"
"js_of_ocaml"
"uuidm"
"scfg"
"crunch"
"safepass"
"omd"
"lambdasoup"
"bos"
"caqti" "caqti"
"caqti-driver-sqlite3" "caqti-driver-sqlite3"
"conan" "conan"
"conan-database" "conan-database"
"crunch"
"data-encoding"
"digestif"
"directories" "directories"
"dream" "dream"
"dream-pure" "dream-pure"
"emile" "emile"
"fmt"
"fpath" "fpath"
"htmlit" "lambdasoup"
"js_of_ocaml" "omd"
"leaflet"
"lwt"
"note"
"safepass" "safepass"
"scfg" "scfg"
"uri" "uri"
"uuidm" "uuidm"
"alcotest" {with-test} "yojson"
"re" {with-test} "ocaml" {>= "4.08"}
"ocamlformat" {with-dev-setup}
"prelude"
"ocaml" {>= "5.1"}
"odoc" {with-doc} "odoc" {with-doc}
] ]
build: [ build: [
@ -64,4 +55,3 @@ build: [
"@doc" {with-doc} "@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 | _ -> session
in in
update_session session; 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; end;
() ()

16
src/client/html_form.ml
View file

@ -148,9 +148,7 @@ let mk_comment_div t_s =
t_s t_s
|> S.changes |> S.changes
|> E.filter_map (fun rf -> |> 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 in
Elr.set_has_focus ~on:focus_e textarea; Elr.set_has_focus ~on:focus_e textarea;
El.div ~at:[ class' "comment-input-div" ] [ label; textarea ] El.div ~at:[ class' "comment-input-div" ] [ label; textarea ]
@ -257,13 +255,11 @@ let profile user =
let delete = let delete =
user.avatar_info user.avatar_info
|> Option.map (fun _ -> |> 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 |> Option.to_list
in in
let upload = 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.map (fun t -> t.Model.quickview) t_s
|> S.changes |> E.filter_map Fun.id |> S.changes |> E.filter_map Fun.id
|> E.map (fun (rect, v) -> |> 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.accum None
|> S.map (function |> 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 in
Elr.def_children container children; Elr.def_children container children;
container container
@ -138,8 +138,8 @@ let post_menu t_s post =
let own_post = let own_post =
S.map Model.get_user t_s S.map Model.get_user t_s
|> S.map (function |> 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 in
def_visibility `On own_post delete; def_visibility `On own_post delete;
[ delete; report ] [ delete; report ]
@ -221,8 +221,8 @@ let post_view t_s post =
let is_highlighted = let is_highlighted =
S.map (fun t -> t.Model.quickview) t_s S.map (fun t -> t.Model.quickview) t_s
|> S.map (function |> 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 in
Elr.def_class (Jstr.v "highlighted") is_highlighted el; Elr.def_class (Jstr.v "highlighted") is_highlighted el;
el el
@ -281,11 +281,11 @@ module Quickview = struct
let children = let children =
S.map (fun t -> t.quickview) t_s S.map (fun t -> t.quickview) t_s
|> S.map (function |> 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 in
Elr.def_children container children; Elr.def_children container children;
container container

8
src/client/html_util.ml
View file

@ -96,10 +96,10 @@ let new_thread_link_el t_s =
let content_s = let content_s =
is_logged_in is_logged_in
|> S.map (function |> 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 in
let el = El.a [] in let el = El.a [] in
Elr.def_at At.Name.href href_s el; 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 = let _fut : unit Fut.t =
get l ~opts get l ~opts
|> Fut.map (fun pos_res -> |> 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 in
() ()
@ -174,9 +174,9 @@ let mk t_s =
( t_s ( t_s
|> S.map (fun t -> t.Model.geolocation) |> S.map (fun t -> t.Model.geolocation)
|> S.map (function |> 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) ) |> S.map (fun s -> s |> Jstr.v |> Option.some) )
img; img;
let el = El.button ~at:[ class' "geolocalize-btn" ] [ img ] in 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.map (Option.map Page.unwrap_thread_id)
|> S.changes |> S.changes
|> hold_endless (fun id_opt -> |> 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 children = mk t_s in
let el = El.div ~at:[ class' "home-right" ] children in let el = El.div ~at:[ class' "home-right" ] children in
el el

28
src/client/model.ml
View file

@ -150,8 +150,8 @@ let load_page = function
let load_quickview opt = let load_quickview opt =
opt opt
|> Option.map (fun (rect, v) -> |> 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 load_model t =
let session = Db.get_session () in let session = Db.get_session () in
@ -258,10 +258,9 @@ let do_action : Client_types.action -> t -> t =
let quickview = let quickview =
opt |> Option.map (fun (rect, v) -> (rect, Loading v)) |> load_quickview opt |> Option.map (fun (rect, v) -> (rect, Loading v)) |> load_quickview
in 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; end;
{ t with quickview } { t with quickview }
| Image_change opened_image -> { t with opened_image } | 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 = let do_data_update : Client_types.data_update -> t -> t =
fun action t -> fun action t ->
Fmt.pr {|do data update: "%a"@.|} pp_data_update action; 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; end;
load_model t load_model t

15
src/client/navigation.ml
View file

@ -72,14 +72,13 @@ let on_link_click () =
let navigation_handler ev = let navigation_handler ev =
(* TODO rm magick if possible *) (* TODO rm magick if possible *)
let el : El.t = Obj.magic (Ev.target ev) in 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 end
in in
hold_on body Ev.click navigation_handler 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 = let f res =
read_response res read_response res
|> Fut.map (function |> 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 in
Fut.bind (fetch ()) f Fut.bind (fetch ()) f
@ -81,14 +81,13 @@ module GET = struct
fun req v -> fun req v ->
let open Client_types in let open Client_types in
let open Events 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; end;
() ()
@ -155,42 +154,41 @@ module POST = struct
fun o v -> fun o v ->
let open Client_types in let open Client_types in
let open Events 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; end;
() ()

4
src/validate_str.ml
View file

@ -63,8 +63,8 @@ let map_err_to_invalid_submission ~kind_str f =
fun s -> fun s ->
f s f s
|> Result.map_error (fun e -> |> 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 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 = type _ tag =
| String : string tag | String : string tag
| Bool : bool tag | Bool : bool tag

6
test/test.ml
View file

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