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

move js to js/, fix code duplication, make post prettier on babillard

Browse source 
too
This commit is contained in:
Swrup 2022-02-14 17:09:29 +01:00
parent 37446d9e1f
commit f9b77948b2
13 changed files with 221 additions and 349 deletions
Download patch file Download diff file Expand all files Collapse all files

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

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

30
src/dune
View file

@ -31,36 +31,6 @@
(preprocess
(pps lwt_ppx)))
(executable
(name js_babillard)
(modules js_babillard)
(libraries js_of_ocaml brr)
(modes js)
(js_of_ocaml
(javascript_files leaflet/leaflet.js))
(preprocess
(pps js_of_ocaml-ppx)))
(executable
(name js_newthread)
(modules js_newthread)
(libraries js_of_ocaml brr)
(modes js)
(js_of_ocaml
(javascript_files leaflet/leaflet.js))
(preprocess
(pps js_of_ocaml-ppx)))
(executable
(name js_thread)
(modules js_thread)
(libraries js_of_ocaml brr)
(modes js)
(js_of_ocaml
(javascript_files leaflet/leaflet.js))
(preprocess
(pps js_of_ocaml-ppx)))
(rule
(targets template.ml)
(deps template.eml.html)

46
src/js/dune Normal file
View file

@ -0,0 +1,46 @@
(library
(name js_post_form)
(modules js_post_form)
(libraries js_of_ocaml brr)
(preprocess
(pps js_of_ocaml-ppx)))
(library
(name js_pretty_post)
(modules js_pretty_post)
(libraries js_of_ocaml brr)
(preprocess
(pps js_of_ocaml-ppx)))
(library
(name js_map)
(modules js_map)
(libraries js_of_ocaml brr js_pretty_post)
(js_of_ocaml
(javascript_files leaflet/leaflet.js))
(preprocess
(pps js_of_ocaml-ppx)))
(executable
(name js_babillard)
(modules js_babillard)
(libraries js_of_ocaml brr js_map)
(modes js)
(preprocess
(pps js_of_ocaml-ppx)))
(executable
(name js_newthread)
(modules js_newthread)
(libraries js_of_ocaml brr js_map js_post_form)
(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)
(modes js)
(preprocess
(pps js_of_ocaml-ppx)))

1
src/js/js_babillard.ml Normal file
View file

@ -0,0 +1 @@
include Js_map

10
src/js_babillard.ml → src/js/js_map.ml
View file

@ -1,6 +1,5 @@
let log = Format.printf
(*TODO fix duplicate modules *)
module Leaflet = struct
(* get the leaflet object *)
let leaflet =
@ -125,6 +124,7 @@ module Marker = struct
Jv.to_string
(Jv.call board_div "getAttribute" [| Jv.of_string "data-board" |])
(*todo do this in js_babillard*)
let marker_on_click thread_preview thread_id _e =
log "marker_on_click@.";
let thread_id = Jv.to_string thread_id in
@ -134,6 +134,7 @@ module Marker = struct
let link = Format.sprintf "/%s/%s" board thread_id in
ignore @@ Jv.set thread_link "href" (Jv.of_string link);
ignore @@ Jv.set thread_link "innerText" (Jv.of_string "[View Thread]");
let _ = Js_pretty_post.make_pretty () in
()
let on_each_feature feature layer =
@ -151,10 +152,17 @@ module Marker = struct
let handle_geojson geojson =
log "handle_geojson@.";
log "feed geojson to leaflet@.";
(* make markers unresponsive on newthread page*)
match Jv.find Jv.global "newthread" with
| None ->
let dict = Jv.obj [| ("onEachFeature", Jv.repr on_each_feature) |] in
let layer = Jv.call Leaflet.leaflet "geoJSON" [| geojson; dict |] in
let _marker_layer = Jv.call layer "addTo" [| Leaflet.map |] in
()
| Some _ ->
let layer = Jv.call Leaflet.leaflet "geoJSON" [| geojson |] in
let _marker_layer = Jv.call layer "addTo" [| Leaflet.map |] in
()
let markers_handle_response response =
log "markers_handle_response@.";

36
src/js/js_newthread.ml Normal file
View file

@ -0,0 +1,36 @@
open Js_map
include Js_post_form
let log = Format.printf
(* set input lat/lng when clicked and make new thread form visible *)
let on_click e =
log "on_click@.";
let lat_lng = Jv.get e "latlng" in
ignore @@ Jv.call Leaflet.popup "setLatLng" [| lat_lng |];
ignore
@@ Jv.call Leaflet.popup "setContent" [| Jv.of_string "create thread here" |];
ignore @@ Jv.call Leaflet.popup "openOn" [| Leaflet.map |];
let lat = Jv.get lat_lng "lat" in
let lng = Jv.get lat_lng "lng" in
let lat_input = Jv.get Jv.global "lat_input" in
let lng_input = Jv.get Jv.global "lng_input" in
ignore @@ Jv.call lat_input "setAttribute" [| Jv.of_string "value"; lat |];
ignore @@ Jv.call lng_input "setAttribute" [| Jv.of_string "value"; lng |];
let form_div = Jv.get Jv.global "newthread-form" in
ignore
@@ Jv.call form_div "setAttribute"
[| Jv.of_string "style"; Jv.of_string "visibility:visible" |];
let newthread_div = Jv.get Jv.global "newthread" in
ignore
@@ Jv.call newthread_div "setAttribute"
[| Jv.of_string "style"; Jv.of_string "visibility:hidden" |];
()
(*add on_click callback to map*)
let () =
ignore
@@ Jv.call Leaflet.map "on" [| Jv.of_string "click"; Jv.repr on_click |]

40
src/js/js_post_form.ml Normal file
View file

@ -0,0 +1,40 @@
let log = Format.printf
(* called by clicking post_id *)
(* insert id into reply form *)
let insert_quote post_id =
log "quote@.";
match Jv.(find global "replyComment") with
| None -> Jv.undefined
| Some comment_textarea ->
let content = Jv.get comment_textarea "value" in
let new_content =
Jv.call content "concat"
[| Jv.of_string "\n>>"; post_id; Jv.of_string " " |]
in
ignore @@ Jv.set comment_textarea "value" new_content;
Jv.undefined
let () = Jv.set Jv.global "insert_quote" (Jv.repr insert_quote)
(* 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@.";
let file_input = Jv.find Jv.global "file" in
match file_input with
| None -> () (*not post form on the page, not logged in*)
| Some file_input ->
let alt_input = Jv.get Jv.global "alt" in
let alt_label = Jv.get Jv.global "altLabel" 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) |];
()

