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

brr

Browse source
This commit is contained in:
Swrup 2022-04-18 03:11:31 +02:00
parent cd03f75612
commit f73e220176
20 changed files with 166 additions and 178 deletions
Download patch file Download diff file Expand all files Collapse all files

6
src/babillard_page.eml.html
View file

@ -6,7 +6,7 @@ let f request =
% {|<a class="btn btn-primary" id="new-thread-button-redirect" href="/login?redirect=%s">New Thread</a>|} (Dream.to_percent_encoded "/")
% else {|<button class="btn btn-primary on" id="new-thread-button">New Thread</button>|}
% in
<script type="text/javascript" src="/assets/js/js_babillard.js" defer="defer"></script>
<script type="text/javascript" src="/assets/js/babillard.js" defer="defer"></script>
<h1>Babillard is love ❤️</h1>
<br />
<div class="row mb-3">
@ -43,8 +43,8 @@ let f request =
<label for="file" id="file-label" class="form-label">Picture:</label>
<input id="file" name="file" aria-describedby="file-label" type="file" accept="image/png,image/jpeg,image/webp,image/gif">
<br />
<label for="alt" id="alt-label" class="form-label">Image description:</label>
<input name="alt" type="text" class="form-control" id="alt" aria-labelledby="alt-label" />
<label for="alt" id="alt-label" class="form-label off">Image description:</label>
<input name="alt" type="text" class="form-control off" id="alt" aria-labelledby="alt-label" />
<br />
<button type="submit" class="btn btn-primary" id="submit-new-thread-button" disabled>Make Thread</button>
</form>

2
src/catalog_page.eml.html
View file

@ -1,6 +1,6 @@
let f content =
<script type="text/javascript" src="/assets/js/js_catalog.js" defer="defer"></script>
<script type="text/javascript" src="/assets/js/catalog.js" defer="defer"></script>
<h1>Catalog:</h1>
<br />
<div class="row mb-3">

8
src/content/assets/css/style.css
View file

@ -118,14 +118,6 @@ blockquote.blockquote {
visibility: hidden;
}
#alt-label {
display:none;
}
#alt {
display:none;
}
a.preview-link {
text-decoration: none;
color: unset;

18
src/content/assets/js/dune
View file

@ -1,26 +1,26 @@
(rule
(target js_catalog.js)
(target catalog.js)
(deps
(file ../../../js/js_catalog.bc.js))
(file ../../../js/catalog.bc.js))
(action
(with-stdout-to
%{target}
(cat ../../../js/js_catalog.bc.js))))
(cat ../../../js/catalog.bc.js))))
(rule
(target js_babillard.js)
(target babillard.js)
(deps
(file ../../../js/js_babillard.bc.js))
(file ../../../js/babillard.bc.js))
(action
(with-stdout-to
%{target}
(cat ../../../js/js_babillard.bc.js))))
(cat ../../../js/babillard.bc.js))))
(rule
(target js_thread.js)
(target thread.js)
(deps
(file ../../../js/js_thread.bc.js))
(file ../../../js/thread.bc.js))
(action
(with-stdout-to
%{target}
(cat ../../../js/js_thread.bc.js))))
(cat ../../../js/thread.bc.js))))

2
src/delete_page.eml.html
View file

@ -1,6 +1,6 @@
let f post_preview post_id request =
<script type="text/javascript" src="/assets/js/js_catalog.js" defer="defer"></script>
<script type="text/javascript" src="/assets/js/catalog.js" defer="defer"></script>
<%s! post_preview %>
% let url = Format.sprintf "/delete/%s" post_id in
% begin match Dream.session "nick" request with

6
src/dune
View file

