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

/new_thread -> /

Browse source
This commit is contained in:
Swrup 2022-02-22 06:07:29 +01:00
parent bb5fb41c2b
commit b0aaf22ea7
10 changed files with 168 additions and 171 deletions
Download patch file Download diff file Expand all files Collapse all files

44
src/babillard_page.eml.html
View file

@ -1,9 +1,10 @@
let f request =
% let new_thread_url =
% let new_thread_button =
% if Option.is_none @@ Dream.session "nick" request then
% Format.sprintf "/login?redirect=%s" (Dream.to_percent_encoded "/new_thread")
% else "/new_thread"
% Format.sprintf
% {|<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>
<h1>Babillard is love ❤️</h1>
@ -13,10 +14,41 @@ let f request =
<div id="map"></div>
<br />
<button class="btn btn-primary" id="geolocalize">Geolocalize me</button>
<a class="btn btn-primary" href="<%s! new_thread_url %>">New Thread</a>
<button class="btn btn-primary off" id="return-button">Return</button>
<%s! new_thread_button %>
</div>
<div class="col-md-6">
<div id="thread_preview_div"></div>
<a id="thread_link"></a>
<div class="thread-preview on" id="thread-preview"></div>
<div class="new-thread off" id="new-thread">
<h1>New thread</h1>
<span id="new-thread-info">
Click the map and make a new thread:
</span>
<br />
<div class="postForm">
<%s! Dream.form_tag ~action:"/" ~enctype:`Multipart_form_data request %>
<input type="hidden" id="lat-input" name="lat-input">
<input type="hidden" id="lng-input" name="lng-input">
<label for="subject" id="subject-label" class="form-label">Subject</label>
<input name="subject" type="text" class="form-control" id="subject" aria-labelledby="subject-label"></input>
<br />
<label for="thread-comment" id="thread-comment-label" class="form-label">Comment</label>
<textarea name="thread-comment" type="text" class="form-control" id="thread-comment" aria-labelledby="thread-comment-label"></textarea>
<br />
<label for="tags" id="tags-label" class="form-label">Tags</label>
<input name="tags" type="text" class="form-control" id="tags" aria-labelledby="tags-label"></input>
<br />
<label for="file" id="file-label" class="form-label">Picture:</label>
<input id="file" name="file" aria-describedby="file-label" type="file" accept="image/*">
<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"></input>
<br />
<button type="submit" class="btn btn-primary" id="submit-new-thread-button" disabled>Make Thread</button>
</form>
</div>
</div>
</div>

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

@ -131,3 +131,10 @@ a.preview-link {
border-radius: 4px;
padding: 2px;
}
.on {
}
.off {
display: none;
}

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

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

8
src/dune
View file

@ -10,7 +10,6 @@
db
delete_page
login
newthread_page
permap
pp_babillard
register
@ -61,12 +60,6 @@
(action
(run dream_eml %{deps} --workspace %{workspace_root})))
(rule
(targets newthread_page.ml)
(deps newthread_page.eml.html)
(action
(run dream_eml %{deps} --workspace %{workspace_root})))
(rule
(targets register.ml)
(deps register.eml.html)
@ -97,7 +90,6 @@
(source_tree content)
(file content/assets/js/js_babillard.js)
(file content/assets/js/js_catalog.js)
(file content/assets/js/js_newthread.js)
(file content/assets/js/js_thread.js))
(action
(with-stdout-to

12
src/js/dune
View file

@ -15,7 +15,7 @@
(library
(name js_map)
(modules js_map)
(libraries js_of_ocaml brr js_pretty_post)
(libraries js_of_ocaml brr)
(js_of_ocaml
(javascript_files leaflet/leaflet.js))
(preprocess
@ -32,15 +32,7 @@
(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)
(libraries js_of_ocaml brr js_map js_post_form js_pretty_post)
(modes js)
(preprocess
(pps js_of_ocaml-ppx)))

120
src/js/js_babillard.ml
View file

@ -1 +1,119 @@
include Js_map
open Js_map
include Js_post_form
module Visibility = struct
let is_in_new_thread_mode () =
log "is_in_new_thread_mode?@\n";
let new_thread_div = Jv.get Jv.global "new-thread" in
let class_list = Jv.get new_thread_div "classList" in
Jv.to_bool @@ Jv.call class_list "contains" [| Jv.of_string "on" |]
let set visible el =
log "set (un)visible@\n";
let class_list = Jv.get el "classList" in
if visible then
ignore
@@ Jv.call class_list "replace"
[| Jv.of_string "off"; Jv.of_string "on" |]
else
ignore
@@ Jv.call class_list "replace"
[| Jv.of_string "on"; Jv.of_string "off" |]
let change_page_mode ~form_visibility _event =
log "change_page_mode@\n";
let new_thread_div = Jv.get Jv.global "new-thread" in
let thread_preview_div = Jv.get Jv.global "thread-preview" in
let new_thread_button = Jv.get Jv.global "new-thread-button" in
let return_button = Jv.get Jv.global "return-button" in
let () = set form_visibility new_thread_div in
let () = set form_visibility return_button in
let () = set (not form_visibility) thread_preview_div in
let () = set (not form_visibility) new_thread_button in
ignore @@ Jv.call Leaflet.map "closePopup" [||]
let () =
log "add events on return/new thread button@\n";
let return_button = Jv.get Jv.global "return-button" in
ignore
@@ Jv.call return_button "addEventListener"
[| Jv.of_string "click"
; Jv.repr (change_page_mode ~form_visibility:false)
|];
(* new-thread-button is new-thread-button-redirect if not logged in *)
let opt = Jv.find Jv.global "new-thread-button" in
if Option.is_some opt then
let new_thread_button = Option.get opt in
ignore
@@ Jv.call new_thread_button "addEventListener"
[| Jv.of_string "click"
; Jv.repr (change_page_mode ~form_visibility:true)
|]
end
module Marker = struct
let marker_on_click thread_preview _e =
log "marker_on_click@\n";
if not (Visibility.is_in_new_thread_mode ()) then (
let thread_preview_div = Jv.get Jv.global "thread-preview" in
ignore @@ Jv.set thread_preview_div "innerHTML" thread_preview;
let _ = Js_pretty_post.make_pretty () in
() )
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
ignore
@@ Jv.call layer "on"
[| Jv.of_string "click"; Jv.repr (marker_on_click thread_preview) |]
let handle_geojson geojson =
log "handle_geojson@\n";
log "feed geojson to leaflet@\n";
(* make markers unresponsive on*)
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
()
let markers_handle_response response =
log "markers_handle_response@\n";
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@\n";
let window = Jv.get Jv.global "window" in
let link = Jv.of_string "/markers" in
let fetchfutur = Jv.call window "fetch" [| link |] in
ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |]
end
(* set input lat/lng when clicked*)
let on_click_set_latlng e =
log "on_click_set_latlng@\n";
if Visibility.is_in_new_thread_mode () then (
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 |];
log "on_click_set_latlng: disableb disabled@\n";
let button = Jv.get Jv.global "submit-new-thread-button" in
ignore @@ Jv.call button "removeAttribute" [| Jv.of_string "disabled" |] )
(*add on_click callback to map*)
let () =
ignore
@@ Jv.call Leaflet.map "on"
[| Jv.of_string "click"; Jv.repr on_click_set_latlng |]

53
src/js/js_map.ml
View file

@ -121,56 +121,3 @@ module Geolocalize = struct
@@ Jv.call button "addEventListener"
[| Jv.of_string "click"; Jv.repr geolocalize |]
end
module Marker = struct
(*todo do this in js_babillard*)
let marker_on_click thread_preview thread_id _e =
log "marker_on_click@\n";
let thread_id = Jv.to_string thread_id in
let thread_preview_div = Jv.get Jv.global "thread_preview_div" in
ignore @@ Jv.set thread_preview_div "innerHTML" thread_preview;
let thread_link = Jv.get Jv.global "thread_link" in
let link = Format.sprintf "/thread/%s" 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 =
log "on_each_feature@\n";
let feature_properties = Jv.get feature "properties" in
let thread_preview = Jv.get feature_properties "content" in
let thread_id = Jv.get feature_properties "thread_id" in
ignore
@@ Jv.call layer "on"
[| Jv.of_string "click"
; Jv.repr (marker_on_click thread_preview thread_id)
|]
let handle_geojson geojson =
log "handle_geojson@\n";
log "feed geojson to leaflet@\n";
(* 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@\n";
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@\n";
let window = Jv.get Jv.global "window" in
let link = Jv.of_string "/markers" in
let fetchfutur = Jv.call window "fetch" [| link |] in
ignore @@ Jv.call fetchfutur "then" [| Jv.repr markers_handle_response |]
end

32
src/js/js_newthread.ml
View file

@ -1,35 +1,3 @@
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@\n";
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 |]

47
src/newthread_page.eml.html
View file

@ -1,47 +0,0 @@
let f request =
% begin match Dream.session "nick" request with
% | None ->
% let redirect = Dream.to_percent_encoded "/new_thread" in
<a href="/login?redirect=<%s redirect%>">Login</a> to make a new thread.
% | Some _nick ->
<script type="text/javascript" src="/assets/js/js_newthread.js" defer="defer"></script>
<h1>New thread</h1>
<div id="newthread">
Click the map to make a new thread:
</div>
<br />
<div class="row mb-3">
<div class="col-md-6">
<div id="map"></div>
<br />
<button class="btn btn-primary" id="geolocalize">Geolocalize me</button>
<br />
<br />
</div>
<div class="col-md-6" id="newthread-form">
<div class="postForm">
<%s! Dream.form_tag ~action:"/new_thread" ~enctype:`Multipart_form_data request %>
<input type="hidden" id="lat-input" name="lat-input">
<input type="hidden" id="lng-input" name="lng-input">
<label for="subject" id="subject-label" class="form-label">Subject</label>
<input name="subject" type="text" class="form-control" id="subject" aria-labelledby="subject-label"></input>
<br />
<label for="thread-comment" id="thread-comment-label" class="form-label">Comment</label>
<textarea name="thread-comment" type="text" class="form-control" id="thread-comment" aria-labelledby="thread-comment-label"></textarea>
<br />
<label for="tags" id="tags-label" class="form-label">Tags</label>
<input name="tags" type="text" class="form-control" id="tags" aria-labelledby="tags-label"></input>
<br />
<label for="file" id="file-label" class="form-label">Picture:</label>
<input id="file" name="file" aria-describedby="file-label" type="file" accept="image/*">
<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"></input>
<br />
<button type="submit" class="btn btn-primary">Make Thread</button>
</form>
</div>
</div>
</div>
% end;

7
src/permap.ml
View file

@ -171,9 +171,7 @@ let markers request =
let babillard_get request = render_unsafe (Babillard_page.f request) request
let newthread_get request = render_unsafe (Newthread_page.f request) request
let newthread_post request =
let babillard_post request =
match Dream.session "nick" request with
| None -> render_unsafe "Not logged in" request
| Some nick -> (
@ -274,6 +272,7 @@ let routes =
let post = Dream.post in
[ get_ "/" babillard_get
; post "/" babillard_post
; get_ "/about" about
; get_ "/assets/**" (Dream.static ~loader:asset_loader "")
; get_ "/catalog" catalog
@ -284,8 +283,6 @@ let routes =
; post "/login" login_post
; get_ "/logout" logout
; get_ "/markers" markers
; get_ "/new_thread" newthread_get
; post "/new_thread" newthread_post
; get_ "/post_pic/:post_id" post_image
; get_ "/profile" profile_get
; post "/profile" profile_post