75
src/js/js_pretty_post.ml Normal file
View file

@ -0,0 +1,75 @@
let log = Format.printf
(*change postImage class to make it bigger/smaller on click*)
let image_click post_image event =
log "image_click@.";
let current_class =
Jv.to_string @@ Jv.call post_image "getAttribute" [| Jv.of_string "class" |]
in
let new_class =
match current_class with
| "postImage" -> "postImageBig"
| "postImageBig" -> "postImage"
| _ -> failwith "invalid image class name"
in
ignore
@@ Jv.call post_image "setAttribute"
[| Jv.of_string "class"; Jv.of_string new_class |];
(*prevent opening image in new tab*)
ignore @@ Jv.call event "preventDefault" [||];
()
let render_time date_span =
log "render time@.";
let unix_time =
float_of_int
(Jv.to_int
(Jv.call date_span "getAttribute" [| Jv.of_string "data-time" |]) )
in
(*use float because int overflow*)
let time_millisecs = 1000.0 *. unix_time in
let date_constructor = Jv.get Jv.global "Date" in
let date = Jv.new' date_constructor [| Jv.of_float time_millisecs |] in
let year = Jv.to_int @@ Jv.call date "getFullYear" [||] in
(*the month is 0-indexed*)
let month = (Jv.to_int @@ Jv.call date "getMonth" [||]) + 1 in
let day = Jv.to_int @@ Jv.call date "getDate" [||] in
let hour = Jv.to_int @@ Jv.call date "getHours" [||] in
let min = Jv.to_int @@ Jv.call date "getMinutes" [||] in
let date_string =
Format.sprintf "%02d-%02d-%02d %02d:%02d" year month day hour min
in
ignore @@ Jv.set date_span "innerHTML" (Jv.of_string date_string);
()
let make_pretty _ =
log "make pretty@.";
let document = Jv.get Jv.global "document" in
let times =
Jv.to_jv_list
@@ Jv.call document "getElementsByClassName" [| Jv.of_string "date" |]
in
List.iter render_time times;
(*add event image_click to all postImage*)
let post_images =
Jv.to_jv_list
@@ Jv.call document "getElementsByClassName" [| Jv.of_string "postImage" |]
in
let add_click el =
ignore
@@ Jv.call el "addEventListener"
[| Jv.of_string "click"; Jv.repr (image_click el) |]
in
List.iter add_click post_images;
()
(*make pretty after page load*)
let () =
log "add load eventlistener to make pretty@.";
let window = Jv.get Jv.global "window" in
ignore
@@ Jv.call window "addEventListener"
[| Jv.of_string "load"; Jv.repr make_pretty |];
()