@ -111,9 +111,9 @@
(target content.ml)
(deps
(source_tree content)
(file content/assets/js/js_babillard.js)
(file content/assets/js/js_catalog.js)
(file content/assets/js/js_thread.js))
(file content/assets/js/babillard.js)
(file content/assets/js/catalog.js)
(file content/assets/js/thread.js))
(action
(with-stdout-to
%{null}

67
src/js/js_babillard.ml → src/js/babillard.ml
View file

@ -1,29 +1,26 @@
open Js_map
include Js_post_form
open Brr
open Utils
open Map
module Visibility = struct
let new_thread_div = Jv.get Jv.global "new-thread"
let new_thread_div = find_by_id "new-thread"
let thread_preview_div = Jv.get Jv.global "thread-preview"
let thread_preview_div = find_by_id "thread-preview"
let return_button = Jv.get Jv.global "return-button"
let return_button = find_by_id "return-button"
(* new-thread-button is new-thread-button-redirect if not logged in *)
let new_thread_button = Jv.find Jv.global "new-thread-button"
let new_thread_button = find_by_id_opt "new-thread-button"
let is_in_new_thread_mode = ref false
let set_visible el =
log "set_visible@\n";
let class_list = Jv.get el "classList" in
ignore
@@ Jv.call class_list "replace" [| Jv.of_string "off"; Jv.of_string "on" |]
El.set_class (Jstr.of_string "off") false el
let set_invisible el =
log "set_invisible@\n";
let class_list = Jv.get el "classList" in
ignore
@@ Jv.call class_list "replace" [| Jv.of_string "on"; Jv.of_string "off" |]
El.set_class (Jstr.of_string "off") true el
let to_new_thread_mode _event =
log "change_page_mode@\n";
@ -45,32 +42,32 @@ module Visibility = struct
let () =
log "add events on return/new thread button@\n";
ignore
@@ Jv.call return_button "addEventListener"
[| Jv.of_string "click"; Jv.repr to_babillard_mode |];
let (_ : Ev.listener) =
Ev.listen Ev.click to_babillard_mode (El.as_target return_button)
in
Option.iter
(fun button ->
ignore
@@ Jv.call button "addEventListener"
[| Jv.of_string "click"; Jv.repr to_new_thread_mode |] )
let (_ : Ev.listener) =
Ev.listen Ev.click to_new_thread_mode (El.as_target button)
in
() )
new_thread_button
end
module Marker = struct
let window = Jv.get Jv.global "window"
let thread_preview_div = Jv.get Jv.global "thread-preview"
let thread_preview_div = find_by_id "thread-preview"
let marker_on_click thread_preview _e =
log "marker_on_click@\n";
if not !Visibility.is_in_new_thread_mode then
ignore @@ Jv.set thread_preview_div "innerHTML" thread_preview;
Js_pretty_post.make_pretty ()
if not !Visibility.is_in_new_thread_mode then (
let inner_html = El.Prop.jstr (Jstr.of_string "innerHTML") in
El.set_prop inner_html thread_preview thread_preview_div;
Pretty_post.make_pretty () )
let on_each_feature feature layer =
log "on_each_feature@\n";
let feature_properties = Jv.get feature "properties" in
let thread_preview = Jv.get feature_properties "content" in
let thread_preview = Jv.get feature_properties "content" |> Jv.to_jstr in
Leaflet.Layer.on Leaflet.Event.Click (marker_on_click thread_preview) layer
let handle_geojson geojson =
@ -89,15 +86,17 @@ module Marker = struct
let () =
log "fetch thread geojson@\n";
let link = Jv.of_string "/markers" in
(* todo: fetch with Brr *)
let window = Jv.get Jv.global "window" in
let fetchfutur = Jv.call window "fetch" [| link |] in
ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |]
end
let lat_input = Jv.get Jv.global "lat-input"
let lat_input = find_by_id "lat-input"
let lng_input = Jv.get Jv.global "lng-input"
let lng_input = find_by_id "lng-input"
let button = Jv.get Jv.global "submit-new-thread-button"
let button = find_by_id "submit-new-thread-button"
(* set input lat/lng when clicked*)
let on_click_set_latlng e =
@ -110,12 +109,12 @@ let on_click_set_latlng e =
in
Leaflet.Map.open_popup popup map;
let lat = Leaflet.Latlng.lat latlng |> Jv.of_float in
let lng = Leaflet.Latlng.lng latlng |> Jv.of_float in
ignore @@ Jv.call lat_input "setAttribute" [| Jv.of_string "value"; lat |];
ignore @@ Jv.call lng_input "setAttribute" [| Jv.of_string "value"; lng |];
ignore @@ Jv.call button "removeAttribute" [| Jv.of_string "disabled" |] )
let lat = Leaflet.Latlng.lat latlng |> Jstr.of_float in
let lng = Leaflet.Latlng.lng latlng |> Jstr.of_float in
let value_jstr = Jstr.of_string "value" in
El.set_at value_jstr (Some lat) lat_input;
El.set_at value_jstr (Some lng) lng_input;
El.set_at (Jstr.of_string "disabled") None button )
(*add on_click callback to map*)
let () = Leaflet.Map.on Leaflet.Event.Click on_click_set_latlng map

0
src/js/catalog.ml Normal file
View file

43
src/js/dune
View file

@ -1,46 +1,53 @@
(library
(name js_post_form)
(modules js_post_form)
(libraries js_of_ocaml brr)
(name utils)
(modules utils)
(libraries brr)
(preprocess
(pps js_of_ocaml-ppx)))
(library
(name js_pretty_post)
(modules js_pretty_post)
(libraries js_of_ocaml brr unix)
(name post_form)
(modules post_form)
(libraries js_of_ocaml brr utils)
(preprocess
(pps js_of_ocaml-ppx)))
(library
(name js_map)
(modules js_map)
(libraries js_of_ocaml brr leaflet)
(name pretty_post)
(modules pretty_post)
(libraries js_of_ocaml brr unix utils)
(preprocess
(pps js_of_ocaml-ppx)))
(library
(name map)
(modules map)
(libraries js_of_ocaml brr leaflet utils)
(js_of_ocaml
(javascript_files leaflet/leaflet.js))
(preprocess
(pps js_of_ocaml-ppx)))
(executable
(name js_catalog)
(modules js_catalog)
(libraries js_of_ocaml brr js_pretty_post)
(name catalog)
(modules catalog)
(libraries js_of_ocaml brr pretty_post)
(modes js)
(preprocess
(pps js_of_ocaml-ppx)))
(executable
(name js_babillard)
(modules js_babillard)
(libraries js_of_ocaml brr js_map js_post_form js_pretty_post leaflet)
(name babillard)
(modules babillard)
(libraries js_of_ocaml brr map post_form pretty_post leaflet utils)
(modes js)
(preprocess
(pps js_of_ocaml-ppx)))
(executable
(name js_thread)
(modules js_thread)
(libraries js_of_ocaml brr js_post_form js_pretty_post)
(name thread)
(modules thread)
(libraries js_of_ocaml brr post_form pretty_post)
(modes js)
(preprocess
(pps js_of_ocaml-ppx)))

1
src/js/js_catalog.ml
View file

@ -1 +0,0 @@
include Js_pretty_post

55
src/js/js_post_form.ml
View file