2
src/js/js_thread.ml Normal file
View file

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

0
src/leaflet/leaflet.js → src/js/leaflet/leaflet.js
View file

201
src/js_newthread.ml
View file

@ -1,201 +0,0 @@
let log = Format.printf
(*TODO fix duplicate modules *)
module Leaflet = struct
(* get the leaflet object *)
let leaflet =
match Jv.(find global "L") with
| Some l -> l
| None -> failwith "can't load leaflet"
(* get popup object *)
let popup = Jv.call leaflet "popup" [||]
(* create a map *)
let map =
log "creating map@.";
let open Brr in
let _container = El.div ~at:At.[ id (Jstr.v "map") ] [] in
Jv.call leaflet "map" [| Jv.of_string "map" |]
(* create map tile layer *)
let tile_layer =
log "creating tile layer@.";
Jv.call leaflet "tileLayer"
[| Jv.of_string "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
; Jv.obj
[| ( "attribution"
, Jv.of_string
{|&copy; <a href="https://.www.openstreetmap.org/copyright">OpenStreetMap</a> contributors|}
)
|]
|]
(* add tile layer *)
let () =
log "adding tile layer@.";
let _map : Jv.t = Jv.call tile_layer "addTo" [| map |] in
()
let storage = Brr_io.Storage.local Brr.G.window
(* set map's view *)
(* try to set map's view to last position viewed by using web storage *)
let () =
log "setting view@.";
let lat = Brr_io.Storage.get_item storage (Jstr.of_string "lat") in
let lng = Brr_io.Storage.get_item storage (Jstr.of_string "lng") in
let zoom = Brr_io.Storage.get_item storage (Jstr.of_string "zoom") in
match (lat, lng, zoom) with
| Some lat, Some lng, Some zoom ->
let latlng =
Jv.call leaflet "latLng" [| Jv.of_jstr lat; Jv.of_jstr lng |]
in
ignore @@ Jv.call map "setView" [| latlng; Jv.of_jstr zoom |]
| _ ->
let latlng =
Jv.call leaflet "latLng" [| Jv.of_float 51.505; Jv.of_float (-0.09) |]
in
ignore @@ Jv.call map "setView" [| latlng; Jv.of_int 13 |]
let on_moveend _event =
log "on zoomend event@.";
let latlng = Jv.call map "getCenter" [||] in
let lat = Jv.get latlng "lat" in
let lng = Jv.get latlng "lng" in
match
Brr_io.Storage.set_item storage (Jstr.of_string "lat") (Jv.to_jstr lat)
with
| (exception Jv.Error _)
| Error _ ->
failwith "can't set latlng storage"
| Ok () -> (
match
Brr_io.Storage.set_item storage (Jstr.of_string "lng") (Jv.to_jstr lng)
with
| (exception Jv.Error _)
| Error _ ->
failwith "can't set latlng storage"
| Ok () -> () )
let on_zoomend _event =
log "on zoomend event@.";
let zoom = Jv.call map "getZoom" [||] in
match
Brr_io.Storage.set_item storage (Jstr.of_string "zoom") (Jv.to_jstr zoom)
with
| (exception Jv.Error _)
| Error _ ->
failwith "can't set latlng storage"
| Ok () -> ()
let () =
log "add on (move/zoom)end event@.";
ignore @@ Jv.call map "on" [| Jv.of_string "moveend"; Jv.repr on_moveend |];
ignore @@ Jv.call map "on" [| Jv.of_string "zoomend"; Jv.repr on_zoomend |];
()
end
module Geolocalize = struct
let update_location geo =
log "update_location@.";
match geo with
| Error _ -> failwith "error in geolocation"
| Ok geo ->
let lat = Brr_io.Geolocation.Pos.latitude geo in
let lng = Brr_io.Geolocation.Pos.longitude geo in
let latlng =
Jv.call Leaflet.leaflet "latLng" [| Jv.of_float lat; Jv.of_float lng |]
in
ignore @@ Jv.call Leaflet.map "setView" [| latlng; Jv.of_int 13 |];
()
let geolocalize () =
log "geolocalize@.";
let l = Brr_io.Geolocation.of_navigator Brr.G.navigator in
ignore @@ Fut.await (Brr_io.Geolocation.get l) update_location;
()
let () = Jv.set Jv.global "geolocalize" (Jv.repr geolocalize)
end
module Marker = struct
let board =
let board_div = Jv.get Jv.global "board" in
Jv.to_string
(Jv.call board_div "getAttribute" [| Jv.of_string "data-board" |])
let handle_geojson geojson =
log "handle_geojson@.";
log "feed geojson to leaflet@.";
let layer = Jv.call Leaflet.leaflet "geoJSON" [| geojson |] in
let _marker_layer = Jv.call layer "addTo" [| Leaflet.map |] in
()
let markers_handle_response response =
log "markers_handle_response@.";
let geo_json_list_futur = Jv.call response "json" [||] in
ignore @@ Jv.call geo_json_list_futur "then" [| Jv.repr handle_geojson |];
()
let () =
log "fetch thread geojson@.";
let window = Jv.get Jv.global "window" in
let link = Jv.of_string (Format.sprintf "/%s/markers" board) in
let fetchfutur = Jv.call window "fetch" [| link |] in
ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |];
()
end
let on_click e =
log "on_click@.";
let lat_lng = Jv.get e "latlng" in
ignore @@ Jv.call Leaflet.popup "setLatLng" [| lat_lng |];
ignore
@@ Jv.call Leaflet.popup "setContent" [| Jv.of_string "create thread here" |];
ignore @@ Jv.call Leaflet.popup "openOn" [| Leaflet.map |];
let lat = Jv.get lat_lng "lat" in
let lng = Jv.get lat_lng "lng" in
let lat_input = Jv.get Jv.global "lat_input" in
let lng_input = Jv.get Jv.global "lng_input" in
ignore @@ Jv.call lat_input "setAttribute" [| Jv.of_string "value"; lat |];
ignore @@ Jv.call lng_input "setAttribute" [| Jv.of_string "value"; lng |];
let form_div = Jv.get Jv.global "newthread-form" in
ignore
@@ Jv.call form_div "setAttribute"
[| Jv.of_string "style"; Jv.of_string "visibility:visible" |];
let board_div = Jv.get Jv.global "board" in
ignore
@@ Jv.call board_div "setAttribute"
[| Jv.of_string "style"; Jv.of_string "visibility:hidden" |];
()
(*add on_click callback to map*)
let () =
ignore
@@ Jv.call Leaflet.map "on" [| Jv.of_string "click"; Jv.repr on_click |]
(*!Duplicate*)
(* make image description field visible when a file is selected*)
let make_visible alt_input alt_label _event =
let alt_style = Jv.get alt_input "style" in
let alt_label_style = Jv.get alt_label "style" in
ignore @@ Jv.set alt_style "display" (Jv.of_string "block");
ignore @@ Jv.set alt_label_style "display" (Jv.of_string "block");
()
let () =
log "change image description visibility@.";
let file_input = Jv.find Jv.global "file" in
match file_input with
| None -> () (*not post form on the page, not logged in*)
| Some file_input ->
let alt_input = Jv.get Jv.global "alt" in
let alt_label = Jv.get Jv.global "altLabel" in
ignore
@@ Jv.call file_input "addEventListener"
[| Jv.of_string "change"; Jv.repr (make_visible alt_input alt_label) |];
()

106
src/js_thread.ml
View file

@ -1,106 +0,0 @@
let log = Format.printf
(* called by clicking post_id *)
(* insert id into reply form *)
let insert_quote post_id =
log "quote@.";
match Jv.(find global "replyComment") with
| None -> Jv.undefined
| Some comment_textarea ->
let content = Jv.get comment_textarea "value" in
let new_content =
Jv.call content "concat"
[| Jv.of_string "\n>>"; post_id; Jv.of_string " " |]
in
ignore @@ Jv.set comment_textarea "value" new_content;
Jv.undefined
let () = Jv.set Jv.global "insert_quote" (Jv.repr insert_quote)
(*change postImage class to make it bigger/smaller on click*)
let image_click post_image event =
log "image_click@.";
let current_class =
Jv.to_string @@ Jv.call post_image "getAttribute" [| Jv.of_string "class" |]
in
let new_class =
match current_class with
| "postImage" -> "postImageBig"
| "postImageBig" -> "postImage"
| _ -> failwith "invalid image class name"
in
ignore
@@ Jv.call post_image "setAttribute"
[| Jv.of_string "class"; Jv.of_string new_class |];
(*prevent opening image in new tab*)
ignore @@ Jv.call event "preventDefault" [||];
()
(*add event image_click to all postImage*)
let () =
let document = Jv.get Jv.global "document" in
let post_images =
Jv.to_jv_list
@@ Jv.call document "getElementsByClassName" [| Jv.of_string "postImage" |]
in
let add_click el =
ignore
@@ Jv.call el "addEventListener"
[| Jv.of_string "click"; Jv.repr (image_click el) |]
in
List.iter add_click post_images;
()
(*!Duplicate*)
(* make image description field visible when a file is selected*)
let make_visible alt_input alt_label _event =
let alt_style = Jv.get alt_input "style" in
let alt_label_style = Jv.get alt_label "style" in
ignore @@ Jv.set alt_style "display" (Jv.of_string "block");
ignore @@ Jv.set alt_label_style "display" (Jv.of_string "block");
()
let () =
log "change image description visibility@.";
let file_input = Jv.find Jv.global "file" in
match file_input with
| None -> () (*not post form on the page, not logged in*)
| Some file_input ->
let alt_input = Jv.get Jv.global "alt" in
let alt_label = Jv.get Jv.global "altLabel" in
ignore
@@ Jv.call file_input "addEventListener"
[| Jv.of_string "change"; Jv.repr (make_visible alt_input alt_label) |];
()
let () =
log "render time@.";
let document = Jv.get Jv.global "document" in
let times =
Jv.to_jv_list
@@ Jv.call document "getElementsByClassName" [| Jv.of_string "date" |]
in
let render_time date_span =
let unix_time =
float_of_int
(Jv.to_int
(Jv.call date_span "getAttribute" [| Jv.of_string "data-time" |]) )
in
(*use float because int overflow*)
let time_millisecs = 1000.0 *. unix_time in
let date_constructor = Jv.get Jv.global "Date" in
let date = Jv.new' date_constructor [| Jv.of_float time_millisecs |] in
let year = Jv.to_int @@ Jv.call date "getFullYear" [||] in
(*the month is 0-indexed*)
let month = (Jv.to_int @@ Jv.call date "getMonth" [||]) + 1 in
let day = Jv.to_int @@ Jv.call date "getDate" [||] in
let hour = Jv.to_int @@ Jv.call date "getHours" [||] in
let min = Jv.to_int @@ Jv.call date "getMinutes" [||] in
let date_string =
Format.sprintf "%02d-%02d-%02d %02d:%02d" year month day hour min
in
ignore @@ Jv.set date_span "innerHTML" (Jv.of_string date_string);
()
in
List.iter render_time times;
()

3
src/newthread_page.eml.html
View file

@ -6,7 +6,8 @@ let f ~board request =
Login to make a new thread.
% | Some _nick ->
<script type="text/javascript" src="/assets/js/js_newthread.js" defer="defer"></script>
<div id="board" data-board=<%s board %> >Click the map to make a new thread:</div>
<div id="newthread">Click the map to make a new thread:</div>
<div id="board" data-board=<%s board %> ></div>
<div class="row mb-3">
<div class="col-md-6">
<div id="map"></div>