@ -1,55 +0,0 @@
let log = Format.printf
(* called by clicking post_id *)
(* insert emojid into reply form *)
let insert_quote emojid _event =
log "quote@\n";
Option.iter
(fun textarea ->
let content = Jv.to_string @@ Jv.get textarea "value" in
let new_content =
if String.ends_with ~suffix:"\n" content || String.length content = 0
then (* don't skip a line *)
Format.sprintf "%s[%s] " content emojid
else Format.sprintf "%s@\n[%s] " content emojid
in
ignore @@ Jv.set textarea "value" (Jv.of_string new_content) )
Jv.(find global "reply-comment")
let () =
log "add inser_quote event on post links@\n";
let document = Jv.get Jv.global "document" in
let quote_links =
Jv.to_jv_list
@@ Jv.call document "getElementsByClassName" [| Jv.of_string "quote-link" |]
in
log "quote_links leng %d@\n" (List.length quote_links);
let add_click quote_link =
let emojid =
Jv.to_string
@@ Jv.call quote_link "getAttribute" [| Jv.of_string "data-emojid" |]
in
ignore
@@ Jv.call quote_link "addEventListener"
[| Jv.of_string "click"; Jv.repr (insert_quote emojid) |]
in
List.iter add_click quote_links
(* make image description field visible when a file is selected*)
let make_visible el _event =
let el_style = Jv.get el "style" in
ignore @@ Jv.set el_style "display" (Jv.of_string "block")
let () =
log "change image description visibility@\n";
Option.iter
(fun file_input ->
let alt_input = Jv.get Jv.global "alt" in
let alt_label = Jv.get Jv.global "alt-label" in
ignore
@@ Jv.call file_input "addEventListener"
[| Jv.of_string "change"; Jv.repr (make_visible alt_input) |];
ignore
@@ Jv.call file_input "addEventListener"
[| Jv.of_string "change"; Jv.repr (make_visible alt_label) |] )
Jv.(find global "file")

2
src/js/js_thread.ml
View file

@ -1,2 +0,0 @@
include Js_post_form
include Js_pretty_post

14
src/js/js_map.ml → src/js/map.ml
View file

@ -1,4 +1,4 @@
let log = Format.printf
open Utils
let map = Leaflet.Map.create_on "map"
@ -53,8 +53,7 @@ let on_zoomend _event =
log "on zoomend event@\n";
let zoom = Leaflet.Map.get_zoom map in
match
Brr_io.Storage.set_item storage (Jstr.of_string "zoom")
(Jv.to_jstr @@ Jv.of_int zoom)
Brr_io.Storage.set_item storage (Jstr.of_string "zoom") (Jstr.of_int zoom)
with
| (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
| Ok () -> ()
@ -81,8 +80,9 @@ module Geolocalize = struct
ignore @@ Fut.await (Brr_io.Geolocation.get l) update_location
let () =
let button = Jv.get Jv.global "geolocalize" in
ignore
@@ Jv.call button "addEventListener"
[| Jv.of_string "click"; Jv.repr geolocalize |]
let button = find_by_id "geolocalize" in
let (_ : Brr.Ev.listener) =
Brr.Ev.listen Brr.Ev.click geolocalize (Brr.El.as_target button)
in
()
end

0
src/js/js_newthread.ml → src/js/newthread.ml
View file

45
src/js/post_form.ml Normal file
View file

@ -0,0 +1,45 @@
open Brr
open Utils
(* called by clicking post_id *)
(* insert emojid into reply form *)
let insert_quote el _event =
log "quote@\n";
let emojid =
match El.at (Jstr.of_string "data-emojid") el with
| None -> "no data-emojid on element"
| Some emojid -> Jstr.to_string emojid
in
let textarea = find_by_id "reply-comment" in
let inner_html = El.Prop.jstr (Jstr.of_string "innerHTML") in
let content = Jstr.to_string @@ El.prop inner_html textarea in
let new_content =
if String.ends_with ~suffix:"\n" content || String.length content = 0 then
(* don't skip a line *)
Format.sprintf "%s[>%s] " content emojid
else Format.sprintf "%s@\n[>%s] " content emojid
in
El.set_prop inner_html (Jstr.of_string new_content) textarea
let () =
log "add inser_quote event on post links@\n";
add_event_to_class Ev.click "quote-link" insert_quote
(* make image description field visible when a file is selected*)
let make_visible el _event = El.set_class (Jstr.of_string "off") false el
let () =
log "add event to change image description visibility@\n";
match find_by_id_opt "file" with
| None -> log "no file element found, not logged in?@\n"
| Some file_input ->
let alt_input = find_by_id "alt" in
let alt_label = find_by_id "alt-label" in
let change = Ev.Type.create (Jstr.of_string "change") in
let (_ : Ev.listener) =
Ev.listen change (make_visible alt_input) (El.as_target file_input)
in
let (_ : Ev.listener) =
Ev.listen change (make_visible alt_label) (El.as_target file_input)
in
()

49
src/js/js_pretty_post.ml → src/js/pretty_post.ml
View file

@ -1,6 +1,5 @@
open Brr
let log = Format.printf
open Utils
type image_size =
| Big
@ -50,12 +49,6 @@ let render_time date_span =
| None -> failwith "no attribute data-time for date element"
| Some data_time -> Jstr.to_float data_time
in
(*
let t =
Jv.to_float
(Jv.call date_span "getAttribute" [| Jv.of_string "data-time" |])
in
*)
let t = Unix.localtime data_time in
let date =
Format.sprintf "%02d-%02d-%02d %02d:%02d" (1900 + t.tm_year) (1 + t.tm_mon)
@ -75,7 +68,7 @@ let on_hashchange _event =
let frag = Jstr.to_string @@ Uri.fragment @@ Window.location G.window in
if frag = "" then ()
else
match Document.find_el_by_id G.document (Jstr.of_string frag) with
match find_by_id_opt frag with
| None -> log "fragment not found on the page"
| Some reply ->
let () =
@ -110,9 +103,7 @@ let clone_element el =
let body = Jv.get document "body" in
ignore @@ Jv.call body "append" [| div |];
(* go back to El *)
match
Document.find_el_by_id G.document (Jstr.of_string "floating-reply-preview")
with
match find_by_id_opt "floating-reply-preview" with
| None -> failwith "error cloning element"
| Some el -> el
@ -122,15 +113,17 @@ let on_mouse_over el _event =
let reply_id =
match El.at (Jstr.of_string "data-id") el with
| None -> failwith "no data-id on element"
| Some data_id -> data_id
| Some data_id -> Jstr.to_string data_id
in
match Document.find_el_by_id G.document reply_id with
match find_by_id_opt reply_id with
| None -> failwith "error getting reply_div, this reply is not on this page"
| Some reply_div ->
(* check if it in view, if it is, just make it of class `highlight` *)
let window_height =
let window = Jv.get Jv.global "window" in
let window_height = Jv.get window "innerHeight" |> Jv.to_int in
Jv.get window "innerHeight" |> Jv.to_int
in
let reply_top = El.bound_y reply_div |> int_of_float in
if reply_top < window_height - 50 && reply_top + 50 > 0 then (
(* just highlight if reply is in viewport *)
@ -184,30 +177,21 @@ let on_mouse_out _el _event =
let make_pretty _event =
log "make pretty@\n";
let add_event_to_class ~name ~event handler =
let event = Ev.Type.create (Jstr.of_string event) in
let el_list = El.find_by_class (Jstr.of_string name) in
List.iter (fun el -> Ev.listen event (handler el) (El.as_target el)) el_list
in
let dates = El.find_by_class (Jstr.of_string "date") in
List.iter render_time dates;
(*add event image_click to all postImage*)
let () = add_event_to_class ~name:"post-image" ~event:"click" image_click in
let () = add_event_to_class Ev.click "post-image" image_click in
(*add event mouse_over/out to all reply-link *)
let () =
add_event_to_class ~name:"reply-link" ~event:"mouseover" on_mouse_over
in
let () =
add_event_to_class ~name:"reply-link" ~event:"mouseout" on_mouse_out
in
let () = add_event_to_class Ev.mouseover "reply-link" on_mouse_over in
let () = add_event_to_class Ev.mouseout "reply-link" on_mouse_out in
(* add fragment listener to mark as selected the linked post *)
(* TODO call with brr*)
let hashchange = Ev.Type.create (Jstr.of_string "hashchange") in
Ev.listen hashchange on_hashchange (Window.as_target G.window);
let (_ : Ev.listener) =
Ev.listen hashchange on_hashchange (Window.as_target G.window)
in
(* call hashchange on page load too *)
on_hashchange ()
@ -215,6 +199,7 @@ let make_pretty _event =
let () =
log "add load eventlistener to make pretty@\n";
let load = Ev.Type.create (Jstr.of_string "load") in
let (_ : Ev.listener) =
Ev.listen load make_pretty (Window.as_target G.window)
(* TODO reply can be in another thread, how to display it? if displaying it on mouseover we need to fetch it. and display it in special color. need to change pp_post in pp_babillard *)
in
()

0
src/js/thread.ml Normal file
View file

18
src/js/utils.ml Normal file
View file

@ -0,0 +1,18 @@
open Brr
let log = Format.printf
let find_by_id_opt id = Document.find_el_by_id G.document (Jstr.of_string id)
let find_by_id id =
match find_by_id_opt id with
| None -> failwith (Format.sprintf "element `%s` not found" id)
| Some el -> el
let add_event_to_class event name handler =
let el_list = El.find_by_class (Jstr.of_string name) in
List.iter
(fun el ->
let (_ : Ev.listener) = Ev.listen event (handler el) (El.as_target el) in
() )
el_list

2
src/report_page.eml.html
View file

@ -1,6 +1,6 @@
let f post_preview post_id request =
<script type="text/javascript" src="/assets/js/js_catalog.js" defer="defer"></script>
<script type="text/javascript" src="/assets/js/catalog.js" defer="defer"></script>
<%s! post_preview %>
% let url = Format.sprintf "/report/%s" post_id in
% begin match Dream.session "nick" request with

2
src/thread_page.eml.html
View file

@ -1,5 +1,5 @@
let f thread_view thread_id request =
<script type="text/javascript" src="/assets/js/js_thread.js" defer="defer"></script>
<script type="text/javascript" src="/assets/js/thread.js" defer="defer"></script>
<%s! thread_view %>
% let thread_url = Format.sprintf "/thread/%s" thread_id in
% begin match Dream.session "nick" request with